1 // Copyright (c) 1999-2014 OPEN CASCADE SAS
2 //
3 // This file is part of Open CASCADE Technology software library.
4 //
5 // This library is free software; you can redistribute it and/or modify it under
6 // the terms of the GNU Lesser General Public License version 2.1 as published
7 // by the Free Software Foundation, with special exception defined in the file
8 // OCCT_LGPL_EXCEPTION.txt. Consult the file LICENSE_LGPL_21.txt included in OCCT
9 // distribution for complete text of the license and disclaimer of any warranty.
10 //
11 // Alternatively, this file may be used under the terms of Open CASCADE
12 // commercial license or contractual agreement.
13
14 // AdvApp2Var_MathBase.cxx
15 #include <math.h>
16 #include <AdvApp2Var_SysBase.hxx>
17 #include <AdvApp2Var_Data_f2c.hxx>
18 #include <AdvApp2Var_MathBase.hxx>
19 #include <AdvApp2Var_Data.hxx>
20 #include <NCollection_Array1.hxx>
21
22 // statics
23 static
24 int mmchole_(integer *mxcoef,
25 integer *dimens,
26 doublereal *amatri,
27 integer *aposit,
28 integer *posuiv,
29 doublereal *chomat,
30 integer *iercod);
31
32
33
34
35 static
36 int mmrslss_(integer *mxcoef,
37 integer *dimens,
38 doublereal *smatri,
39 integer *sposit,
40 integer *posuiv,
41 doublereal *mscnmbr,
42 doublereal *soluti,
43 integer *iercod);
44
45 static
46 int mfac_(doublereal *f,
47 integer *n);
48
49 static
50 int mmaper0_(integer *ncofmx,
51 integer *ndimen,
52 integer *ncoeff,
53 doublereal *crvlgd,
54 integer *ncfnew,
55 doublereal *ycvmax,
56 doublereal *errmax);
57 static
58 int mmaper2_(integer *ncofmx,
59 integer *ndimen,
60 integer *ncoeff,
61 doublereal *crvjac,
62 integer *ncfnew,
63 doublereal *ycvmax,
64 doublereal *errmax);
65
66 static
67 int mmaper4_(integer *ncofmx,
68 integer *ndimen,
69 integer *ncoeff,
70 doublereal *crvjac,
71 integer *ncfnew,
72 doublereal *ycvmax,
73 doublereal *errmax);
74
75 static
76 int mmaper6_(integer *ncofmx,
77 integer *ndimen,
78 integer *ncoeff,
79 doublereal *crvjac,
80 integer *ncfnew,
81 doublereal *ycvmax,
82 doublereal *errmax);
83
84 static
85 int mmarc41_(integer *ndimax,
86 integer *ndimen,
87 integer *ncoeff,
88 doublereal *crvold,
89 doublereal *upara0,
90 doublereal *upara1,
91 doublereal *crvnew,
92 integer *iercod);
93
94 static
95 int mmatvec_(integer *nligne,
96 integer *ncolon,
97 integer *gposit,
98 integer *gnstoc,
99 doublereal *gmatri,
100 doublereal *vecin,
101 integer *deblig,
102 doublereal *vecout,
103 integer *iercod);
104
105 static
106 int mmcvstd_(integer *ncofmx,
107 integer *ndimax,
108 integer *ncoeff,
109 integer *ndimen,
110 doublereal *crvcan,
111 doublereal *courbe);
112
113 static
114 int mmdrvcb_(integer *ideriv,
115 integer *ndim,
116 integer *ncoeff,
117 doublereal *courbe,
118 doublereal *tparam,
119 doublereal *tabpnt,
120 integer *iercod);
121
122 static
123 int mmexthi_(integer *ndegre,
124 NCollection_Array1<doublereal>& hwgaus);
125
126 static
127 int mmextrl_(integer *ndegre,
128 NCollection_Array1<doublereal>& rootlg);
129
130
131
132 static
133 int mmherm0_(doublereal *debfin,
134 integer *iercod);
135
136 static
137 int mmherm1_(doublereal *debfin,
138 integer *ordrmx,
139 integer *iordre,
140 doublereal *hermit,
141 integer *iercod);
142 static
143 int mmloncv_(integer *ndimax,
144 integer *ndimen,
145 integer *ncoeff,
146 doublereal *courbe,
147 doublereal *tdebut,
148 doublereal *tfinal,
149 doublereal *xlongc,
150 integer *iercod);
151 static
152 int mmpojac_(doublereal *tparam,
153 integer *iordre,
154 integer *ncoeff,
155 integer *nderiv,
156 NCollection_Array1<doublereal>& valjac,
157 integer *iercod);
158
159 static
160 int mmrslw_(integer *normax,
161 integer *nordre,
162 integer *ndimen,
163 doublereal *epspiv,
164 doublereal *abmatr,
165 doublereal *xmatri,
166 integer *iercod);
167 static
168 int mmtmave_(integer *nligne,
169 integer *ncolon,
170 integer *gposit,
171 integer *gnstoc,
172 doublereal *gmatri,
173 doublereal *vecin,
174 doublereal *vecout,
175 integer *iercod);
176 static
177 int mmtrpj0_(integer *ncofmx,
178 integer *ndimen,
179 integer *ncoeff,
180 doublereal *epsi3d,
181 doublereal *crvlgd,
182 doublereal *ycvmax,
183 doublereal *epstrc,
184 integer *ncfnew);
185 static
186 int mmtrpj2_(integer *ncofmx,
187 integer *ndimen,
188 integer *ncoeff,
189 doublereal *epsi3d,
190 doublereal *crvlgd,
191 doublereal *ycvmax,
192 doublereal *epstrc,
193 integer *ncfnew);
194
195 static
196 int mmtrpj4_(integer *ncofmx,
197 integer *ndimen,
198 integer *ncoeff,
199 doublereal *epsi3d,
200 doublereal *crvlgd,
201 doublereal *ycvmax,
202 doublereal *epstrc,
203 integer *ncfnew);
204 static
205 int mmtrpj6_(integer *ncofmx,
206 integer *ndimen,
207 integer *ncoeff,
208 doublereal *epsi3d,
209 doublereal *crvlgd,
210 doublereal *ycvmax,
211 doublereal *epstrc,
212 integer *ncfnew);
213 static
214 integer pow__ii(integer *x,
215 integer *n);
216
217 static
218 int mvcvin2_(integer *ncoeff,
219 doublereal *crvold,
220 doublereal *crvnew,
221 integer *iercod);
222
223 static
224 int mvcvinv_(integer *ncoeff,
225 doublereal *crvold,
226 doublereal *crvnew,
227 integer *iercod);
228
229 static
230 int mvgaus0_(integer *kindic,
231 doublereal *urootl,
232 doublereal *hiltab,
233 integer *nbrval,
234 integer *iercod);
235 static
236 int mvpscr2_(integer *ncoeff,
237 doublereal *curve2,
238 doublereal *tparam,
239 doublereal *pntcrb);
240
241 static
242 int mvpscr3_(integer *ncoeff,
243 doublereal *curve2,
244 doublereal *tparam,
245 doublereal *pntcrb);
246
247 static struct {
248 doublereal eps1, eps2, eps3, eps4;
249 integer niterm, niterr;
250 } mmprcsn_;
251
252 static struct {
253 doublereal tdebut, tfinal, verifi, cmherm[576];
254 } mmcmher_;
255
256 //=======================================================================
257 //function : AdvApp2Var_MathBase::mdsptpt_
258 //purpose :
259 //=======================================================================
mdsptpt_(integer * ndimen,doublereal * point1,doublereal * point2,doublereal * distan)260 int AdvApp2Var_MathBase::mdsptpt_(integer *ndimen,
261 doublereal *point1,
262 doublereal *point2,
263 doublereal *distan)
264
265 {
266 integer c__8 = 8;
267 /* System generated locals */
268 integer i__1;
269 doublereal d__1;
270
271 /* Local variables */
272 integer i__;
273 doublereal* differ = 0;
274 integer ier;
275 intptr_t iofset, j;
276
277 /* **********************************************************************
278 */
279
280 /* FUNCTION : */
281 /* ---------- */
282 /* CALCULATE DISTANCE BETWEEN TWO POINTS */
283
284 /* KEYWORDS : */
285 /* ----------- */
286 /* DISTANCE,POINT. */
287
288 /* INPUT ARGUMENTS : */
289 /* ------------------ */
290 /* NDIMEN: Space Dimension. */
291 /* POINT1: Table of coordinates of the 1st point. */
292 /* POINT2: Table of coordinates of the 2nd point. */
293
294 /* OUTPUT ARGUMENTS : */
295 /* ------------------- */
296 /* DISTAN: Distance between 2 points. */
297
298 /* COMMONS USED : */
299 /* ---------------- */
300
301 /* REFERENCES CALLED : */
302 /* ----------------------- */
303
304 /* DESCRIPTION/NOTES/LIMITATIONS : */
305 /* ----------------------------------- */
306 /* > */
307 /* **********************************************************************
308 */
309
310
311 /* ***********************************************************************
312 */
313 /* INITIALISATION */
314 /* ***********************************************************************
315 */
316
317 /* Parameter adjustment */
318 --point2;
319 --point1;
320
321 /* Function Body */
322 iofset = 0;
323 ier = 0;
324
325 /* ***********************************************************************
326 */
327 /* TRAITEMENT */
328 /* ***********************************************************************
329 */
330
331 AdvApp2Var_SysBase anAdvApp2Var_SysBase;
332 if (*ndimen > 100) {
333 anAdvApp2Var_SysBase.mcrrqst_(&c__8, ndimen, differ, &iofset, &ier);
334 }
335
336 /* --- If allocation is refused, the trivial method is applied. */
337
338 if (ier > 0) {
339
340 *distan = 0.;
341 i__1 = *ndimen;
342 for (i__ = 1; i__ <= i__1; ++i__) {
343 /* Computing 2nd power */
344 d__1 = point1[i__] - point2[i__];
345 *distan += d__1 * d__1;
346 }
347 *distan = sqrt(*distan);
348
349 /* --- Otherwise MZSNORM is used to minimize the risks of overflow
350 */
351
352 } else {
353 i__1 = *ndimen;
354 for (i__ = 1; i__ <= i__1; ++i__) {
355 j=iofset + i__ - 1;
356 differ[j] = point2[i__] - point1[i__];
357 }
358
359 *distan = AdvApp2Var_MathBase::mzsnorm_(ndimen, &differ[iofset]);
360
361 }
362
363 /* ***********************************************************************
364 */
365 /* RETURN CALLING PROGRAM */
366 /* ***********************************************************************
367 */
368
369 /* --- Dynamic Desallocation */
370
371 if (iofset != 0) {
372 anAdvApp2Var_SysBase.mcrdelt_(&c__8, ndimen, differ, &iofset, &ier);
373 }
374
375 return 0 ;
376 } /* mdsptpt_ */
377
378 //=======================================================================
379 //function : mfac_
380 //purpose :
381 //=======================================================================
mfac_(doublereal * f,integer * n)382 int mfac_(doublereal *f,
383 integer *n)
384
385 {
386 /* System generated locals */
387 integer i__1;
388
389 /* Local variables */
390 integer i__;
391
392 /* FORTRAN CONFORME AU TEXT */
393 /* CALCUL DE MFACTORIEL N */
394 /* Parameter adjustments */
395 --f;
396
397 /* Function Body */
398 f[1] = (float)1.;
399 i__1 = *n;
400 for (i__ = 2; i__ <= i__1; ++i__) {
401 /* L10: */
402 f[i__] = i__ * f[i__ - 1];
403 }
404 return 0;
405 } /* mfac_ */
406
407 //=======================================================================
408 //function : AdvApp2Var_MathBase::mmapcmp_
409 //purpose :
410 //=======================================================================
mmapcmp_(integer * ndim,integer * ncofmx,integer * ncoeff,doublereal * crvold,doublereal * crvnew)411 int AdvApp2Var_MathBase::mmapcmp_(integer *ndim,
412 integer *ncofmx,
413 integer *ncoeff,
414 doublereal *crvold,
415 doublereal *crvnew)
416
417 {
418 /* System generated locals */
419 integer crvold_dim1, crvold_offset, crvnew_dim1, crvnew_offset, i__1,
420 i__2;
421
422 /* Local variables */
423 integer ipair, nd, ndegre, impair, ibb, idg;
424 //extern int mgsomsg_();//mgenmsg_(),
425
426 /* **********************************************************************
427 */
428
429 /* FUNCTION : */
430 /* ---------- */
431 /* Compression of curve CRVOLD in a table of */
432 /* coeff. of even : CRVNEW(*,0,*) */
433 /* and uneven range : CRVNEW(*,1,*). */
434
435 /* KEYWORDS : */
436 /* ----------- */
437 /* COMPRESSION,CURVE. */
438
439 /* INPUT ARGUMENTS : */
440 /* ------------------ */
441 /* NDIM : Space Dimension. */
442 /* NCOFMX : Max nb of coeff. of the curve to compress. */
443 /* NCOEFF : Max nb of coeff. of the compressed curve. */
444 /* CRVOLD : The curve (0:NCOFMX-1,NDIM) to compress. */
445
446 /* OUTPUT ARGUMENTS : */
447 /* ------------------- */
448 /* CRVNEW : Curve compacted in (0:(NCOEFF-1)/2,0,NDIM) (containing
449 */
450 /* even terms) and in (0:(NCOEFF-1)/2,1,NDIM) */
451 /* (containing uneven terms). */
452
453 /* COMMONS USED : */
454 /* ---------------- */
455
456 /* REFERENCES CALLED : */
457 /* ----------------------- */
458
459 /* DESCRIPTION/NOTES/LIMITATIONS : */
460 /* ----------------------------------- */
461 /* This routine is useful to prepare coefficients of a */
462 /* curve in an orthogonal base (Legendre or Jacobi) before */
463 /* calculating the coefficients in the canonical; base [-1,1] by */
464 /* MMJACAN. */
465 /* ***********************************************************************
466 */
467
468 /* Name of the routine */
469
470 /* Parameter adjustments */
471 crvold_dim1 = *ncofmx;
472 crvold_offset = crvold_dim1;
473 crvold -= crvold_offset;
474 crvnew_dim1 = (*ncoeff - 1) / 2 + 1;
475 crvnew_offset = crvnew_dim1 << 1;
476 crvnew -= crvnew_offset;
477
478 /* Function Body */
479 ibb = AdvApp2Var_SysBase::mnfndeb_();
480 if (ibb >= 3) {
481 AdvApp2Var_SysBase::mgenmsg_("MMAPCMP", 7L);
482 }
483
484 ndegre = *ncoeff - 1;
485 i__1 = *ndim;
486 for (nd = 1; nd <= i__1; ++nd) {
487 ipair = 0;
488 i__2 = ndegre / 2;
489 for (idg = 0; idg <= i__2; ++idg) {
490 crvnew[idg + (nd << 1) * crvnew_dim1] = crvold[ipair + nd *
491 crvold_dim1];
492 ipair += 2;
493 /* L200: */
494 }
495 if (ndegre < 1) {
496 goto L400;
497 }
498 impair = 1;
499 i__2 = (ndegre - 1) / 2;
500 for (idg = 0; idg <= i__2; ++idg) {
501 crvnew[idg + ((nd << 1) + 1) * crvnew_dim1] = crvold[impair + nd *
502 crvold_dim1];
503 impair += 2;
504 /* L300: */
505 }
506
507 L400:
508 /* L100: */
509 ;
510 }
511
512 /* ---------------------------------- The end ---------------------------
513 */
514
515 if (ibb >= 3) {
516 AdvApp2Var_SysBase::mgsomsg_("MMAPCMP", 7L);
517 }
518 return 0;
519 } /* mmapcmp_ */
520
521 //=======================================================================
522 //function : mmaper0_
523 //purpose :
524 //=======================================================================
mmaper0_(integer * ncofmx,integer * ndimen,integer * ncoeff,doublereal * crvlgd,integer * ncfnew,doublereal * ycvmax,doublereal * errmax)525 int mmaper0_(integer *ncofmx,
526 integer *ndimen,
527 integer *ncoeff,
528 doublereal *crvlgd,
529 integer *ncfnew,
530 doublereal *ycvmax,
531 doublereal *errmax)
532
533 {
534 /* System generated locals */
535 integer crvlgd_dim1, crvlgd_offset, i__1, i__2;
536 doublereal d__1;
537
538 /* Local variables */
539 integer ncut;
540 doublereal bidon;
541 integer ii, nd;
542
543 /* ***********************************************************************
544 */
545
546 /* FUNCTION : */
547 /* ---------- */
548 /* Calculate the max error of approximation done when */
549 /* only the first NCFNEW coefficients of a curve are preserved.
550 */
551 /* Degree NCOEFF-1 written in the base of Legendre (Jacobi */
552 /* of order 0). */
553
554 /* KEYWORDS : */
555 /* ----------- */
556 /* LEGENDRE,POLYGON,APPROXIMATION,ERROR. */
557
558 /* INPUT ARGUMENTS : */
559 /* ------------------ */
560 /* NCOFMX : Max. degree of the curve. */
561 /* NDIMEN : Space dimension. */
562 /* NCOEFF : Degree +1 of the curve. */
563 /* CRVLGD : Curve the degree which of should be lowered. */
564 /* NCFNEW : Degree +1 of the resulting polynom. */
565
566 /* OUTPUT ARGUMENTS : */
567 /* ------------------- */
568 /* YCVMAX : Auxiliary Table (max error on each dimension).
569 */
570 /* ERRMAX : Precision of the approximation. */
571
572 /* COMMONS USED : */
573 /* ---------------- */
574
575 /* REFERENCES CALLED : */
576 /* ----------------------- */
577
578 /* DESCRIPTION/NOTES/LIMITATIONS : */
579 /* ----------------------------------- */
580 /* ***********************************************************************
581 */
582
583
584 /* ------------------- Init to calculate an error -----------------------
585 */
586
587 /* Parameter adjustments */
588 --ycvmax;
589 crvlgd_dim1 = *ncofmx;
590 crvlgd_offset = crvlgd_dim1 + 1;
591 crvlgd -= crvlgd_offset;
592
593 /* Function Body */
594 i__1 = *ndimen;
595 for (ii = 1; ii <= i__1; ++ii) {
596 ycvmax[ii] = 0.;
597 /* L100: */
598 }
599
600 /* ------ Minimum that can be reached : Stop at 1 or NCFNEW ------
601 */
602
603 ncut = 1;
604 if (*ncfnew + 1 > ncut) {
605 ncut = *ncfnew + 1;
606 }
607
608 /* -------------- Elimination of high degree coefficients-----------
609 */
610 /* ----------- Loop on the series of Legendre: NCUT --> NCOEFF --------
611 */
612
613 i__1 = *ncoeff;
614 for (ii = ncut; ii <= i__1; ++ii) {
615 /* Factor of renormalization (Maximum of Li(t)). */
616 bidon = ((ii - 1) * 2. + 1.) / 2.;
617 bidon = sqrt(bidon);
618
619 i__2 = *ndimen;
620 for (nd = 1; nd <= i__2; ++nd) {
621 ycvmax[nd] += (d__1 = crvlgd[ii + nd * crvlgd_dim1], advapp_abs(d__1)) *
622 bidon;
623 /* L310: */
624 }
625 /* L300: */
626 }
627
628 /* -------------- The error is the norm of the vector error ---------------
629 */
630
631 *errmax = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
632
633 /* --------------------------------- Fin --------------------------------
634 */
635
636 return 0;
637 } /* mmaper0_ */
638
639 //=======================================================================
640 //function : mmaper2_
641 //purpose :
642 //=======================================================================
mmaper2_(integer * ncofmx,integer * ndimen,integer * ncoeff,doublereal * crvjac,integer * ncfnew,doublereal * ycvmax,doublereal * errmax)643 int mmaper2_(integer *ncofmx,
644 integer *ndimen,
645 integer *ncoeff,
646 doublereal *crvjac,
647 integer *ncfnew,
648 doublereal *ycvmax,
649 doublereal *errmax)
650
651 {
652 /* Initialized data */
653
654 static doublereal xmaxj[57] = { .9682458365518542212948163499456,
655 .986013297183269340427888048593603,
656 1.07810420343739860362585159028115,
657 1.17325804490920057010925920756025,
658 1.26476561266905634732910520370741,
659 1.35169950227289626684434056681946,
660 1.43424378958284137759129885012494,
661 1.51281316274895465689402798226634,
662 1.5878364329591908800533936587012,
663 1.65970112228228167018443636171226,
664 1.72874345388622461848433443013543,
665 1.7952515611463877544077632304216,
666 1.85947199025328260370244491818047,
667 1.92161634324190018916351663207101,
668 1.98186713586472025397859895825157,
669 2.04038269834980146276967984252188,
670 2.09730119173852573441223706382076,
671 2.15274387655763462685970799663412,
672 2.20681777186342079455059961912859,
673 2.25961782459354604684402726624239,
674 2.31122868752403808176824020121524,
675 2.36172618435386566570998793688131,
676 2.41117852396114589446497298177554,
677 2.45964731268663657873849811095449,
678 2.50718840313973523778244737914028,
679 2.55385260994795361951813645784034,
680 2.59968631659221867834697883938297,
681 2.64473199258285846332860663371298,
682 2.68902863641518586789566216064557,
683 2.73261215675199397407027673053895,
684 2.77551570192374483822124304745691,
685 2.8177699459714315371037628127545,
686 2.85940333797200948896046563785957,
687 2.90044232019793636101516293333324,
688 2.94091151970640874812265419871976,
689 2.98083391718088702956696303389061,
690 3.02023099621926980436221568258656,
691 3.05912287574998661724731962377847,
692 3.09752842783622025614245706196447,
693 3.13546538278134559341444834866301,
694 3.17295042316122606504398054547289,
695 3.2099992681699613513775259670214,
696 3.24662674946606137764916854570219,
697 3.28284687953866689817670991319787,
698 3.31867291347259485044591136879087,
699 3.35411740487202127264475726990106,
700 3.38919225660177218727305224515862,
701 3.42390876691942143189170489271753,
702 3.45827767149820230182596660024454,
703 3.49230918177808483937957161007792,
704 3.5260130200285724149540352829756,
705 3.55939845146044235497103883695448,
706 3.59247431368364585025958062194665,
707 3.62524904377393592090180712976368,
708 3.65773070318071087226169680450936,
709 3.68992700068237648299565823810245,
710 3.72184531357268220291630708234186 };
711
712 /* System generated locals */
713 integer crvjac_dim1, crvjac_offset, i__1, i__2;
714 doublereal d__1;
715
716 /* Local variables */
717 integer idec, ncut;
718 doublereal bidon;
719 integer ii, nd;
720
721
722
723 /* ***********************************************************************
724 */
725
726 /* FONCTION : */
727 /* ---------- */
728 /* Calculate max approximation error i faite lorsque l' on */
729 /* ne conserve que les premiers NCFNEW coefficients d' une courbe
730 */
731 /* de degre NCOEFF-1 ecrite dans la base de Jacobi d' ordre 2. */
732
733 /* KEYWORDS : */
734 /* ----------- */
735 /* JACOBI, POLYGON, APPROXIMATION, ERROR. */
736 /**/
737 /* INPUT ARGUMENTS : */
738 /* ------------------ */
739 /* NCOFMX : Max. degree of the curve. */
740 /* NDIMEN : Space dimension. */
741 /* NCOEFF : Degree +1 of the curve. */
742 /* CRVLGD : Curve the degree which of should be lowered. */
743 /* NCFNEW : Degree +1 of the resulting polynom. */
744
745 /* OUTPUT ARGUMENTS : */
746 /* ------------------- */
747 /* YCVMAX : Auxiliary Table (max error on each dimension).
748 */
749 /* ERRMAX : Precision of the approximation. */
750
751 /* COMMONS USED : */
752 /* ---------------- */
753
754 /* REFERENCES CALLED : */
755 /* ----------------------- */
756 /* DESCRIPTION/NOTES/LIMITATIONS : */
757 /* ----------------------------------- */
758
759
760
761 /* ------------------ Table of maximums of (1-t2)*Ji(t) ----------------
762 */
763
764 /* Parameter adjustments */
765 --ycvmax;
766 crvjac_dim1 = *ncofmx;
767 crvjac_offset = crvjac_dim1 + 1;
768 crvjac -= crvjac_offset;
769
770 /* Function Body */
771
772
773
774 /* ------------------- Init for error calculation -----------------------
775 */
776
777 i__1 = *ndimen;
778 for (ii = 1; ii <= i__1; ++ii) {
779 ycvmax[ii] = 0.;
780 /* L100: */
781 }
782
783 /* ------ Min. Degree that can be attained : Stop at 3 or NCFNEW ------
784 */
785
786 idec = 3;
787 /* Computing MAX */
788 i__1 = idec, i__2 = *ncfnew + 1;
789 ncut = advapp_max(i__1,i__2);
790
791 /* -------------- Removal of coefficients of high degree -----------
792 */
793 /* ----------- Loop on the series of Jacobi :NCUT --> NCOEFF ----------
794 */
795
796 i__1 = *ncoeff;
797 for (ii = ncut; ii <= i__1; ++ii) {
798 /* Factor of renormalization. */
799 bidon = xmaxj[ii - idec];
800 i__2 = *ndimen;
801 for (nd = 1; nd <= i__2; ++nd) {
802 ycvmax[nd] += (d__1 = crvjac[ii + nd * crvjac_dim1], advapp_abs(d__1)) *
803 bidon;
804 /* L310: */
805 }
806 /* L300: */
807 }
808
809 /* -------------- The error is the norm of the vector error ---------------
810 */
811
812 *errmax = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
813
814 /* --------------------------------- Fin --------------------------------
815 */
816
817 return 0;
818 } /* mmaper2_ */
819
820 /* MAPER4.f -- translated by f2c (version 19960827).
821 You must link the resulting object file with the libraries:
822 -lf2c -lm (in that order)
823 */
824
825 /* Subroutine */
826 //=======================================================================
827 //function : mmaper4_
828 //purpose :
829 //=======================================================================
mmaper4_(integer * ncofmx,integer * ndimen,integer * ncoeff,doublereal * crvjac,integer * ncfnew,doublereal * ycvmax,doublereal * errmax)830 int mmaper4_(integer *ncofmx,
831 integer *ndimen,
832 integer *ncoeff,
833 doublereal *crvjac,
834 integer *ncfnew,
835 doublereal *ycvmax,
836 doublereal *errmax)
837 {
838 /* Initialized data */
839
840 static doublereal xmaxj[55] = { 1.1092649593311780079813740546678,
841 1.05299572648705464724876659688996,
842 1.0949715351434178709281698645813,
843 1.15078388379719068145021100764647,
844 1.2094863084718701596278219811869,
845 1.26806623151369531323304177532868,
846 1.32549784426476978866302826176202,
847 1.38142537365039019558329304432581,
848 1.43575531950773585146867625840552,
849 1.48850442653629641402403231015299,
850 1.53973611681876234549146350844736,
851 1.58953193485272191557448229046492,
852 1.63797820416306624705258190017418,
853 1.68515974143594899185621942934906,
854 1.73115699602477936547107755854868,
855 1.77604489805513552087086912113251,
856 1.81989256661534438347398400420601,
857 1.86276344480103110090865609776681,
858 1.90471563564740808542244678597105,
859 1.94580231994751044968731427898046,
860 1.98607219357764450634552790950067,
861 2.02556989246317857340333585562678,
862 2.06433638992049685189059517340452,
863 2.10240936014742726236706004607473,
864 2.13982350649113222745523925190532,
865 2.17661085564771614285379929798896,
866 2.21280102016879766322589373557048,
867 2.2484214321456956597803794333791,
868 2.28349755104077956674135810027654,
869 2.31805304852593774867640120860446,
870 2.35210997297725685169643559615022,
871 2.38568889602346315560143377261814,
872 2.41880904328694215730192284109322,
873 2.45148841120796359750021227795539,
874 2.48374387161372199992570528025315,
875 2.5155912654873773953959098501893,
876 2.54704548720896557684101746505398,
877 2.57812056037881628390134077704127,
878 2.60882970619319538196517982945269,
879 2.63918540521920497868347679257107,
880 2.66919945330942891495458446613851,
881 2.69888301230439621709803756505788,
882 2.72824665609081486737132853370048,
883 2.75730041251405791603760003778285,
884 2.78605380158311346185098508516203,
885 2.81451587035387403267676338931454,
886 2.84269522483114290814009184272637,
887 2.87060005919012917988363332454033,
888 2.89823818258367657739520912946934,
889 2.92561704377132528239806135133273,
890 2.95274375377994262301217318010209,
891 2.97962510678256471794289060402033,
892 3.00626759936182712291041810228171,
893 3.03267744830655121818899164295959,
894 3.05886060707437081434964933864149 };
895
896 /* System generated locals */
897 integer crvjac_dim1, crvjac_offset, i__1, i__2;
898 doublereal d__1;
899
900 /* Local variables */
901 integer idec, ncut;
902 doublereal bidon;
903 integer ii, nd;
904
905
906
907 /* ***********************************************************************
908 */
909
910 /* FUNCTION : */
911 /* ---------- */
912 /* Calculate the max. error of approximation made when */
913 /* only first NCFNEW coefficients of a curve are preserved
914 */
915 /* degree NCOEFF-1 is written in the base of Jacobi of order 4. */
916 /* KEYWORDS : */
917 /* ----------- */
918 /* LEGENDRE,POLYGON,APPROXIMATION,ERROR. */
919
920 /* INPUT ARGUMENTS : */
921 /* ------------------ */
922 /* NCOFMX : Max. degree of the curve. */
923 /* NDIMEN : Space dimension. */
924 /* NCOEFF : Degree +1 of the curve. */
925 /* CRVJAC : Curve the degree which of should be lowered. */
926 /* NCFNEW : Degree +1 of the resulting polynom. */
927
928 /* OUTPUT ARGUMENTS : */
929 /* ------------------- */
930 /* YCVMAX : Auxiliary Table (max error on each dimension).
931 */
932 /* ERRMAX : Precision of the approximation. */
933
934 /* COMMONS USED : */
935 /* ---------------- */
936
937 /* REFERENCES CALLED : */
938 /* ----------------------- */
939
940 /* DESCRIPTION/NOTES/LIMITATIONS : */
941
942
943 /* ***********************************************************************
944 */
945
946
947 /* ---------------- Table of maximums of ((1-t2)2)*Ji(t) ---------------
948 */
949
950 /* Parameter adjustments */
951 --ycvmax;
952 crvjac_dim1 = *ncofmx;
953 crvjac_offset = crvjac_dim1 + 1;
954 crvjac -= crvjac_offset;
955
956 /* Function Body */
957
958
959
960 /* ------------------- Init for error calculation -----------------------
961 */
962
963 i__1 = *ndimen;
964 for (ii = 1; ii <= i__1; ++ii) {
965 ycvmax[ii] = 0.;
966 /* L100: */
967 }
968
969 /* ------ Min. Degree that can be attained : Stop at 5 or NCFNEW ------
970 */
971
972 idec = 5;
973 /* Computing MAX */
974 i__1 = idec, i__2 = *ncfnew + 1;
975 ncut = advapp_max(i__1,i__2);
976
977 /* -------------- Removal of high degree coefficients -----------
978 */
979 /* ----------- Loop on the series of Jacobi :NCUT --> NCOEFF ----------
980 */
981
982 i__1 = *ncoeff;
983 for (ii = ncut; ii <= i__1; ++ii) {
984 /* Factor of renormalisation. */
985 bidon = xmaxj[ii - idec];
986 i__2 = *ndimen;
987 for (nd = 1; nd <= i__2; ++nd) {
988 ycvmax[nd] += (d__1 = crvjac[ii + nd * crvjac_dim1], advapp_abs(d__1)) *
989 bidon;
990 /* L310: */
991 }
992 /* L300: */
993 }
994
995 /* -------------- The error is the norm of the error vector ---------------
996 */
997
998 *errmax = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
999
1000 /* --------------------------------- End --------------------------------
1001 */
1002
1003 return 0;
1004 } /* mmaper4_ */
1005
1006 //=======================================================================
1007 //function : mmaper6_
1008 //purpose :
1009 //=======================================================================
mmaper6_(integer * ncofmx,integer * ndimen,integer * ncoeff,doublereal * crvjac,integer * ncfnew,doublereal * ycvmax,doublereal * errmax)1010 int mmaper6_(integer *ncofmx,
1011 integer *ndimen,
1012 integer *ncoeff,
1013 doublereal *crvjac,
1014 integer *ncfnew,
1015 doublereal *ycvmax,
1016 doublereal *errmax)
1017
1018 {
1019 /* Initialized data */
1020
1021 static doublereal xmaxj[53] = { 1.21091229812484768570102219548814,
1022 1.11626917091567929907256116528817,
1023 1.1327140810290884106278510474203,
1024 1.1679452722668028753522098022171,
1025 1.20910611986279066645602153641334,
1026 1.25228283758701572089625983127043,
1027 1.29591971597287895911380446311508,
1028 1.3393138157481884258308028584917,
1029 1.3821288728999671920677617491385,
1030 1.42420414683357356104823573391816,
1031 1.46546895108549501306970087318319,
1032 1.50590085198398789708599726315869,
1033 1.54550385142820987194251585145013,
1034 1.58429644271680300005206185490937,
1035 1.62230484071440103826322971668038,
1036 1.65955905239130512405565733793667,
1037 1.69609056468292429853775667485212,
1038 1.73193098017228915881592458573809,
1039 1.7671112206990325429863426635397,
1040 1.80166107681586964987277458875667,
1041 1.83560897003644959204940535551721,
1042 1.86898184653271388435058371983316,
1043 1.90180515174518670797686768515502,
1044 1.93410285411785808749237200054739,
1045 1.96589749778987993293150856865539,
1046 1.99721027139062501070081653790635,
1047 2.02806108474738744005306947877164,
1048 2.05846864831762572089033752595401,
1049 2.08845055210580131460156962214748,
1050 2.11802334209486194329576724042253,
1051 2.14720259305166593214642386780469,
1052 2.17600297710595096918495785742803,
1053 2.20443832785205516555772788192013,
1054 2.2325216999457379530416998244706,
1055 2.2602654243075083168599953074345,
1056 2.28768115912702794202525264301585,
1057 2.3147799369092684021274946755348,
1058 2.34157220782483457076721300512406,
1059 2.36806787963276257263034969490066,
1060 2.39427635443992520016789041085844,
1061 2.42020656255081863955040620243062,
1062 2.44586699364757383088888037359254,
1063 2.47126572552427660024678584642791,
1064 2.49641045058324178349347438430311,
1065 2.52130850028451113942299097584818,
1066 2.54596686772399937214920135190177,
1067 2.5703922285006754089328998222275,
1068 2.59459096001908861492582631591134,
1069 2.61856915936049852435394597597773,
1070 2.64233265984385295286445444361827,
1071 2.66588704638685848486056711408168,
1072 2.68923766976735295746679957665724,
1073 2.71238965987606292679677228666411 };
1074
1075 /* System generated locals */
1076 integer crvjac_dim1, crvjac_offset, i__1, i__2;
1077 doublereal d__1;
1078
1079 /* Local variables */
1080 integer idec, ncut;
1081 doublereal bidon;
1082 integer ii, nd;
1083
1084
1085
1086 /* ***********************************************************************
1087 */
1088 /* FUNCTION : */
1089 /* ---------- */
1090 /* Calculate the max. error of approximation made when */
1091 /* only first NCFNEW coefficients of a curve are preserved
1092 */
1093 /* degree NCOEFF-1 is written in the base of Jacobi of order 6. */
1094 /* KEYWORDS : */
1095 /* ----------- */
1096 /* JACOBI,POLYGON,APPROXIMATION,ERROR. */
1097
1098 /* INPUT ARGUMENTS : */
1099 /* ------------------ */
1100 /* NCOFMX : Max. degree of the curve. */
1101 /* NDIMEN : Space dimension. */
1102 /* NCOEFF : Degree +1 of the curve. */
1103 /* CRVJAC : Curve the degree which of should be lowered. */
1104 /* NCFNEW : Degree +1 of the resulting polynom. */
1105
1106 /* OUTPUT ARGUMENTS : */
1107 /* ------------------- */
1108 /* YCVMAX : Auxiliary Table (max error on each dimension).
1109 */
1110 /* ERRMAX : Precision of the approximation. */
1111
1112 /* COMMONS USED : */
1113 /* ---------------- */
1114
1115 /* REFERENCES CALLED : */
1116 /* ----------------------- */
1117
1118 /* DESCRIPTION/NOTES/LIMITATIONS : */
1119 /* > */
1120 /* ***********************************************************************
1121 */
1122
1123
1124 /* ---------------- Table of maximums of ((1-t2)3)*Ji(t) ---------------
1125 */
1126
1127 /* Parameter adjustments */
1128 --ycvmax;
1129 crvjac_dim1 = *ncofmx;
1130 crvjac_offset = crvjac_dim1 + 1;
1131 crvjac -= crvjac_offset;
1132
1133 /* Function Body */
1134
1135
1136
1137 /* ------------------- Init for error calculation -----------------------
1138 */
1139
1140 i__1 = *ndimen;
1141 for (ii = 1; ii <= i__1; ++ii) {
1142 ycvmax[ii] = 0.;
1143 /* L100: */
1144 }
1145
1146 /* ------ Min Degree that can be attained : Stop at 3 or NCFNEW ------
1147 */
1148
1149 idec = 7;
1150 /* Computing MAX */
1151 i__1 = idec, i__2 = *ncfnew + 1;
1152 ncut = advapp_max(i__1,i__2);
1153
1154 /* -------------- Removal of high degree coefficients -----------
1155 */
1156 /* ----------- Loop on the series of Jacobi :NCUT --> NCOEFF ----------
1157 */
1158
1159 i__1 = *ncoeff;
1160 for (ii = ncut; ii <= i__1; ++ii) {
1161 /* Factor of renormalization. */
1162 bidon = xmaxj[ii - idec];
1163 i__2 = *ndimen;
1164 for (nd = 1; nd <= i__2; ++nd) {
1165 ycvmax[nd] += (d__1 = crvjac[ii + nd * crvjac_dim1], advapp_abs(d__1)) *
1166 bidon;
1167 /* L310: */
1168 }
1169 /* L300: */
1170 }
1171
1172 /* -------------- The error is the norm of the vector error ---------------
1173 */
1174
1175 *errmax = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
1176
1177 /* --------------------------------- END --------------------------------
1178 */
1179
1180 return 0;
1181 } /* mmaper6_ */
1182
1183 //=======================================================================
1184 //function : AdvApp2Var_MathBase::mmaperx_
1185 //purpose :
1186 //=======================================================================
mmaperx_(integer * ncofmx,integer * ndimen,integer * ncoeff,integer * iordre,doublereal * crvjac,integer * ncfnew,doublereal * ycvmax,doublereal * errmax,integer * iercod)1187 int AdvApp2Var_MathBase::mmaperx_(integer *ncofmx,
1188 integer *ndimen,
1189 integer *ncoeff,
1190 integer *iordre,
1191 doublereal *crvjac,
1192 integer *ncfnew,
1193 doublereal *ycvmax,
1194 doublereal *errmax,
1195 integer *iercod)
1196
1197 {
1198 /* System generated locals */
1199 integer crvjac_dim1, crvjac_offset;
1200
1201 /* Local variables */
1202 integer jord;
1203
1204 /* **********************************************************************
1205 */
1206 /* FUNCTION : */
1207 /* ---------- */
1208 /* Calculate the max. error of approximation made when */
1209 /* only first NCFNEW coefficients of a curve are preserved
1210 */
1211 /* degree NCOEFF-1 is written in the base of Jacobi of order IORDRE. */
1212 /* KEYWORDS : */
1213 /* ----------- */
1214 /* JACOBI,LEGENDRE,POLYGON,APPROXIMATION,ERROR. */
1215
1216 /* INPUT ARGUMENTS : */
1217 /* ------------------ */
1218 /* NCOFMX : Max. degree of the curve. */
1219 /* NDIMEN : Space dimension. */
1220 /* NCOEFF : Degree +1 of the curve. */
1221 /* IORDRE : Order of continuity at the extremities. */
1222 /* CRVJAC : Curve the degree which of should be lowered. */
1223 /* NCFNEW : Degree +1 of the resulting polynom. */
1224
1225 /* OUTPUT ARGUMENTS : */
1226 /* ------------------- */
1227 /* YCVMAX : Auxiliary Table (max error on each dimension).
1228 */
1229 /* ERRMAX : Precision of the approximation. */
1230 /* IERCOD = 0, OK */
1231 /* = 1, order of constraints (IORDRE) is not within the */
1232 /* autorized values. */
1233 /* COMMONS USED : */
1234 /* ---------------- */
1235
1236 /* REFERENCES CALLED : */
1237 /* ----------------------- */
1238
1239 /* DESCRIPTION/NOTES/LIMITATIONS : */
1240 /* ----------------------------------- */
1241 /* Canceled and replaced MMAPERR. */
1242 /* ***********************************************************************
1243 */
1244
1245
1246 /* Parameter adjustments */
1247 --ycvmax;
1248 crvjac_dim1 = *ncofmx;
1249 crvjac_offset = crvjac_dim1 + 1;
1250 crvjac -= crvjac_offset;
1251
1252 /* Function Body */
1253 *iercod = 0;
1254 /* --> Order of Jacobi polynoms */
1255 jord = ( *iordre + 1) << 1;
1256
1257 if (jord == 0) {
1258 mmaper0_(ncofmx, ndimen, ncoeff, &crvjac[crvjac_offset], ncfnew, &
1259 ycvmax[1], errmax);
1260 } else if (jord == 2) {
1261 mmaper2_(ncofmx, ndimen, ncoeff, &crvjac[crvjac_offset], ncfnew, &
1262 ycvmax[1], errmax);
1263 } else if (jord == 4) {
1264 mmaper4_(ncofmx, ndimen, ncoeff, &crvjac[crvjac_offset], ncfnew, &
1265 ycvmax[1], errmax);
1266 } else if (jord == 6) {
1267 mmaper6_(ncofmx, ndimen, ncoeff, &crvjac[crvjac_offset], ncfnew, &
1268 ycvmax[1], errmax);
1269 } else {
1270 *iercod = 1;
1271 }
1272
1273 /* ----------------------------------- Fin ------------------------------
1274 */
1275
1276 return 0;
1277 } /* mmaperx_ */
1278
1279 //=======================================================================
1280 //function : mmarc41_
1281 //purpose :
1282 //=======================================================================
mmarc41_(integer * ndimax,integer * ndimen,integer * ncoeff,doublereal * crvold,doublereal * upara0,doublereal * upara1,doublereal * crvnew,integer * iercod)1283 int mmarc41_(integer *ndimax,
1284 integer *ndimen,
1285 integer *ncoeff,
1286 doublereal *crvold,
1287 doublereal *upara0,
1288 doublereal *upara1,
1289 doublereal *crvnew,
1290 integer *iercod)
1291
1292 {
1293 /* System generated locals */
1294 integer crvold_dim1, crvold_offset, crvnew_dim1, crvnew_offset, i__1,
1295 i__2, i__3;
1296
1297 /* Local variables */
1298 integer nboct;
1299 doublereal tbaux[61];
1300 integer nd;
1301 doublereal bid;
1302 integer ncf, ncj;
1303
1304
1305 /* IMPLICIT DOUBLE PRECISION(A-H,O-Z) */
1306 /* IMPLICIT INTEGER (I-N) */
1307
1308 /* ***********************************************************************
1309 */
1310
1311 /* FUNCTION : */
1312 /* ---------- */
1313 /* Creation of curve C2(v) defined on (0,1) identic to */
1314 /* curve C1(u) defined on (U0,U1) (change of parameter */
1315 /* of a curve). */
1316
1317 /* KEYWORDS : */
1318 /* ----------- */
1319 /* LIMITATION, RESTRICTION, CURVE */
1320
1321 /* INPUT ARGUMENTS : */
1322 /* ------------------ */
1323 /* NDIMAX : Space Dimensioning. */
1324 /* NDIMEN : Curve Dimension. */
1325 /* NCOEFF : Nb of coefficients of the curve. */
1326 /* CRVOLD : Curve to be limited. */
1327 /* UPARA0 : Min limit of the interval limiting the curve.
1328 */
1329 /* UPARA1 : Max limit of the interval limiting the curve.
1330 */
1331
1332 /* OUTPUT ARGUMENTS : */
1333 /* ------------------- */
1334 /* CRVNEW : Relimited curve, defined on (0,1) and equal to */
1335 /* CRVOLD defined on (U0,U1). */
1336 /* IERCOD : = 0, OK */
1337 /* =10, Nb of coeff. <1 or > 61. */
1338
1339 /* COMMONS USED : */
1340 /* ---------------- */
1341 /* REFERENCES CALLED : */
1342 /* ---------------------- */
1343 /* Type Name */
1344 /* MAERMSG MCRFILL MVCVIN2 */
1345 /* MVCVINV */
1346
1347 /* DESCRIPTION/NOTES/LIMITATIONS : */
1348 /* ----------------------------------- */
1349 /* ---> Algorithm used in this general case is based on the */
1350 /* following principle : */
1351 /* Let S(t) = a0 + a1*t + a2*t**2 + ... of degree NCOEFF-1, and */
1352 /* U(t) = b0 + b1*t, then the coeff. of */
1353 /* S(U(t)) are calculated step by step with help of table TBAUX. */
1354 /* At each step number N (N=2 to NCOEFF), TBAUX(n) contains */
1355 /* the n-th coefficient of U(t)**N for n=1 to N. (RBD) */
1356 /* ---> Reference : KNUTH, 'The Art of Computer Programming', */
1357 /* Vol. 2/'Seminumerical Algorithms', */
1358 /* Ex. 11 p:451 et solution p:562. (RBD) */
1359
1360 /* ---> Removal of the input argument CRVOLD by CRVNEW is */
1361 /* possible, which means that the call : */
1362 /* CALL MMARC41(NDIMAX,NDIMEN,NCOEFF,CURVE,UPARA0,UPARA1 */
1363 /* ,CURVE,IERCOD) */
1364 /* is absolutely LEGAL. (RBD) */
1365
1366 /* > */
1367 /* **********************************************************************
1368 */
1369
1370 /* Name of the routine */
1371
1372 /* Auxiliary table of coefficients of (UPARA1-UPARA0)T+UPARA0 */
1373 /* with power N=1 to NCOEFF-1. */
1374
1375
1376 /* Parameter adjustments */
1377 crvnew_dim1 = *ndimax;
1378 crvnew_offset = crvnew_dim1 + 1;
1379 crvnew -= crvnew_offset;
1380 crvold_dim1 = *ndimax;
1381 crvold_offset = crvold_dim1 + 1;
1382 crvold -= crvold_offset;
1383
1384 /* Function Body */
1385 *iercod = 0;
1386 /* **********************************************************************
1387 */
1388 /* CASE WHEN PROCESSING CAN'T BE DONE */
1389 /* **********************************************************************
1390 */
1391 if (*ncoeff > 61 || *ncoeff < 1) {
1392 *iercod = 10;
1393 goto L9999;
1394 }
1395 /* **********************************************************************
1396 */
1397 /* IF NO CHANGES */
1398 /* **********************************************************************
1399 */
1400 if (*ndimen == *ndimax && *upara0 == 0. && *upara1 == 1.) {
1401 nboct = (*ndimax << 3) * *ncoeff;
1402 AdvApp2Var_SysBase::mcrfill_(&nboct,
1403 &crvold[crvold_offset],
1404 &crvnew[crvnew_offset]);
1405 goto L9999;
1406 }
1407 /* **********************************************************************
1408 */
1409 /* INVERSION 3D : FAST PROCESSING */
1410 /* **********************************************************************
1411 */
1412 if (*upara0 == 1. && *upara1 == 0.) {
1413 if (*ndimen == 3 && *ndimax == 3 && *ncoeff <= 21) {
1414 mvcvinv_(ncoeff, &crvold[crvold_offset], &crvnew[crvnew_offset],
1415 iercod);
1416 goto L9999;
1417 }
1418 /* ******************************************************************
1419 **** */
1420 /* INVERSION 2D : FAST PROCESSING */
1421 /* ******************************************************************
1422 **** */
1423 if (*ndimen == 2 && *ndimax == 2 && *ncoeff <= 21) {
1424 mvcvin2_(ncoeff, &crvold[crvold_offset], &crvnew[crvnew_offset],
1425 iercod);
1426 goto L9999;
1427 }
1428 }
1429 /* **********************************************************************
1430 */
1431 /* GENERAL PROCESSING */
1432 /* **********************************************************************
1433 */
1434 /* -------------------------- Initializations ---------------------------
1435 */
1436
1437 i__1 = *ndimen;
1438 for (nd = 1; nd <= i__1; ++nd) {
1439 crvnew[nd + crvnew_dim1] = crvold[nd + crvold_dim1];
1440 /* L100: */
1441 }
1442 if (*ncoeff == 1) {
1443 goto L9999;
1444 }
1445 tbaux[0] = *upara0;
1446 tbaux[1] = *upara1 - *upara0;
1447
1448 /* ----------------------- Calculation of coeff. of CRVNEW ------------------
1449 */
1450
1451 i__1 = *ncoeff - 1;
1452 for (ncf = 2; ncf <= i__1; ++ncf) {
1453
1454 /* ------------ Take into account NCF-th coeff. of CRVOLD --------
1455 ---- */
1456
1457 i__2 = ncf - 1;
1458 for (ncj = 1; ncj <= i__2; ++ncj) {
1459 bid = tbaux[ncj - 1];
1460 i__3 = *ndimen;
1461 for (nd = 1; nd <= i__3; ++nd) {
1462 crvnew[nd + ncj * crvnew_dim1] += crvold[nd + ncf *
1463 crvold_dim1] * bid;
1464 /* L400: */
1465 }
1466 /* L300: */
1467 }
1468
1469 bid = tbaux[ncf - 1];
1470 i__2 = *ndimen;
1471 for (nd = 1; nd <= i__2; ++nd) {
1472 crvnew[nd + ncf * crvnew_dim1] = crvold[nd + ncf * crvold_dim1] *
1473 bid;
1474 /* L500: */
1475 }
1476
1477 /* --------- Calculate (NCF+1) coeff. of ((U1-U0)*t + U0)**(NCF) ---
1478 ---- */
1479
1480 bid = *upara1 - *upara0;
1481 tbaux[ncf] = tbaux[ncf - 1] * bid;
1482 for (ncj = ncf; ncj >= 2; --ncj) {
1483 tbaux[ncj - 1] = tbaux[ncj - 1] * *upara0 + tbaux[ncj - 2] * bid;
1484 /* L600: */
1485 }
1486 tbaux[0] *= *upara0;
1487
1488 /* L200: */
1489 }
1490
1491 /* -------------- Take into account the last coeff. of CRVOLD -----------
1492 */
1493
1494 i__1 = *ncoeff - 1;
1495 for (ncj = 1; ncj <= i__1; ++ncj) {
1496 bid = tbaux[ncj - 1];
1497 i__2 = *ndimen;
1498 for (nd = 1; nd <= i__2; ++nd) {
1499 crvnew[nd + ncj * crvnew_dim1] += crvold[nd + *ncoeff *
1500 crvold_dim1] * bid;
1501 /* L800: */
1502 }
1503 /* L700: */
1504 }
1505 i__1 = *ndimen;
1506 for (nd = 1; nd <= i__1; ++nd) {
1507 crvnew[nd + *ncoeff * crvnew_dim1] = crvold[nd + *ncoeff *
1508 crvold_dim1] * tbaux[*ncoeff - 1];
1509 /* L900: */
1510 }
1511
1512 /* ---------------------------- The end ---------------------------------
1513 */
1514
1515 L9999:
1516 if (*iercod != 0) {
1517 AdvApp2Var_SysBase::maermsg_("MMARC41", iercod, 7L);
1518 }
1519
1520 return 0 ;
1521 } /* mmarc41_ */
1522
1523 //=======================================================================
1524 //function : AdvApp2Var_MathBase::mmarcin_
1525 //purpose :
1526 //=======================================================================
mmarcin_(integer * ndimax,integer * ndim,integer * ncoeff,doublereal * crvold,doublereal * u0,doublereal * u1,doublereal * crvnew,integer * iercod)1527 int AdvApp2Var_MathBase::mmarcin_(integer *ndimax,
1528 integer *ndim,
1529 integer *ncoeff,
1530 doublereal *crvold,
1531 doublereal *u0,
1532 doublereal *u1,
1533 doublereal *crvnew,
1534 integer *iercod)
1535
1536 {
1537 /* System generated locals */
1538 integer crvold_dim1, crvold_offset, crvnew_dim1, crvnew_offset, i__1,
1539 i__2, i__3;
1540 doublereal d__1;
1541
1542 /* Local variables */
1543 doublereal x0, x1;
1544 integer nd;
1545 doublereal tabaux[61];
1546 integer ibb;
1547 doublereal bid;
1548 integer ncf;
1549 integer ncj;
1550 doublereal eps3;
1551
1552
1553
1554 /* **********************************************************************
1555 *//* FUNCTION : */
1556 /* ---------- */
1557 /* Creation of curve C2(v) defined on [U0,U1] identic to */
1558 /* curve C1(u) defined on [-1,1] (change of parameter */
1559 /* of a curve) with INVERSION of indices of the resulting table. */
1560
1561 /* KEYWORDS : */
1562 /* ----------- */
1563 /* GENERALIZED LIMITATION, RESTRICTION, INVERSION, CURVE */
1564
1565 /* INPUT ARGUMENTS : */
1566 /* ------------------ */
1567 /* NDIMAX : Maximum Space Dimensioning. */
1568 /* NDIMEN : Curve Dimension. */
1569 /* NCOEFF : Nb of coefficients of the curve. */
1570 /* CRVOLD : Curve to be limited. */
1571 /* U0 : Min limit of the interval limiting the curve.
1572 */
1573 /* U1 : Max limit of the interval limiting the curve.
1574 */
1575
1576 /* OUTPUT ARGUMENTS : */
1577 /* ------------------- */
1578 /* CRVNEW : Relimited curve, defined on [U0,U1] and equal to */
1579 /* CRVOLD defined on [-1,1]. */
1580 /* IERCOD : = 0, OK */
1581 /* =10, Nb of coeff. <1 or > 61. */
1582 /* =13, the requested interval of variation is null. */
1583 /* COMMONS USED : */
1584 /* ---------------- */
1585 /* REFERENCES CALLED : */
1586 /* ---------------------- */
1587 /* DESCRIPTION/NOTES/LIMITATIONS : */
1588 /* ----------------------------------- */
1589 /* > */
1590 /* **********************************************************************
1591 */
1592
1593 /* Name of the routine */
1594
1595 /* Auxiliary table of coefficients of X1*T+X0 */
1596 /* with power N=1 to NCOEFF-1. */
1597
1598
1599 /* Parameter adjustments */
1600 crvnew_dim1 = *ndimax;
1601 crvnew_offset = crvnew_dim1 + 1;
1602 crvnew -= crvnew_offset;
1603 crvold_dim1 = *ncoeff;
1604 crvold_offset = crvold_dim1 + 1;
1605 crvold -= crvold_offset;
1606
1607 /* Function Body */
1608 ibb = AdvApp2Var_SysBase::mnfndeb_();
1609 if (ibb >= 2) {
1610 AdvApp2Var_SysBase::mgenmsg_("MMARCIN", 7L);
1611 }
1612
1613 /* At zero machine it is tested if the output interval is not null */
1614
1615 AdvApp2Var_MathBase::mmveps3_(&eps3);
1616 if ((d__1 = *u1 - *u0, advapp_abs(d__1)) < eps3) {
1617 *iercod = 13;
1618 goto L9999;
1619 }
1620 *iercod = 0;
1621
1622 /* **********************************************************************
1623 */
1624 /* CASE WHEN THE PROCESSING IS IMPOSSIBLE */
1625 /* **********************************************************************
1626 */
1627 if (*ncoeff > 61 || *ncoeff < 1) {
1628 *iercod = 10;
1629 goto L9999;
1630 }
1631 /* **********************************************************************
1632 */
1633 /* IF NO CHANGE OF THE INTERVAL OF DEFINITION */
1634 /* (ONLY INVERSION OF INDICES OF TABLE CRVOLD) */
1635 /* **********************************************************************
1636 */
1637 if (*ndim == *ndimax && *u0 == -1. && *u1 == 1.) {
1638 AdvApp2Var_MathBase::mmcvinv_(ndim, ncoeff, ndim, &crvold[crvold_offset], &crvnew[
1639 crvnew_offset]);
1640 goto L9999;
1641 }
1642 /* **********************************************************************
1643 */
1644 /* CASE WHEN THE NEW INTERVAL OF DEFINITION IS [0,1] */
1645 /* **********************************************************************
1646 */
1647 if (*u0 == 0. && *u1 == 1.) {
1648 mmcvstd_(ncoeff, ndimax, ncoeff, ndim, &crvold[crvold_offset], &
1649 crvnew[crvnew_offset]);
1650 goto L9999;
1651 }
1652 /* **********************************************************************
1653 */
1654 /* GENERAL PROCESSING */
1655 /* **********************************************************************
1656 */
1657 /* -------------------------- Initialization ---------------------------
1658 */
1659
1660 x0 = -(*u1 + *u0) / (*u1 - *u0);
1661 x1 = 2. / (*u1 - *u0);
1662 i__1 = *ndim;
1663 for (nd = 1; nd <= i__1; ++nd) {
1664 crvnew[nd + crvnew_dim1] = crvold[nd * crvold_dim1 + 1];
1665 /* L100: */
1666 }
1667 if (*ncoeff == 1) {
1668 goto L9999;
1669 }
1670 tabaux[0] = x0;
1671 tabaux[1] = x1;
1672
1673 /* ----------------------- Calculation of coeff. of CRVNEW ------------------
1674 */
1675
1676 i__1 = *ncoeff - 1;
1677 for (ncf = 2; ncf <= i__1; ++ncf) {
1678
1679 /* ------------ Take into account the NCF-th coeff. of CRVOLD --------
1680 ---- */
1681
1682 i__2 = ncf - 1;
1683 for (ncj = 1; ncj <= i__2; ++ncj) {
1684 bid = tabaux[ncj - 1];
1685 i__3 = *ndim;
1686 for (nd = 1; nd <= i__3; ++nd) {
1687 crvnew[nd + ncj * crvnew_dim1] += crvold[ncf + nd *
1688 crvold_dim1] * bid;
1689 /* L400: */
1690 }
1691 /* L300: */
1692 }
1693
1694 bid = tabaux[ncf - 1];
1695 i__2 = *ndim;
1696 for (nd = 1; nd <= i__2; ++nd) {
1697 crvnew[nd + ncf * crvnew_dim1] = crvold[ncf + nd * crvold_dim1] *
1698 bid;
1699 /* L500: */
1700 }
1701
1702 /* --------- Calculation of (NCF+1) coeff. of [X1*t + X0]**(NCF) --------
1703 ---- */
1704
1705 tabaux[ncf] = tabaux[ncf - 1] * x1;
1706 for (ncj = ncf; ncj >= 2; --ncj) {
1707 tabaux[ncj - 1] = tabaux[ncj - 1] * x0 + tabaux[ncj - 2] * x1;
1708 /* L600: */
1709 }
1710 tabaux[0] *= x0;
1711
1712 /* L200: */
1713 }
1714
1715 /* -------------- Take into account the last coeff. of CRVOLD -----------
1716 */
1717
1718 i__1 = *ncoeff - 1;
1719 for (ncj = 1; ncj <= i__1; ++ncj) {
1720 bid = tabaux[ncj - 1];
1721 i__2 = *ndim;
1722 for (nd = 1; nd <= i__2; ++nd) {
1723 crvnew[nd + ncj * crvnew_dim1] += crvold[*ncoeff + nd *
1724 crvold_dim1] * bid;
1725 /* L800: */
1726 }
1727 /* L700: */
1728 }
1729 i__1 = *ndim;
1730 for (nd = 1; nd <= i__1; ++nd) {
1731 crvnew[nd + *ncoeff * crvnew_dim1] = crvold[*ncoeff + nd *
1732 crvold_dim1] * tabaux[*ncoeff - 1];
1733 /* L900: */
1734 }
1735
1736 /* ---------------------------- The end ---------------------------------
1737 */
1738
1739 L9999:
1740 if (*iercod > 0) {
1741 AdvApp2Var_SysBase::maermsg_("MMARCIN", iercod, 7L);
1742 }
1743 if (ibb >= 2) {
1744 AdvApp2Var_SysBase::mgsomsg_("MMARCIN", 7L);
1745 }
1746 return 0;
1747 } /* mmarcin_ */
1748
1749 //=======================================================================
1750 //function : mmatvec_
1751 //purpose :
1752 //=======================================================================
mmatvec_(integer * nligne,integer *,integer * gposit,integer *,doublereal * gmatri,doublereal * vecin,integer * deblig,doublereal * vecout,integer * iercod)1753 int mmatvec_(integer *nligne,
1754 integer *,//ncolon,
1755 integer *gposit,
1756 integer *,//gnstoc,
1757 doublereal *gmatri,
1758 doublereal *vecin,
1759 integer *deblig,
1760 doublereal *vecout,
1761 integer *iercod)
1762
1763 {
1764 /* System generated locals */
1765 integer i__1, i__2;
1766
1767 /* Local variables */
1768 logical ldbg;
1769 integer jmin, jmax, i__, j, k;
1770 doublereal somme;
1771 integer aux;
1772
1773
1774 /* ***********************************************************************
1775 */
1776
1777 /* FUNCTION : */
1778 /* ---------- */
1779 /* Produce vector matrix in form of profile */
1780
1781
1782 /* MOTS CLES : */
1783 /* ----------- */
1784 /* RESERVE, MATRIX, PRODUCT, VECTOR, PROFILE */
1785
1786 /* INPUT ARGUMENTS : */
1787 /* -------------------- */
1788 /* NLIGNE : Line number of the matrix of constraints */
1789 /* NCOLON : Number of column of the matrix of constraints */
1790 /* GNSTOC: Number of coefficients in the profile of matrix GMATRI */
1791
1792 /* GPOSIT: Table of positioning of terms of storage */
1793 /* GPOSIT(1,I) contains the number of terms-1 on the line I */
1794 /* in the profile of the matrix. */
1795 /* GPOSIT(2,I) contains the index of storage of diagonal term*/
1796 /* of line I */
1797 /* GPOSIT(3,I) contains the index of column of the first term of */
1798 /* profile of line I */
1799 /* GNSTOC: Number of coefficients in the profile of matrix */
1800 /* GMATRI */
1801 /* GMATRI : Matrix of constraints in form of profile */
1802 /* VECIN : Input vector */
1803 /* DEBLIG : Line indexusing which the vector matrix is calculated */
1804 /**/
1805 /* OUTPUT ARGUMENTS */
1806 /* --------------------- */
1807 /* VECOUT : VECTOR PRODUCT */
1808
1809 /* IERCOD : ERROR CODE */
1810
1811
1812 /* COMMONS USED : */
1813 /* ------------------ */
1814
1815
1816 /* REFERENCES CALLED : */
1817 /* --------------------- */
1818
1819
1820 /* DESCRIPTION/NOTES/LIMITATIONS : */
1821 /* ----------------------------------- */
1822
1823 /* ***********************************************************************
1824 */
1825 /* DECLARATIONS */
1826 /* ***********************************************************************
1827 */
1828
1829
1830
1831 /* ***********************************************************************
1832 */
1833 /* INITIALISATIONS */
1834 /* ***********************************************************************
1835 */
1836
1837 /* Parameter adjustments */
1838 --vecout;
1839 gposit -= 4;
1840 --vecin;
1841 --gmatri;
1842
1843 /* Function Body */
1844 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 2;
1845 if (ldbg) {
1846 AdvApp2Var_SysBase::mgenmsg_("MMATVEC", 7L);
1847 }
1848 *iercod = 0;
1849
1850 /* ***********************************************************************
1851 */
1852 /* Processing */
1853 /* ***********************************************************************
1854 */
1855 AdvApp2Var_SysBase::mvriraz_(nligne,
1856 &vecout[1]);
1857 i__1 = *nligne;
1858 for (i__ = *deblig; i__ <= i__1; ++i__) {
1859 somme = 0.;
1860 jmin = gposit[i__ * 3 + 3];
1861 jmax = gposit[i__ * 3 + 1] + gposit[i__ * 3 + 3] - 1;
1862 aux = gposit[i__ * 3 + 2] - gposit[i__ * 3 + 1] - jmin + 1;
1863 i__2 = jmax;
1864 for (j = jmin; j <= i__2; ++j) {
1865 k = j + aux;
1866 somme += gmatri[k] * vecin[j];
1867 }
1868 vecout[i__] = somme;
1869 }
1870
1871
1872
1873
1874
1875 goto L9999;
1876
1877 /* ***********************************************************************
1878 */
1879 /* ERROR PROCESSING */
1880 /* ***********************************************************************
1881 */
1882
1883
1884
1885
1886 /* ***********************************************************************
1887 */
1888 /* RETURN CALLING PROGRAM */
1889 /* ***********************************************************************
1890 */
1891
1892 L9999:
1893
1894 /* ___ DESALLOCATION, ... */
1895
1896 AdvApp2Var_SysBase::maermsg_("MMATVEC", iercod, 7L);
1897 if (ldbg) {
1898 AdvApp2Var_SysBase::mgsomsg_("MMATVEC", 7L);
1899 }
1900
1901 return 0 ;
1902 } /* mmatvec_ */
1903
1904 //=======================================================================
1905 //function : mmbulld_
1906 //purpose :
1907 //=======================================================================
mmbulld_(integer * nbcoln,integer * nblign,doublereal * dtabtr,integer * numcle)1908 int AdvApp2Var_MathBase::mmbulld_(integer *nbcoln,
1909 integer *nblign,
1910 doublereal *dtabtr,
1911 integer *numcle)
1912
1913 {
1914 /* System generated locals */
1915 integer dtabtr_dim1, dtabtr_offset, i__1, i__2;
1916
1917 /* Local variables */
1918 logical ldbg;
1919 doublereal daux;
1920 integer nite1, nite2, nchan, i1, i2;
1921
1922 /* ***********************************************************************
1923 */
1924
1925 /* FUNCTION : */
1926 /* ---------- */
1927 /* Parsing of columns of a table of integers in increasing order */
1928 /* KEYWORDS : */
1929 /* ----------- */
1930 /* POINT-ENTRY, PARSING */
1931 /* INPUT ARGUMENTS : */
1932 /* -------------------- */
1933 /* - NBCOLN : Number of columns in the table */
1934 /* - NBLIGN : Number of lines in the table */
1935 /* - DTABTR : Table of integers to be parsed */
1936 /* - NUMCLE : Position of the key on the column */
1937
1938 /* OUTPUT ARGUMENTS : */
1939 /* --------------------- */
1940 /* - DTABTR : Parsed table */
1941
1942 /* COMMONS USED : */
1943 /* ------------------ */
1944
1945
1946 /* REFERENCES CALLED : */
1947 /* --------------------- */
1948
1949
1950 /* DESCRIPTION/NOTES/LIMITATIONS : */
1951 /* ----------------------------------- */
1952 /* Particularly performant if the table is almost parsed */
1953 /* In the opposite case it is better to use MVSHELD */
1954 /* ***********************************************************************
1955 */
1956
1957 /* Parameter adjustments */
1958 dtabtr_dim1 = *nblign;
1959 dtabtr_offset = dtabtr_dim1 + 1;
1960 dtabtr -= dtabtr_offset;
1961
1962 /* Function Body */
1963 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 2;
1964 if (ldbg) {
1965 AdvApp2Var_SysBase::mgenmsg_("MMBULLD", 7L);
1966 }
1967 nchan = 1;
1968 nite1 = *nbcoln;
1969 nite2 = 2;
1970
1971 /* ***********************************************************************
1972 */
1973 /* PROCESSING */
1974 /* ***********************************************************************
1975 */
1976
1977 /* ---->ALGORITHM in N^2 / 2 additional iteration */
1978
1979 while(nchan != 0) {
1980
1981 /* ----> Parsing from left to the right */
1982
1983 nchan = 0;
1984 i__1 = nite1;
1985 for (i1 = nite2; i1 <= i__1; ++i1) {
1986 if (dtabtr[*numcle + i1 * dtabtr_dim1] < dtabtr[*numcle + (i1 - 1)
1987 * dtabtr_dim1]) {
1988 i__2 = *nblign;
1989 for (i2 = 1; i2 <= i__2; ++i2) {
1990 daux = dtabtr[i2 + (i1 - 1) * dtabtr_dim1];
1991 dtabtr[i2 + (i1 - 1) * dtabtr_dim1] = dtabtr[i2 + i1 *
1992 dtabtr_dim1];
1993 dtabtr[i2 + i1 * dtabtr_dim1] = daux;
1994 }
1995 if (nchan == 0) {
1996 nchan = 1;
1997 }
1998 }
1999 }
2000 --nite1;
2001
2002 /* ----> Parsing from right to the left */
2003
2004 if (nchan != 0) {
2005 nchan = 0;
2006 i__1 = nite2;
2007 for (i1 = nite1; i1 >= i__1; --i1) {
2008 if (dtabtr[*numcle + i1 * dtabtr_dim1] < dtabtr[*numcle + (i1
2009 - 1) * dtabtr_dim1]) {
2010 i__2 = *nblign;
2011 for (i2 = 1; i2 <= i__2; ++i2) {
2012 daux = dtabtr[i2 + (i1 - 1) * dtabtr_dim1];
2013 dtabtr[i2 + (i1 - 1) * dtabtr_dim1] = dtabtr[i2 + i1 *
2014 dtabtr_dim1];
2015 dtabtr[i2 + i1 * dtabtr_dim1] = daux;
2016 }
2017 if (nchan == 0) {
2018 nchan = 1;
2019 }
2020 }
2021 }
2022 ++nite2;
2023 }
2024 }
2025
2026
2027 goto L9999;
2028
2029 /* ***********************************************************************
2030 */
2031 /* ERROR PROCESSING */
2032 /* ***********************************************************************
2033 */
2034
2035 /* ----> No errors at calling functions, only tests and loops. */
2036
2037 /* ***********************************************************************
2038 */
2039 /* RETURN CALLING PROGRAM */
2040 /* ***********************************************************************
2041 */
2042
2043 L9999:
2044
2045 if (ldbg) {
2046 AdvApp2Var_SysBase::mgsomsg_("MMBULLD", 7L);
2047 }
2048
2049 return 0 ;
2050 } /* mmbulld_ */
2051
2052
2053 //=======================================================================
2054 //function : AdvApp2Var_MathBase::mmcdriv_
2055 //purpose :
2056 //=======================================================================
mmcdriv_(integer * ndimen,integer * ncoeff,doublereal * courbe,integer * ideriv,integer * ncofdv,doublereal * crvdrv)2057 int AdvApp2Var_MathBase::mmcdriv_(integer *ndimen,
2058 integer *ncoeff,
2059 doublereal *courbe,
2060 integer *ideriv,
2061 integer *ncofdv,
2062 doublereal *crvdrv)
2063
2064
2065 {
2066 /* System generated locals */
2067 integer courbe_dim1, courbe_offset, crvdrv_dim1, crvdrv_offset, i__1,
2068 i__2;
2069
2070 /* Local variables */
2071 integer i__, j, k;
2072 doublereal mfactk, bid;
2073
2074
2075 /* ***********************************************************************
2076 */
2077
2078 /* FUNCTION : */
2079 /* ---------- */
2080 /* Calculate matrix of a derivate curve of order IDERIV. */
2081 /* with input parameters other than output parameters. */
2082
2083
2084 /* KEYWORDS : */
2085 /* ----------- */
2086 /* COEFFICIENTS,CURVE,DERIVATE I-EME. */
2087
2088 /* INPUT ARGUMENTS : */
2089 /* ------------------ */
2090 /* NDIMEN : Space dimension (2 or 3 in general) */
2091 /* NCOEFF : Degree +1 of the curve. */
2092 /* COURBE : Table of coefficients of the curve. */
2093 /* IDERIV : Required order of derivation : 1=1st derivate, etc... */
2094
2095 /* OUTPUT ARGUMENTS : */
2096 /* ------------------- */
2097 /* NCOFDV : Degree +1 of the derivative of order IDERIV of the curve. */
2098 /* CRVDRV : Table of coefficients of the derivative of order IDERIV */
2099 /* of the curve. */
2100
2101 /* COMMONS USED : */
2102 /* ---------------- */
2103
2104 /* REFERENCES CALLED : */
2105 /* ----------------------- */
2106
2107 /* DESCRIPTION/NOTES/LIMITATIONS : */
2108 /* ----------------------------------- */
2109
2110 /* ---> It is possible to take as output argument the curve */
2111 /* and the number of coeff passed at input by making : */
2112 /* CALL MMCDRIV(NDIMEN,NCOEFF,COURBE,IDERIV,NCOEFF,COURBE). */
2113 /* After this call, NCOEFF does the number of coeff of the derived */
2114 /* curve the coefficients which of are stored in CURVE. */
2115 /* Attention to the coefficients of CURVE of rank superior to */
2116 /* NCOEFF : they are not set to zero. */
2117
2118 /* ---> Algorithm : */
2119 /* The code below was written basing on the following algorithm:
2120 */
2121
2122 /* Let P(t) = a1 + a2*t + ... an*t**n. Derivate of order k of P */
2123 /* (containing n-k coefficients) is calculated as follows : */
2124
2125 /* Pk(t) = a(k+1)*CNP(k,k)*k! */
2126 /* + a(k+2)*CNP(k+1,k)*k! * t */
2127 /* . */
2128 /* . */
2129 /* . */
2130 /* + a(n)*CNP(n-1,k)*k! * t**(n-k-1). */
2131 /* ***********************************************************************
2132 */
2133
2134
2135 /* -------------- Case when the order of derivative is -------------------
2136 */
2137 /* ---------------- greater than the degree of the curve ---------------------
2138 */
2139
2140 /* **********************************************************************
2141 */
2142
2143 /* FUNCTION : */
2144 /* ---------- */
2145 /* Serves to provide the coefficients of binome (Pascal's triangle). */
2146
2147 /* KEYWORDS : */
2148 /* ----------- */
2149 /* Binomial coeff from 0 to 60. read only . init par block data */
2150
2151 /* DEMSCRIPTION/NOTES/LIMITATIONS : */
2152 /* ----------------------------------- */
2153 /* Binomial coefficients form a triangular matrix. */
2154 /* This matrix is completed in table CNP by its transposition. */
2155 /* So: CNP(I,J) = CNP(J,I) for I and J = 0, ..., 60. */
2156
2157 /* Initialization is done by block-data MMLLL09.RES, */
2158 /* created by program MQINICNP.FOR). */
2159 /* **********************************************************************
2160 */
2161
2162
2163
2164 /* ***********************************************************************
2165 */
2166
2167 /* Parameter adjustments */
2168 crvdrv_dim1 = *ndimen;
2169 crvdrv_offset = crvdrv_dim1 + 1;
2170 crvdrv -= crvdrv_offset;
2171 courbe_dim1 = *ndimen;
2172 courbe_offset = courbe_dim1 + 1;
2173 courbe -= courbe_offset;
2174
2175 /* Function Body */
2176 if (*ideriv >= *ncoeff) {
2177 i__1 = *ndimen;
2178 for (i__ = 1; i__ <= i__1; ++i__) {
2179 crvdrv[i__ + crvdrv_dim1] = 0.;
2180 /* L10: */
2181 }
2182 *ncofdv = 1;
2183 goto L9999;
2184 }
2185 /* **********************************************************************
2186 */
2187 /* General processing */
2188 /* **********************************************************************
2189 */
2190 /* --------------------- Calculation of Factorial(IDERIV) ------------------
2191 */
2192
2193 k = *ideriv;
2194 mfactk = 1.;
2195 i__1 = k;
2196 for (i__ = 2; i__ <= i__1; ++i__) {
2197 mfactk *= i__;
2198 /* L50: */
2199 }
2200
2201 /* ------------ Calculation of coeff of the derived of order IDERIV ----------
2202 */
2203 /* ---> Attention : coefficient binomial C(n,m) is represented in */
2204 /* MCCNP by CNP(N+1,M+1). */
2205
2206 i__1 = *ncoeff;
2207 for (j = k + 1; j <= i__1; ++j) {
2208 bid = mmcmcnp_.cnp[j - 1 + k * 61] * mfactk;
2209 i__2 = *ndimen;
2210 for (i__ = 1; i__ <= i__2; ++i__) {
2211 crvdrv[i__ + (j - k) * crvdrv_dim1] = bid * courbe[i__ + j *
2212 courbe_dim1];
2213 /* L200: */
2214 }
2215 /* L100: */
2216 }
2217
2218 *ncofdv = *ncoeff - *ideriv;
2219
2220 /* -------------------------------- The end -----------------------------
2221 */
2222
2223 L9999:
2224 return 0;
2225 } /* mmcdriv_ */
2226
2227 //=======================================================================
2228 //function : AdvApp2Var_MathBase::mmcglc1_
2229 //purpose :
2230 //=======================================================================
mmcglc1_(integer * ndimax,integer * ndimen,integer * ncoeff,doublereal * courbe,doublereal * tdebut,doublereal * tfinal,doublereal * epsiln,doublereal * xlongc,doublereal * erreur,integer * iercod)2231 int AdvApp2Var_MathBase::mmcglc1_(integer *ndimax,
2232 integer *ndimen,
2233 integer *ncoeff,
2234 doublereal *courbe,
2235 doublereal *tdebut,
2236 doublereal *tfinal,
2237 doublereal *epsiln,
2238 doublereal *xlongc,
2239 doublereal *erreur,
2240 integer *iercod)
2241
2242
2243 {
2244 /* System generated locals */
2245 integer courbe_dim1, courbe_offset, i__1;
2246 doublereal d__1;
2247
2248 /* Local variables */
2249 integer ndec;
2250 doublereal tdeb, tfin;
2251 integer iter;
2252 doublereal oldso = 0.;
2253 integer itmax;
2254 doublereal sottc;
2255 integer kk, ibb;
2256 doublereal dif, pas;
2257 doublereal som;
2258
2259
2260 /* ***********************************************************************
2261 */
2262
2263 /* FUNCTION : */
2264 /* ---------- */
2265 /* Allows calculating the length of an arc of curve POLYNOMIAL */
2266 /* on an interval [A,B]. */
2267
2268 /* KEYWORDS : */
2269 /* ----------- */
2270 /* LENGTH,CURVE,GAUSS,PRIVATE. */
2271
2272 /* INPUT ARGUMENTS : */
2273 /* ------------------ */
2274 /* NDIMAX : Max. number of lines of tables */
2275 /* (i.e. max. nb of polynoms). */
2276 /* NDIMEN : Dimension of the space (nb of polynoms). */
2277 /* NCOEFF : Nb of coefficients of the polynom. This is degree + 1.
2278 */
2279 /* COURBE(NDIMAX,NCOEFF) : Coefficients of the curve. */
2280 /* TDEBUT : Lower limit of the interval of integration for */
2281 /* length calculation. */
2282 /* TFINAL : Upper limit of the interval of integration for */
2283 /* length calculation. */
2284 /* EPSILN : REQIRED precision for length calculation. */
2285
2286 /* OUTPUT ARGUMENTS : */
2287 /* ------------------- */
2288 /* XLONGC : Length of the arc of curve */
2289 /* ERREUR : Precision OBTAINED for the length calculation. */
2290 /* IERCOD : Error code, 0 OK, >0 Serious error. */
2291 /* = 1 Too much iterations, the best calculated resultat */
2292 /* (is almost ERROR) */
2293 /* = 2 Pb MMLONCV (no result) */
2294 /* = 3 NDIM or NCOEFF invalid (no result) */
2295
2296 /* COMMONS USED : */
2297 /* ---------------- */
2298
2299 /* REFERENCES CALLED : */
2300 /* ----------------------- */
2301
2302 /* DESCRIPTION/NOTES/LIMITATIONS : */
2303 /* ----------------------------------- */
2304 /* The polynom is actually a set of polynoms with */
2305 /* coefficients arranged in a table of 2 indices, */
2306 /* each line relative to the polynom. */
2307 /* The polynom is defined by these coefficients ordered */
2308 /* by increasing power of the variable. */
2309 /* All polynoms have the same number of coefficients (the */
2310 /* same degree). */
2311
2312 /* This program cancels and replaces LENGCV, MLONGC and MLENCV. */
2313
2314 /* ATTENTION : if TDEBUT > TFINAL, the length is NEGATIVE. */
2315
2316 /* > */
2317 /* ***********************************************************************
2318 */
2319
2320 /* Name of the routine */
2321
2322
2323 /* ------------------------ General Initialization ---------------------
2324 */
2325
2326 /* Parameter adjustments */
2327 courbe_dim1 = *ndimax;
2328 courbe_offset = courbe_dim1 + 1;
2329 courbe -= courbe_offset;
2330
2331 /* Function Body */
2332 ibb = AdvApp2Var_SysBase::mnfndeb_();
2333 if (ibb >= 2) {
2334 AdvApp2Var_SysBase::mgenmsg_("MMCGLC1", 7L);
2335 }
2336
2337 *iercod = 0;
2338 *xlongc = 0.;
2339 *erreur = 0.;
2340
2341 /* ------ Test of equity of limits */
2342
2343 if (*tdebut == *tfinal) {
2344 *iercod = 0;
2345 goto L9999;
2346 }
2347
2348 /* ------ Test of the dimension and the number of coefficients */
2349
2350 if (*ndimen <= 0 || *ncoeff <= 0) {
2351 goto L9003;
2352 }
2353
2354 /* ----- Nb of current cutting, nb of iteration, */
2355 /* max nb of iterations */
2356
2357 ndec = 1;
2358 iter = 1;
2359
2360 itmax = 13;
2361
2362 /* ------ Variation of the nb of intervals */
2363 /* Multiplied by 2 at each iteration */
2364
2365 L5000:
2366 pas = (*tfinal - *tdebut) / ndec;
2367 sottc = 0.;
2368
2369 /* ------ Loop on all current NDEC intervals */
2370
2371 i__1 = ndec;
2372 for (kk = 1; kk <= i__1; ++kk) {
2373
2374 /* ------ Limits of the current integration interval */
2375
2376 tdeb = *tdebut + (kk - 1) * pas;
2377 tfin = tdeb + pas;
2378 mmloncv_(ndimax, ndimen, ncoeff, &courbe[courbe_offset], &tdeb, &tfin,
2379 &som, iercod);
2380 if (*iercod > 0) {
2381 goto L9002;
2382 }
2383
2384 sottc += som;
2385
2386 /* L100: */
2387 }
2388
2389
2390 /* ----------------- Test of the maximum number of iterations ------------
2391 */
2392
2393 /* Test if passes at least once ** */
2394
2395 if (iter == 1) {
2396 oldso = sottc;
2397 ndec <<= 1;
2398 ++iter;
2399 goto L5000;
2400 } else {
2401
2402 /* ------ Take into account DIF - Test of convergence */
2403
2404 ++iter;
2405 dif = (d__1 = sottc - oldso, advapp_abs(d__1));
2406
2407 /* ------ If DIF is OK, leave..., otherwise: */
2408
2409 if (dif > *epsiln) {
2410
2411 /* ------ If nb iteration exceeded, leave */
2412
2413 if (iter > itmax) {
2414 *iercod = 1;
2415 goto L9000;
2416 } else {
2417
2418 /* ------ Otherwise continue by cutting the initial interval.
2419 */
2420
2421 oldso = sottc;
2422 ndec <<= 1;
2423 goto L5000;
2424 }
2425 }
2426 }
2427
2428 /* ------------------------------ THE END -------------------------------
2429 */
2430
2431 L9000:
2432 *xlongc = sottc;
2433 *erreur = dif;
2434 goto L9999;
2435
2436 /* ---> PB in MMLONCV */
2437
2438 L9002:
2439 *iercod = 2;
2440 goto L9999;
2441
2442 /* ---> NCOEFF or NDIM invalid. */
2443
2444 L9003:
2445 *iercod = 3;
2446 goto L9999;
2447
2448 L9999:
2449 if (*iercod > 0) {
2450 AdvApp2Var_SysBase::maermsg_("MMCGLC1", iercod, 7L);
2451 }
2452 if (ibb >= 2) {
2453 AdvApp2Var_SysBase::mgsomsg_("MMCGLC1", 7L);
2454 }
2455 return 0;
2456 } /* mmcglc1_ */
2457
2458 //=======================================================================
2459 //function : mmchole_
2460 //purpose :
2461 //=======================================================================
mmchole_(integer *,integer * dimens,doublereal * amatri,integer * aposit,integer * posuiv,doublereal * chomat,integer * iercod)2462 int mmchole_(integer *,//mxcoef,
2463 integer *dimens,
2464 doublereal *amatri,
2465 integer *aposit,
2466 integer *posuiv,
2467 doublereal *chomat,
2468 integer *iercod)
2469
2470 {
2471 /* System generated locals */
2472 integer i__1, i__2, i__3;
2473 doublereal d__1;
2474
2475 /* Builtin functions */
2476 //double sqrt();
2477
2478 /* Local variables */
2479 logical ldbg;
2480 integer kmin, i__, j, k;
2481 doublereal somme;
2482 integer ptini, ptcou;
2483
2484
2485 /* ***********************************************************************
2486 */
2487
2488 /* FUNCTION : */
2489 /* ---------- T */
2490 /* Produce decomposition of choleski of matrix A in S.S */
2491 /* Calculate inferior triangular matrix S. */
2492
2493 /* KEYWORDS : */
2494 /* ----------- */
2495 /* RESOLUTION, MFACTORISATION, MATRIX_PROFILE, CHOLESKI */
2496
2497 /* INPUT ARGUMENTS : */
2498 /* -------------------- */
2499 /* MXCOEF : Max number of terms in the hessian profile */
2500 /* DIMENS : Dimension of the problem */
2501 /* AMATRI(MXCOEF) : Coefficients of the matrix profile */
2502 /* APOSIT(1,*) : Distance diagonal-left extremity of the line
2503 */
2504 /* APOSIT(2,*) : Position of diagonal terms in HESSIE */
2505 /* POSUIV(MXCOEF) : first line inferior not out of profile */
2506
2507 /* OUTPUT ARGUMENTS : */
2508 /* --------------------- */
2509 /* CHOMAT(MXCOEF) : Inferior triangular matrix preserving the */
2510 /* profile of AMATRI. */
2511 /* IERCOD : error code */
2512 /* = 0 : ok */
2513 /* = 1 : non-defined positive matrix */
2514
2515 /* COMMONS USED : */
2516 /* ------------------ */
2517
2518 /* .Neant. */
2519
2520 /* REFERENCES CALLED : */
2521 /* ---------------------- */
2522
2523 /* DESCRIPTION/NOTES/LIMITATIONS : */
2524 /* ----------------------------------- */
2525 /* DEBUG LEVEL = 4 */
2526 /* ***********************************************************************
2527 */
2528 /* DECLARATIONS */
2529 /* ***********************************************************************
2530 */
2531
2532
2533
2534 /* ***********************************************************************
2535 */
2536 /* INITIALISATIONS */
2537 /* ***********************************************************************
2538 */
2539
2540 /* Parameter adjustments */
2541 --chomat;
2542 --posuiv;
2543 --amatri;
2544 aposit -= 3;
2545
2546 /* Function Body */
2547 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 4;
2548 if (ldbg) {
2549 AdvApp2Var_SysBase::mgenmsg_("MMCHOLE", 7L);
2550 }
2551 *iercod = 0;
2552
2553 /* ***********************************************************************
2554 */
2555 /* PROCESSING */
2556 /* ***********************************************************************
2557 */
2558
2559 i__1 = *dimens;
2560 for (j = 1; j <= i__1; ++j) {
2561
2562 ptini = aposit[(j << 1) + 2];
2563
2564 somme = 0.;
2565 i__2 = ptini - 1;
2566 for (k = ptini - aposit[(j << 1) + 1]; k <= i__2; ++k) {
2567 /* Computing 2nd power */
2568 d__1 = chomat[k];
2569 somme += d__1 * d__1;
2570 }
2571
2572 if (amatri[ptini] - somme < 1e-32) {
2573 goto L9101;
2574 }
2575 chomat[ptini] = sqrt(amatri[ptini] - somme);
2576
2577 ptcou = ptini;
2578
2579 while(posuiv[ptcou] > 0) {
2580
2581 i__ = posuiv[ptcou];
2582 ptcou = aposit[(i__ << 1) + 2] - (i__ - j);
2583
2584 /* Calculate the sum of S .S for k =1 a j-1 */
2585 /* ik jk */
2586 somme = 0.;
2587 /* Computing MAX */
2588 i__2 = i__ - aposit[(i__ << 1) + 1], i__3 = j - aposit[(j << 1) +
2589 1];
2590 kmin = advapp_max(i__2,i__3);
2591 i__2 = j - 1;
2592 for (k = kmin; k <= i__2; ++k) {
2593 somme += chomat[aposit[(i__ << 1) + 2] - (i__ - k)] * chomat[
2594 aposit[(j << 1) + 2] - (j - k)];
2595 }
2596
2597 chomat[ptcou] = (amatri[ptcou] - somme) / chomat[ptini];
2598 }
2599 }
2600
2601 goto L9999;
2602
2603 /* ***********************************************************************
2604 */
2605 /* ERROR PROCESSING */
2606 /* ***********************************************************************
2607 */
2608
2609 L9101:
2610 *iercod = 1;
2611 goto L9999;
2612
2613 /* ***********************************************************************
2614 */
2615 /* RETURN CALLING PROGRAM */
2616 /* ***********************************************************************
2617 */
2618
2619 L9999:
2620
2621 AdvApp2Var_SysBase::maermsg_("MMCHOLE", iercod, 7L);
2622 if (ldbg) {
2623 AdvApp2Var_SysBase::mgsomsg_("MMCHOLE", 7L);
2624 }
2625
2626 return 0 ;
2627 } /* mmchole_ */
2628
2629 //=======================================================================
2630 //function : AdvApp2Var_MathBase::mmcvctx_
2631 //purpose :
2632 //=======================================================================
mmcvctx_(integer * ndimen,integer * ncofmx,integer * nderiv,doublereal * ctrtes,doublereal * crvres,doublereal * tabaux,doublereal * xmatri,integer * iercod)2633 int AdvApp2Var_MathBase::mmcvctx_(integer *ndimen,
2634 integer *ncofmx,
2635 integer *nderiv,
2636 doublereal *ctrtes,
2637 doublereal *crvres,
2638 doublereal *tabaux,
2639 doublereal *xmatri,
2640 integer *iercod)
2641
2642 {
2643 /* System generated locals */
2644 integer ctrtes_dim1, ctrtes_offset, crvres_dim1, crvres_offset,
2645 xmatri_dim1, xmatri_offset, tabaux_dim1, tabaux_offset, i__1,
2646 i__2;
2647
2648 /* Local variables */
2649 integer moup1, nordr;
2650 integer nd;
2651 integer ibb, ncf, ndv;
2652 doublereal eps1;
2653
2654
2655 /* ***********************************************************************
2656 */
2657
2658 /* FUNCTION : */
2659 /* ---------- */
2660 /* Calculate a polynomial curve checking the */
2661 /* passage constraints (interpolation) */
2662 /* from first derivatives, etc... to extremities. */
2663 /* Parameters at the extremities are supposed to be -1 and 1. */
2664
2665 /* KEYWORDS : */
2666 /* ----------- */
2667 /* ALL, AB_SPECIFI::CONSTRAINTS&,INTERPOLATION,&CURVE */
2668
2669 /* INPUT ARGUMENTS : */
2670 /* ------------------ */
2671 /* NDIMEN : Space Dimension. */
2672 /* NCOFMX : Nb of coeff. of curve CRVRES on each */
2673 /* dimension. */
2674 /* NDERIV : Order of constraint with derivatives : */
2675 /* 0 --> interpolation simple. */
2676 /* 1 --> interpolation+constraints with 1st. */
2677 /* 2 --> cas (0)+ (1) + " " 2nd derivatives. */
2678 /* etc... */
2679 /* CTRTES : Table of constraints. */
2680 /* CTRTES(*,1,*) = contraints at -1. */
2681 /* CTRTES(*,2,*) = contraints at 1. */
2682
2683 /* OUTPUT ARGUMENTS : */
2684 /* ------------------- */
2685 /* CRVRES : Resulting curve defined on (-1,1). */
2686 /* TABAUX : Auxilliary matrix. */
2687 /* XMATRI : Auxilliary matrix. */
2688
2689 /* COMMONS UTILISES : */
2690 /* ---------------- */
2691
2692 /* .Neant. */
2693
2694 /* REFERENCES CALLED : */
2695 /* ---------------------- */
2696 /* Type Name */
2697 /* MAERMSG R*8 DFLOAT MGENMSG */
2698 /* MGSOMSG MMEPS1 MMRSLW */
2699 /* I*4 MNFNDEB */
2700
2701 /* DESCRIPTION/NOTES/LIMITATIONS : */
2702 /* ----------------------------------- */
2703 /* The polynom (or the curve) is calculated by solving a */
2704 /* system of linear equations. If the imposed degree is great */
2705 /* it is preferable to call a routine based on */
2706 /* Lagrange or Hermite interpolation depending on the case. */
2707 /* (for a high degree the matrix of the system can be badly */
2708 /* conditioned). */
2709 /* This routine returns a curve defined in (-1,1). */
2710 /* In general case, it is necessary to use MCVCTG. */
2711 /* > */
2712 /* ***********************************************************************
2713 */
2714
2715 /* Name of the routine */
2716
2717
2718 /* Parameter adjustments */
2719 crvres_dim1 = *ncofmx;
2720 crvres_offset = crvres_dim1 + 1;
2721 crvres -= crvres_offset;
2722 xmatri_dim1 = *nderiv + 1;
2723 xmatri_offset = xmatri_dim1 + 1;
2724 xmatri -= xmatri_offset;
2725 tabaux_dim1 = *nderiv + 1 + *ndimen;
2726 tabaux_offset = tabaux_dim1 + 1;
2727 tabaux -= tabaux_offset;
2728 ctrtes_dim1 = *ndimen;
2729 ctrtes_offset = ctrtes_dim1 * 3 + 1;
2730 ctrtes -= ctrtes_offset;
2731
2732 /* Function Body */
2733 ibb = AdvApp2Var_SysBase::mnfndeb_();
2734 if (ibb >= 3) {
2735 AdvApp2Var_SysBase::mgenmsg_("MMCVCTX", 7L);
2736 }
2737 /* Precision. */
2738 AdvApp2Var_MathBase::mmeps1_(&eps1);
2739
2740 /* ****************** CALCULATION OF EVEN COEFFICIENTS *********************
2741 */
2742 /* ------------------------- Initialization -----------------------------
2743 */
2744
2745 nordr = *nderiv + 1;
2746 i__1 = nordr;
2747 for (ncf = 1; ncf <= i__1; ++ncf) {
2748 tabaux[ncf + tabaux_dim1] = 1.;
2749 /* L100: */
2750 }
2751
2752 /* ---------------- Calculation of terms corresponding to derivatives -------
2753 */
2754
2755 i__1 = nordr;
2756 for (ndv = 2; ndv <= i__1; ++ndv) {
2757 i__2 = nordr;
2758 for (ncf = 1; ncf <= i__2; ++ncf) {
2759 tabaux[ncf + ndv * tabaux_dim1] = tabaux[ncf + (ndv - 1) *
2760 tabaux_dim1] * (doublereal) ((ncf << 1) - ndv);
2761 /* L300: */
2762 }
2763 /* L200: */
2764 }
2765
2766 /* ------------------ Writing the second member -----------------------
2767 */
2768
2769 moup1 = 1;
2770 i__1 = nordr;
2771 for (ndv = 1; ndv <= i__1; ++ndv) {
2772 i__2 = *ndimen;
2773 for (nd = 1; nd <= i__2; ++nd) {
2774 tabaux[nordr + nd + ndv * tabaux_dim1] = (ctrtes[nd + ((ndv << 1)
2775 + 2) * ctrtes_dim1] + moup1 * ctrtes[nd + ((ndv << 1) + 1)
2776 * ctrtes_dim1]) / 2.;
2777 /* L500: */
2778 }
2779 moup1 = -moup1;
2780 /* L400: */
2781 }
2782
2783 /* -------------------- Resolution of the system ---------------------------
2784 */
2785
2786 mmrslw_(&nordr, &nordr, ndimen, &eps1, &tabaux[tabaux_offset], &xmatri[
2787 xmatri_offset], iercod);
2788 if (*iercod > 0) {
2789 goto L9999;
2790 }
2791 i__1 = *ndimen;
2792 for (nd = 1; nd <= i__1; ++nd) {
2793 i__2 = nordr;
2794 for (ncf = 1; ncf <= i__2; ++ncf) {
2795 crvres[(ncf << 1) - 1 + nd * crvres_dim1] = xmatri[ncf + nd *
2796 xmatri_dim1];
2797 /* L700: */
2798 }
2799 /* L600: */
2800 }
2801
2802 /* ***************** CALCULATION OF UNEVEN COEFFICIENTS ********************
2803 */
2804 /* ------------------------- Initialization -----------------------------
2805 */
2806
2807
2808 i__1 = nordr;
2809 for (ncf = 1; ncf <= i__1; ++ncf) {
2810 tabaux[ncf + tabaux_dim1] = 1.;
2811 /* L1100: */
2812 }
2813
2814 /* ---------------- Calculation of terms corresponding to derivatives -------
2815 */
2816
2817 i__1 = nordr;
2818 for (ndv = 2; ndv <= i__1; ++ndv) {
2819 i__2 = nordr;
2820 for (ncf = 1; ncf <= i__2; ++ncf) {
2821 tabaux[ncf + ndv * tabaux_dim1] = tabaux[ncf + (ndv - 1) *
2822 tabaux_dim1] * (doublereal) ((ncf << 1) - ndv + 1);
2823 /* L1300: */
2824 }
2825 /* L1200: */
2826 }
2827
2828 /* ------------------ Writing of the second member -----------------------
2829 */
2830
2831 moup1 = -1;
2832 i__1 = nordr;
2833 for (ndv = 1; ndv <= i__1; ++ndv) {
2834 i__2 = *ndimen;
2835 for (nd = 1; nd <= i__2; ++nd) {
2836 tabaux[nordr + nd + ndv * tabaux_dim1] = (ctrtes[nd + ((ndv << 1)
2837 + 2) * ctrtes_dim1] + moup1 * ctrtes[nd + ((ndv << 1) + 1)
2838 * ctrtes_dim1]) / 2.;
2839 /* L1500: */
2840 }
2841 moup1 = -moup1;
2842 /* L1400: */
2843 }
2844
2845 /* -------------------- Solution of the system ---------------------------
2846 */
2847
2848 mmrslw_(&nordr, &nordr, ndimen, &eps1, &tabaux[tabaux_offset], &xmatri[
2849 xmatri_offset], iercod);
2850 if (*iercod > 0) {
2851 goto L9999;
2852 }
2853 i__1 = *ndimen;
2854 for (nd = 1; nd <= i__1; ++nd) {
2855 i__2 = nordr;
2856 for (ncf = 1; ncf <= i__2; ++ncf) {
2857 crvres[(ncf << 1) + nd * crvres_dim1] = xmatri[ncf + nd *
2858 xmatri_dim1];
2859 /* L1700: */
2860 }
2861 /* L1600: */
2862 }
2863
2864 /* --------------------------- The end ----------------------------------
2865 */
2866
2867 L9999:
2868 if (*iercod != 0) {
2869 AdvApp2Var_SysBase::maermsg_("MMCVCTX", iercod, 7L);
2870 }
2871 if (ibb >= 3) {
2872 AdvApp2Var_SysBase::mgsomsg_("MMCVCTX", 7L);
2873 }
2874
2875 return 0 ;
2876 } /* mmcvctx_ */
2877
2878 //=======================================================================
2879 //function : AdvApp2Var_MathBase::mmcvinv_
2880 //purpose :
2881 //=======================================================================
mmcvinv_(integer * ndimax,integer * ncoef,integer * ndim,doublereal * curveo,doublereal * curve)2882 int AdvApp2Var_MathBase::mmcvinv_(integer *ndimax,
2883 integer *ncoef,
2884 integer *ndim,
2885 doublereal *curveo,
2886 doublereal *curve)
2887
2888 {
2889 /* Initialized data */
2890
2891 static char nomprg[8+1] = "MMCVINV ";
2892
2893 /* System generated locals */
2894 integer curve_dim1, curve_offset, curveo_dim1, curveo_offset, i__1, i__2;
2895
2896 /* Local variables */
2897 integer i__, nd, ibb;
2898
2899
2900 /* ***********************************************************************
2901 */
2902
2903 /* FUNCTION : */
2904 /* ---------- */
2905 /* Inversion of arguments of the final curve. */
2906
2907 /* KEYWORDS : */
2908 /* ----------- */
2909 /* SMOOTHING,CURVE */
2910
2911
2912 /* INPUT ARGUMENTS : */
2913 /* ------------------ */
2914
2915 /* NDIM: Space Dimension. */
2916 /* NCOEF: Degree of the polynom. */
2917 /* CURVEO: The curve before inversion. */
2918
2919 /* OUTPUT ARGUMENTS : */
2920 /* ------------------- */
2921 /* CURVE: The curve after inversion. */
2922
2923 /* COMMONS USED : */
2924 /* ---------------- */
2925 /* REFERENCES APPELEES : */
2926 /* ----------------------- */
2927 /* DESCRIPTION/NOTES/LIMITATIONS : */
2928 /* ----------------------------------- */
2929 /* ***********************************************************************
2930 */
2931
2932 /* The name of the routine */
2933 /* Parameter adjustments */
2934 curve_dim1 = *ndimax;
2935 curve_offset = curve_dim1 + 1;
2936 curve -= curve_offset;
2937 curveo_dim1 = *ncoef;
2938 curveo_offset = curveo_dim1 + 1;
2939 curveo -= curveo_offset;
2940
2941 /* Function Body */
2942
2943 ibb = AdvApp2Var_SysBase::mnfndeb_();
2944 if (ibb >= 2) {
2945 AdvApp2Var_SysBase::mgenmsg_(nomprg, 6L);
2946 }
2947
2948 i__1 = *ncoef;
2949 for (i__ = 1; i__ <= i__1; ++i__) {
2950 i__2 = *ndim;
2951 for (nd = 1; nd <= i__2; ++nd) {
2952 curve[nd + i__ * curve_dim1] = curveo[i__ + nd * curveo_dim1];
2953 /* L300: */
2954 }
2955 }
2956
2957 /* L9999: */
2958 return 0;
2959 } /* mmcvinv_ */
2960
2961 //=======================================================================
2962 //function : mmcvstd_
2963 //purpose :
2964 //=======================================================================
mmcvstd_(integer * ncofmx,integer * ndimax,integer * ncoeff,integer * ndimen,doublereal * crvcan,doublereal * courbe)2965 int mmcvstd_(integer *ncofmx,
2966 integer *ndimax,
2967 integer *ncoeff,
2968 integer *ndimen,
2969 doublereal *crvcan,
2970 doublereal *courbe)
2971
2972 {
2973 /* System generated locals */
2974 integer courbe_dim1, crvcan_dim1, crvcan_offset, i__1, i__2, i__3;
2975
2976 /* Local variables */
2977 integer ndeg, i__, j, j1, nd, ibb;
2978 doublereal bid;
2979
2980
2981 /* ***********************************************************************
2982 */
2983
2984 /* FUNCTION : */
2985 /* ---------- */
2986 /* Transform curve defined between [-1,1] into [0,1]. */
2987
2988 /* KEYWORDS : */
2989 /* ----------- */
2990 /* LIMITATION,RESTRICTION,CURVE */
2991
2992 /* INPUT ARGUMENTS : */
2993 /* ------------------ */
2994 /* NDIMAX : Dimension of the space. */
2995 /* NDIMEN : Dimension of the curve. */
2996 /* NCOEFF : Degree of the curve. */
2997 /* CRVCAN(NCOFMX,NDIMEN): The curve is defined at the interval [-1,1]. */
2998
2999 /* OUTPUT ARGUMENTS : */
3000 /* ------------------- */
3001 /* CURVE(NDIMAX,NCOEFF): Curve defined at the interval [0,1]. */
3002
3003 /* COMMONS USED : */
3004 /* ---------------- */
3005
3006 /* REFERENCES CALLED : */
3007 /* ----------------------- */
3008
3009 /* DESCRIPTION/NOTES/LIMITATIONS : */
3010 /* ----------------------------------- */
3011 /* > */
3012 /* ***********************************************************************
3013 */
3014
3015 /* Name of the program. */
3016
3017
3018 /* **********************************************************************
3019 */
3020
3021 /* FUNCTION : */
3022 /* ---------- */
3023 /* Provides binomial coefficients (Pascal triangle). */
3024
3025 /* KEYWORDS : */
3026 /* ----------- */
3027 /* Binomial coefficient from 0 to 60. read only . init by block data */
3028
3029 /* DEMSCRIPTION/NOTES/LIMITATIONS : */
3030 /* ----------------------------------- */
3031 /* Binomial coefficients form a triangular matrix. */
3032 /* This matrix is completed in table CNP by its transposition. */
3033 /* So: CNP(I,J) = CNP(J,I) for I and J = 0, ..., 60. */
3034
3035 /* Initialization is done with block-data MMLLL09.RES, */
3036 /* created by the program MQINICNP.FOR. */
3037 /* > */
3038 /* **********************************************************************
3039 */
3040
3041
3042
3043 /* ***********************************************************************
3044 */
3045
3046 /* Parameter adjustments */
3047 courbe_dim1 = *ndimax;
3048 --courbe;
3049 crvcan_dim1 = *ncofmx;
3050 crvcan_offset = crvcan_dim1;
3051 crvcan -= crvcan_offset;
3052
3053 /* Function Body */
3054 ibb = AdvApp2Var_SysBase::mnfndeb_();
3055 if (ibb >= 3) {
3056 AdvApp2Var_SysBase::mgenmsg_("MMCVSTD", 7L);
3057 }
3058 ndeg = *ncoeff - 1;
3059
3060 /* ------------------ Construction of the resulting curve ----------------
3061 */
3062
3063 i__1 = *ndimen;
3064 for (nd = 1; nd <= i__1; ++nd) {
3065 i__2 = ndeg;
3066 for (j = 0; j <= i__2; ++j) {
3067 bid = 0.;
3068 i__3 = ndeg;
3069 for (i__ = j; i__ <= i__3; i__ += 2) {
3070 bid += crvcan[i__ + nd * crvcan_dim1] * mmcmcnp_.cnp[i__ + j
3071 * 61];
3072 /* L410: */
3073 }
3074 courbe[nd + j * courbe_dim1] = bid;
3075
3076 bid = 0.;
3077 j1 = j + 1;
3078 i__3 = ndeg;
3079 for (i__ = j1; i__ <= i__3; i__ += 2) {
3080 bid += crvcan[i__ + nd * crvcan_dim1] * mmcmcnp_.cnp[i__ + j
3081 * 61];
3082 /* L420: */
3083 }
3084 courbe[nd + j * courbe_dim1] -= bid;
3085 /* L400: */
3086 }
3087 /* L300: */
3088 }
3089
3090 /* ------------------- Renormalization of the CURVE -------------------------
3091 */
3092
3093 bid = 1.;
3094 i__1 = ndeg;
3095 for (i__ = 0; i__ <= i__1; ++i__) {
3096 i__2 = *ndimen;
3097 for (nd = 1; nd <= i__2; ++nd) {
3098 courbe[nd + i__ * courbe_dim1] *= bid;
3099 /* L510: */
3100 }
3101 bid *= 2.;
3102 /* L500: */
3103 }
3104
3105 /* ----------------------------- The end --------------------------------
3106 */
3107
3108 if (ibb >= 3) {
3109 AdvApp2Var_SysBase::mgsomsg_("MMCVSTD", 7L);
3110 }
3111 return 0;
3112 } /* mmcvstd_ */
3113
3114 //=======================================================================
3115 //function : AdvApp2Var_MathBase::mmdrc11_
3116 //purpose :
3117 //=======================================================================
mmdrc11_(integer * iordre,integer * ndimen,integer * ncoeff,doublereal * courbe,doublereal * points,doublereal * mfactab)3118 int AdvApp2Var_MathBase::mmdrc11_(integer *iordre,
3119 integer *ndimen,
3120 integer *ncoeff,
3121 doublereal *courbe,
3122 doublereal *points,
3123 doublereal *mfactab)
3124
3125 {
3126 /* System generated locals */
3127 integer courbe_dim1, courbe_offset, points_dim2, points_offset, i__1,
3128 i__2;
3129
3130 /* Local variables */
3131
3132 integer ndeg, i__, j, ndgcb, nd, ibb;
3133
3134
3135 /* **********************************************************************
3136 */
3137
3138 /* FUNCTION : */
3139 /* ---------- */
3140 /* Calculation of successive derivatives of equation CURVE with */
3141 /* parameters -1, 1 from order 0 to order IORDRE */
3142 /* included. The calculation is produced without knowing the coefficients of */
3143 /* derivatives of the curve. */
3144
3145 /* KEYWORDS : */
3146 /* ----------- */
3147 /* POSITIONING,EXTREMITIES,CURVE,DERIVATIVE. */
3148
3149 /* INPUT ARGUMENTS : */
3150 /* ------------------ */
3151 /* IORDRE : Maximum order of calculation of derivatives. */
3152 /* NDIMEN : Dimension of the space. */
3153 /* NCOEFF : Number of coefficients of the curve (degree+1). */
3154 /* COURBE : Table of coefficients of the curve. */
3155
3156 /* OUTPUT ARGUMENTS : */
3157 /* ------------------- */
3158 /* POINTS : Table of values of consecutive derivatives */
3159 /* of parameters -1.D0 and 1.D0. */
3160 /* MFACTAB : Auxiliary table for calculation of factorial(I).
3161 */
3162
3163 /* COMMONS USED : */
3164 /* ---------------- */
3165 /* None. */
3166
3167 /* REFERENCES CALLED : */
3168 /* ----------------------- */
3169
3170 /* DESCRIPTION/NOTES/LIMITATIONS : */
3171 /* ----------------------------------- */
3172
3173 /* ---> ATTENTION, the coefficients of the curve are */
3174 /* in a reverse order. */
3175
3176 /* ---> The algorithm of calculation of derivatives is based on */
3177 /* generalization of Horner scheme : */
3178 /* k 2 */
3179 /* Let C(t) = uk.t + ... + u2.t + u1.t + u0 . */
3180
3181
3182 /* a0 = uk, b0 = 0, c0 = 0 and for 1<=j<=k, it is calculated : */
3183
3184 /* aj = a(j-1).x + u(k-j) */
3185 /* bj = b(j-1).x + a(j-1) */
3186 /* cj = c(j-1).x + b(j-1) */
3187
3188 /* So : C(x) = ak, C'(x) = bk, C"(x) = 2.ck . */
3189
3190 /* The algorithm is generalized easily for calculation of */
3191
3192 /* (n) */
3193 /* C (x) . */
3194 /* --------- */
3195 /* n! */
3196
3197 /* Reference : D. KNUTH, "The Art of Computer Programming" */
3198 /* --------- Vol. 2/Seminumerical Algorithms */
3199 /* Addison-Wesley Pub. Co. (1969) */
3200 /* pages 423-425. */
3201 /* > */
3202 /* **********************************************************************
3203 */
3204
3205 /* Name of the routine */
3206
3207 /* Parameter adjustments */
3208 points_dim2 = *iordre + 1;
3209 points_offset = (points_dim2 << 1) + 1;
3210 points -= points_offset;
3211 courbe_dim1 = *ncoeff;
3212 courbe_offset = courbe_dim1;
3213 courbe -= courbe_offset;
3214
3215 /* Function Body */
3216 ibb = AdvApp2Var_SysBase::mnfndeb_();
3217 if (ibb >= 2) {
3218 AdvApp2Var_SysBase::mgenmsg_("MMDRC11", 7L);
3219 }
3220
3221 if (*iordre < 0 || *ncoeff < 1) {
3222 goto L9999;
3223 }
3224
3225 /* ------------------- Initialization of table POINTS -----------------
3226 */
3227
3228 ndgcb = *ncoeff - 1;
3229 i__1 = *ndimen;
3230 for (nd = 1; nd <= i__1; ++nd) {
3231 points[(nd * points_dim2 << 1) + 1] = courbe[ndgcb + nd * courbe_dim1]
3232 ;
3233 points[(nd * points_dim2 << 1) + 2] = courbe[ndgcb + nd * courbe_dim1]
3234 ;
3235 /* L100: */
3236 }
3237
3238 i__1 = *ndimen;
3239 for (nd = 1; nd <= i__1; ++nd) {
3240 i__2 = *iordre;
3241 for (j = 1; j <= i__2; ++j) {
3242 points[((j + nd * points_dim2) << 1) + 1] = 0.;
3243 points[((j + nd * points_dim2) << 1) + 2] = 0.;
3244 /* L400: */
3245 }
3246 /* L300: */
3247 }
3248
3249 /* Calculation with parameter -1 and 1 */
3250
3251 i__1 = *ndimen;
3252 for (nd = 1; nd <= i__1; ++nd) {
3253 i__2 = ndgcb;
3254 for (ndeg = 1; ndeg <= i__2; ++ndeg) {
3255 for (i__ = *iordre; i__ >= 1; --i__) {
3256 points[((i__ + nd * points_dim2) << 1) + 1] = -points[((i__ + nd
3257 * points_dim2) << 1) + 1] + points[((i__ - 1 + nd *
3258 points_dim2) << 1) + 1];
3259 points[((i__ + nd * points_dim2) << 1) + 2] += points[((i__ - 1
3260 + nd * points_dim2) << 1) + 2];
3261 /* L800: */
3262 }
3263 points[(nd * points_dim2 << 1) + 1] = -points[(nd * points_dim2 <<
3264 1) + 1] + courbe[ndgcb - ndeg + nd * courbe_dim1];
3265 points[(nd * points_dim2 << 1) + 2] += courbe[ndgcb - ndeg + nd *
3266 courbe_dim1];
3267 /* L700: */
3268 }
3269 /* L600: */
3270 }
3271
3272 /* --------------------- Multiplication by factorial(I) --------------
3273 */
3274
3275 if (*iordre > 1) {
3276 mfac_(&mfactab[1], iordre);
3277
3278 i__1 = *ndimen;
3279 for (nd = 1; nd <= i__1; ++nd) {
3280 i__2 = *iordre;
3281 for (i__ = 2; i__ <= i__2; ++i__) {
3282 points[((i__ + nd * points_dim2) << 1) + 1] = mfactab[i__] *
3283 points[((i__ + nd * points_dim2) << 1) + 1];
3284 points[((i__ + nd * points_dim2) << 1) + 2] = mfactab[i__] *
3285 points[((i__ + nd * points_dim2) << 1) + 2];
3286 /* L1000: */
3287 }
3288 /* L900: */
3289 }
3290 }
3291
3292 /* ---------------------------- End -------------------------------------
3293 */
3294
3295 L9999:
3296 if (ibb >= 2) {
3297 AdvApp2Var_SysBase::mgsomsg_("MMDRC11", 7L);
3298 }
3299 return 0;
3300 } /* mmdrc11_ */
3301
3302 //=======================================================================
3303 //function : mmdrvcb_
3304 //purpose :
3305 //=======================================================================
mmdrvcb_(integer * ideriv,integer * ndim,integer * ncoeff,doublereal * courbe,doublereal * tparam,doublereal * tabpnt,integer * iercod)3306 int mmdrvcb_(integer *ideriv,
3307 integer *ndim,
3308 integer *ncoeff,
3309 doublereal *courbe,
3310 doublereal *tparam,
3311 doublereal *tabpnt,
3312 integer *iercod)
3313
3314 {
3315 /* System generated locals */
3316 integer courbe_dim1, tabpnt_dim1, i__1, i__2, i__3;
3317
3318 /* Local variables */
3319 integer ndeg, i__, j, nd, ndgcrb, iptpnt, ibb;
3320
3321
3322 /* *********************************************************************** */
3323 /* FUNCTION : */
3324 /* ---------- */
3325
3326 /* Calculation of successive derivatives of equation CURVE with */
3327 /* parameter TPARAM from order 0 to order IDERIV included. */
3328 /* The calculation is produced without knowing the coefficients of */
3329 /* derivatives of the CURVE. */
3330
3331 /* KEYWORDS : */
3332 /* ----------- */
3333 /* POSITIONING,PARAMETER,CURVE,DERIVATIVE. */
3334
3335 /* INPUT ARGUMENTS : */
3336 /* ------------------ */
3337 /* IORDRE : Maximum order of calculation of derivatives. */
3338 /* NDIMEN : Dimension of the space. */
3339 /* NCOEFF : Number of coefficients of the curve (degree+1). */
3340 /* COURBE : Table of coefficients of the curve. */
3341 /* TPARAM : Value of the parameter where the curve should be evaluated. */
3342
3343 /* OUTPUT ARGUMENTS : */
3344 /* ------------------- */
3345 /* TABPNT : Table of values of consecutive derivatives */
3346 /* of parameter TPARAM. */
3347 /* IERCOD : 0 = OK, */
3348 /* 1 = incoherent input. */
3349
3350 /* COMMONS USED : */
3351 /* ---------------- */
3352 /* None. */
3353
3354 /* REFERENCES CALLED : */
3355 /* ----------------------- */
3356
3357 /* DESCRIPTION/NOTES/LIMITATIONS : */
3358 /* ----------------------------------- */
3359
3360 /* The algorithm of calculation of derivatives is based on */
3361 /* generalization of the Horner scheme : */
3362 /* k 2 */
3363 /* Let C(t) = uk.t + ... + u2.t + u1.t + u0 . */
3364
3365
3366 /* a0 = uk, b0 = 0, c0 = 0 and for 1<=j<=k, it is calculated : */
3367
3368 /* aj = a(j-1).x + u(k-j) */
3369 /* bj = b(j-1).x + a(j-1) */
3370 /* cj = c(j-1).x + b(j-1) */
3371
3372 /* So, it is obtained : C(x) = ak, C'(x) = bk, C"(x) = 2.ck . */
3373
3374 /* The algorithm can be easily generalized for the calculation of */
3375
3376 /* (n) */
3377 /* C (x) . */
3378 /* --------- */
3379 /* n! */
3380
3381 /* Reference : D. KNUTH, "The Art of Computer Programming" */
3382 /* --------- Vol. 2/Seminumerical Algorithms */
3383 /* Addison-Wesley Pub. Co. (1969) */
3384 /* pages 423-425. */
3385
3386 /* ---> To evaluare derivatives at 0 and 1, it is preferable */
3387 /* to use routine MDRV01.FOR . */
3388 /* > */
3389 /* **********************************************************************
3390 */
3391
3392 /* Name of the routine */
3393
3394 /* Parameter adjustments */
3395 tabpnt_dim1 = *ndim;
3396 --tabpnt;
3397 courbe_dim1 = *ndim;
3398 --courbe;
3399
3400 /* Function Body */
3401 ibb = AdvApp2Var_SysBase::mnfndeb_();
3402 if (ibb >= 2) {
3403 AdvApp2Var_SysBase::mgenmsg_("MMDRVCB", 7L);
3404 }
3405
3406 if (*ideriv < 0 || *ncoeff < 1) {
3407 *iercod = 1;
3408 goto L9999;
3409 }
3410 *iercod = 0;
3411
3412 /* ------------------- Initialization of table TABPNT -----------------
3413 */
3414
3415 ndgcrb = *ncoeff - 1;
3416 i__1 = *ndim;
3417 for (nd = 1; nd <= i__1; ++nd) {
3418 tabpnt[nd] = courbe[nd + ndgcrb * courbe_dim1];
3419 /* L100: */
3420 }
3421
3422 if (*ideriv < 1) {
3423 goto L200;
3424 }
3425 iptpnt = *ndim * *ideriv;
3426 AdvApp2Var_SysBase::mvriraz_(&iptpnt,
3427 &tabpnt[tabpnt_dim1 + 1]);
3428 L200:
3429
3430 /* ------------------------ Calculation of parameter TPARAM ------------------
3431 */
3432
3433 i__1 = ndgcrb;
3434 for (ndeg = 1; ndeg <= i__1; ++ndeg) {
3435 i__2 = *ndim;
3436 for (nd = 1; nd <= i__2; ++nd) {
3437 for (i__ = *ideriv; i__ >= 1; --i__) {
3438 tabpnt[nd + i__ * tabpnt_dim1] = tabpnt[nd + i__ *
3439 tabpnt_dim1] * *tparam + tabpnt[nd + (i__ - 1) *
3440 tabpnt_dim1];
3441 /* L700: */
3442 }
3443 tabpnt[nd] = tabpnt[nd] * *tparam + courbe[nd + (ndgcrb - ndeg) *
3444 courbe_dim1];
3445 /* L600: */
3446 }
3447 /* L500: */
3448 }
3449
3450 /* --------------------- Multiplication by factorial(I) -------------
3451 */
3452
3453 i__1 = *ideriv;
3454 for (i__ = 2; i__ <= i__1; ++i__) {
3455 i__2 = i__;
3456 for (j = 2; j <= i__2; ++j) {
3457 i__3 = *ndim;
3458 for (nd = 1; nd <= i__3; ++nd) {
3459 tabpnt[nd + i__ * tabpnt_dim1] = (doublereal) j * tabpnt[nd +
3460 i__ * tabpnt_dim1];
3461 /* L1200: */
3462 }
3463 /* L1100: */
3464 }
3465 /* L1000: */
3466 }
3467
3468 /* --------------------------- The end ---------------------------------
3469 */
3470
3471 L9999:
3472 if (*iercod > 0) {
3473 AdvApp2Var_SysBase::maermsg_("MMDRVCB", iercod, 7L);
3474 }
3475 return 0;
3476 } /* mmdrvcb_ */
3477
3478 //=======================================================================
3479 //function : AdvApp2Var_MathBase::mmdrvck_
3480 //purpose :
3481 //=======================================================================
mmdrvck_(integer * ncoeff,integer * ndimen,doublereal * courbe,integer * ideriv,doublereal * tparam,doublereal * pntcrb)3482 int AdvApp2Var_MathBase::mmdrvck_(integer *ncoeff,
3483 integer *ndimen,
3484 doublereal *courbe,
3485 integer *ideriv,
3486 doublereal *tparam,
3487 doublereal *pntcrb)
3488
3489 {
3490 /* Initialized data */
3491
3492 static doublereal mmfack[21] = { 1.,2.,6.,24.,120.,720.,5040.,40320.,
3493 362880.,3628800.,39916800.,479001600.,6227020800.,87178291200.,
3494 1.307674368e12,2.0922789888e13,3.55687428096e14,6.402373705728e15,
3495 1.21645100408832e17,2.43290200817664e18,5.109094217170944e19 };
3496
3497 /* System generated locals */
3498 integer courbe_dim1, courbe_offset, i__1, i__2;
3499
3500 /* Local variables */
3501 integer i__, j, k, nd;
3502 doublereal mfactk, bid;
3503
3504
3505 /* IMPLICIT INTEGER (I-N) */
3506 /* IMPLICIT DOUBLE PRECISION(A-H,O-Z) */
3507
3508
3509 /* ***********************************************************************
3510 */
3511
3512 /* FONCTION : */
3513 /* ---------- */
3514 /* Calculate the value of a derived curve of order IDERIV in */
3515 /* a point of parameter TPARAM. */
3516
3517 /* KEYWORDS : */
3518 /* ----------- */
3519 /* POSITIONING,CURVE,DERIVATIVE of ORDER K. */
3520
3521 /* INPUT ARGUMENTS : */
3522 /* ------------------ */
3523 /* NCOEFF : Degree +1 of the curve. */
3524 /* NDIMEN : Dimension of the space (2 or 3 in general) */
3525 /* COURBE : Table of coefficients of the curve. */
3526 /* IDERIV : Required order of derivation : 1=1st derivative, etc... */
3527 /* TPARAM : Value of parameter of the curve. */
3528
3529 /* OUTPUT ARGUMENTS : */
3530 /* ------------------- */
3531 /* PNTCRB : Point of parameter TPARAM on the derivative of order */
3532 /* IDERIV of CURVE. */
3533
3534 /* COMMONS USED : */
3535 /* ---------------- */
3536 /* MMCMCNP */
3537
3538 /* REFERENCES CALLED : */
3539 /* ---------------------- */
3540 /* None. */
3541 /* DESCRIPTION/NOTES/LIMITATIONS : */
3542 /* ----------------------------------- */
3543
3544 /* The code below was written basing on the following algorithm :
3545 */
3546
3547 /* Let P(t) = a1 + a2*t + ... an*t**n. The derivative of order k of P */
3548 /* (containing n-k coefficients) is calculated as follows : */
3549
3550 /* Pk(t) = a(k+1)*CNP(k,k)*k! */
3551 /* + a(k+2)*CNP(k+1,k)*k! * t */
3552 /* . */
3553 /* . */
3554 /* . */
3555 /* + a(n)*CNP(n-1,k)*k! * t**(n-k-1). */
3556
3557 /* Evaluation is produced following the classic Horner scheme. */
3558 /* > */
3559 /* ***********************************************************************
3560 */
3561
3562
3563 /* Factorials (1 to 21) caculated on VAX in R*16 */
3564
3565
3566 /* **********************************************************************
3567 */
3568
3569 /* FUNCTION : */
3570 /* ---------- */
3571 /* Serves to provide binomial coefficients (Pascal triangle). */
3572
3573 /* KEYWORDS : */
3574 /* ----------- */
3575 /* Binomial Coeff from 0 to 60. read only . init by block data */
3576
3577 /* DEMSCRIPTION/NOTES/LIMITATIONS : */
3578 /* ----------------------------------- */
3579 /* Binomial coefficients form a triangular matrix. */
3580 /* This matrix is completed in table CNP by its transposition. */
3581 /* So: CNP(I,J) = CNP(J,I) for I and J = 0, ..., 60. */
3582
3583 /* Initialization is done by block-data MMLLL09.RES, */
3584 /* created by program MQINICNP.FOR. */
3585 /* > */
3586 /* **********************************************************************
3587 */
3588
3589
3590
3591 /* ***********************************************************************
3592 */
3593
3594 /* Parameter adjustments */
3595 --pntcrb;
3596 courbe_dim1 = *ndimen;
3597 courbe_offset = courbe_dim1 + 1;
3598 courbe -= courbe_offset;
3599
3600 /* Function Body */
3601
3602 /* -------------- Case when the order of derivative is greater than -------------------
3603 */
3604 /* ---------------- the degree of the curve ---------------------
3605 */
3606
3607 if (*ideriv >= *ncoeff) {
3608 i__1 = *ndimen;
3609 for (nd = 1; nd <= i__1; ++nd) {
3610 pntcrb[nd] = 0.;
3611 /* L100: */
3612 }
3613 goto L9999;
3614 }
3615 /* **********************************************************************
3616 */
3617 /* General processing*/
3618 /* **********************************************************************
3619 */
3620 /* --------------------- Calculation of Factorial(IDERIV) ------------------
3621 */
3622
3623 k = *ideriv;
3624 if (*ideriv <= 21 && *ideriv > 0) {
3625 mfactk = mmfack[k - 1];
3626 } else {
3627 mfactk = 1.;
3628 i__1 = k;
3629 for (i__ = 2; i__ <= i__1; ++i__) {
3630 mfactk *= i__;
3631 /* L200: */
3632 }
3633 }
3634
3635 /* ------- Calculation of derivative of order IDERIV of CURVE in TPARAM -----
3636 */
3637 /* ---> Attention : binomial coefficient C(n,m) is represented in */
3638 /* MCCNP by CNP(N,M). */
3639
3640 i__1 = *ndimen;
3641 for (nd = 1; nd <= i__1; ++nd) {
3642 pntcrb[nd] = courbe[nd + *ncoeff * courbe_dim1] * mmcmcnp_.cnp[*
3643 ncoeff - 1 + k * 61] * mfactk;
3644 /* L300: */
3645 }
3646
3647 i__1 = k + 1;
3648 for (j = *ncoeff - 1; j >= i__1; --j) {
3649 bid = mmcmcnp_.cnp[j - 1 + k * 61] * mfactk;
3650 i__2 = *ndimen;
3651 for (nd = 1; nd <= i__2; ++nd) {
3652 pntcrb[nd] = pntcrb[nd] * *tparam + courbe[nd + j * courbe_dim1] *
3653 bid;
3654 /* L500: */
3655 }
3656 /* L400: */
3657 }
3658
3659 /* -------------------------------- The end -----------------------------
3660 */
3661
3662 L9999:
3663
3664 return 0 ;
3665
3666 } /* mmdrvck_ */
3667 //=======================================================================
3668 //function : AdvApp2Var_MathBase::mmeps1_
3669 //purpose :
3670 //=======================================================================
mmeps1_(doublereal * epsilo)3671 int AdvApp2Var_MathBase::mmeps1_(doublereal *epsilo)
3672
3673 {
3674 /* ***********************************************************************
3675 */
3676
3677 /* FUNCTION : */
3678 /* ---------- */
3679 /* Extraction of EPS1 from COMMON MPRCSN. EPS1 is spatial zero */
3680 /* equal to 1.D-9 */
3681
3682 /* KEYWORDS : */
3683 /* ----------- */
3684 /* MPRCSN,PRECISON,EPS1. */
3685
3686 /* INPUT ARGUMENTS : */
3687 /* ------------------ */
3688 /* None */
3689
3690 /* OUTPUT ARGUMENTS : */
3691 /* ------------------- */
3692 /* EPSILO : Value of EPS1 (spatial zero (10**-9)) */
3693
3694 /* COMMONS USED : */
3695 /* ---------------- */
3696
3697 /* REFERENCES CALLED : */
3698 /* ----------------------- */
3699
3700 /* DESCRIPTION/NOTES/LIMITATIONS : */
3701 /* ----------------------------------- */
3702 /* EPS1 is ABSOLUTE spatial zero, so it is necessary */
3703 /* to use it whenever it is necessary to test if a variable */
3704 /* is null. For example, if the norm of a vector is lower than */
3705 /* EPS1, this vector is NULL ! (when one works in */
3706 /* REAL*8) It is absolutely not advised to test arguments */
3707 /* compared to EPS1**2. Taking into account the rounding errors inevitable */
3708 /* during calculations, this causes testing compared to 0.D0. */
3709 /* > */
3710 /* ***********************************************************************
3711 */
3712
3713
3714
3715 /* ***********************************************************************
3716 */
3717
3718 /* FUNCTION : */
3719 /* ---------- */
3720 /* Gives tolerances of invalidity in stream */
3721 /* as well as limits of iterative processes */
3722
3723 /* general context, modifiable by the user */
3724
3725 /* KEYWORDS : */
3726 /* ----------- */
3727 /* PARAMETER , TOLERANCE */
3728
3729 /* DEMSCRIPTION/NOTES/LIMITATIONS : */
3730 /* ----------------------------------- */
3731 /* INITIALISATION : profile , **VIA MPRFTX** at input in stream */
3732 /* loading of default values of the profile in MPRFTX at input */
3733 /* in stream. They are preserved in local variables of MPRFTX */
3734
3735 /* Reset of default values : MDFINT */
3736 /* Interactive modification by the user : MDBINT */
3737
3738 /* ACCESS FUNCTION : MMEPS1 ... EPS1 */
3739 /* MEPSPB ... EPS3,EPS4 */
3740 /* MEPSLN ... EPS2, NITERM , NITERR */
3741 /* MEPSNR ... EPS2 , NITERM */
3742 /* MITERR ... NITERR */
3743 /* > */
3744 /* ***********************************************************************
3745 */
3746
3747 /* NITERM : max nb of iterations */
3748 /* NITERR : nb of rapid iterations */
3749 /* EPS1 : tolerance of 3D null distance */
3750 /* EPS2 : tolerance of parametric null distance */
3751 /* EPS3 : tolerance to avoid division by 0.. */
3752 /* EPS4 : angular tolerance */
3753
3754
3755
3756 /* ***********************************************************************
3757 */
3758 *epsilo = mmprcsn_.eps1;
3759
3760 return 0 ;
3761 } /* mmeps1_ */
3762
3763 //=======================================================================
3764 //function : mmexthi_
3765 //purpose :
3766 //=======================================================================
mmexthi_(integer * ndegre,NCollection_Array1<doublereal> & hwgaus)3767 int mmexthi_(integer *ndegre,
3768 NCollection_Array1<doublereal>& hwgaus)
3769
3770 {
3771 /* System generated locals */
3772 integer i__1;
3773
3774 /* Local variables */
3775 integer iadd, ideb, ndeg2, nmod2, ii, ibb;
3776 integer kpt;
3777
3778 /* **********************************************************************
3779 */
3780
3781 /* FONCTION : */
3782 /* ---------- */
3783 /* Extract of common LDGRTL the weight of formulas of */
3784 /* Gauss quadrature on all roots of Legendre polynoms of degree */
3785 /* NDEGRE defined on [-1,1]. */
3786
3787 /* KEYWORDS : */
3788 /* ----------- */
3789 /* ALL, AB_SPECIFI::COMMON&, EXTRACTION, &WEIGHT, &GAUSS. */
3790
3791 /* INPUT ARGUMENTS : */
3792 /* ------------------ */
3793 /* NDEGRE : Mathematic degree of Legendre polynom. It should have */
3794 /* 2 <= NDEGRE <= 61. */
3795
3796 /* OUTPUT ARGUMENTS : */
3797 /* ------------------- */
3798 /* HWGAUS : The table of weights of Gauss quadrature formulas */
3799 /* relative to NDEGRE roots of a polynome de Legendre de */
3800 /* degre NDEGRE. */
3801
3802 /* COMMONS UTILISES : */
3803 /* ---------------- */
3804 /* MLGDRTL */
3805
3806 /* REFERENCES CALLED : */
3807 /* ----------------------- */
3808
3809 /* DESCRIPTION/NOTES/LIMITATIONS : */
3810 /* ----------------------------------- */
3811 /* ATTENTION: The condition on NDEGRE ( 2 <= NDEGRE <= 61) is not */
3812 /* tested. The caller should make the test. */
3813
3814 /* Name of the routine */
3815
3816
3817 /* Common MLGDRTL: */
3818 /* This common includes POSITIVE roots of Legendre polynims */
3819 /* AND weights of Gauss quadrature formulas on all */
3820 /* POSITIVE roots of Legendre polynoms. */
3821
3822
3823
3824 /* ***********************************************************************
3825 */
3826
3827 /* FUNCTION : */
3828 /* ---------- */
3829 /* The common of Legendre roots. */
3830
3831 /* KEYWORDS : */
3832 /* ----------- */
3833 /* BASE LEGENDRE */
3834
3835 /* DESCRIPTION/NOTES/LIMITATIONS : */
3836 /* ----------------------------------- */
3837 /* > */
3838 /* ***********************************************************************
3839 */
3840
3841
3842
3843
3844 /* ROOTAB : Table of all roots of Legendre polynoms */
3845 /* within the interval [0,1]. They are ranked for the degrees increasing from */
3846 /* 2 to 61. */
3847 /* HILTAB : Table of Legendre interpolators concerning ROOTAB. */
3848 /* The adressing is the same. */
3849 /* HI0TAB : Table of Legendre interpolators for root x=0 */
3850 /* of polynoms of UNEVEN degree. */
3851 /* RTLTB0 : Table of Li(uk) where uk are the roots of */
3852 /* Legendre polynom of EVEN degree. */
3853 /* RTLTB1 : Table of Li(uk) where uk are the roots of */
3854 /* Legendre polynom of UNEVEN degree. */
3855
3856
3857 /************************************************************************
3858 *****/
3859
3860 /* Function Body */
3861 ibb = AdvApp2Var_SysBase::mnfndeb_();
3862 if (ibb >= 3) {
3863 AdvApp2Var_SysBase::mgenmsg_("MMEXTHI", 7L);
3864 }
3865
3866 ndeg2 = *ndegre / 2;
3867 nmod2 = *ndegre % 2;
3868
3869 /* Address of Gauss weight associated to the 1st strictly */
3870 /* positive root of Legendre polynom of degree NDEGRE in MLGDRTL. */
3871
3872 iadd = ndeg2 * (ndeg2 - 1) / 2 + 1;
3873
3874 /* Index of the 1st HWGAUS element associated to the 1st strictly */
3875 /* positive root of Legendre polynom of degree NDEGRE. */
3876
3877 ideb = (*ndegre + 1) / 2 + 1;
3878
3879 /* Reading of weights associated to strictly positive roots. */
3880
3881 i__1 = *ndegre;
3882 for (ii = ideb; ii <= i__1; ++ii) {
3883 kpt = iadd + ii - ideb;
3884 hwgaus(ii) = mlgdrtl_.hiltab[kpt + nmod2 * 465 - 1];
3885 /* L100: */
3886 }
3887
3888 /* For strictly negative roots, the weight is the same. */
3889 /* i.e HW(1) = HW(NDEGRE), HW(2) = HW(NDEGRE-1), etc... */
3890
3891 i__1 = ndeg2;
3892 for (ii = 1; ii <= i__1; ++ii) {
3893 hwgaus(ii) = hwgaus(*ndegre + 1 - ii);
3894 /* L200: */
3895 }
3896
3897 /* Case of uneven NDEGRE, 0 is root of Legendre polynom, */
3898 /* associated Gauss weights are loaded. */
3899
3900 if (nmod2 == 1) {
3901 hwgaus(ndeg2 + 1) = mlgdrtl_.hi0tab[ndeg2];
3902 }
3903
3904 /* --------------------------- The end ----------------------------------
3905 */
3906
3907 if (ibb >= 3) {
3908 AdvApp2Var_SysBase::mgsomsg_("MMEXTHI", 7L);
3909 }
3910 return 0;
3911 } /* mmexthi_ */
3912
3913 //=======================================================================
3914 //function : mmextrl_
3915 //purpose :
3916 //=======================================================================
mmextrl_(integer * ndegre,NCollection_Array1<doublereal> & rootlg)3917 int mmextrl_(integer *ndegre,
3918 NCollection_Array1<doublereal>& rootlg)
3919 {
3920 /* System generated locals */
3921 integer i__1;
3922
3923 /* Local variables */
3924 integer iadd, ideb, ndeg2, nmod2, ii, ibb;
3925 integer kpt;
3926
3927
3928 /* **********************************************************************
3929 */
3930
3931 /* FUNCTION : */
3932 /* ---------- */
3933 /* Extract of the Common LDGRTL of Legendre polynom roots */
3934 /* of degree NDEGRE defined on [-1,1]. */
3935
3936 /* KEYWORDS : */
3937 /* ----------- */
3938 /* ALL, AB_SPECIFI::COMMON&, EXTRACTION, &ROOT, &LEGENDRE. */
3939
3940 /* INPUT ARGUMENTS : */
3941 /* ------------------ */
3942 /* NDEGRE : Mathematic degree of Legendre polynom. */
3943 /* It is required to have 2 <= NDEGRE <= 61. */
3944
3945 /* OUTPUT ARGUMENTS : */
3946 /* ------------------- */
3947 /* ROOTLG : The table of roots of Legendre polynom of degree */
3948 /* NDEGRE defined on [-1,1]. */
3949
3950 /* COMMONS USED : */
3951 /* ---------------- */
3952 /* MLGDRTL */
3953
3954 /* REFERENCES CALLED : */
3955 /* ----------------------- */
3956
3957 /* DESCRIPTION/NOTES/LIMITATIONS : */
3958 /* ----------------------------------- */
3959 /* ATTENTION: Condition of NDEGRE ( 2 <= NDEGRE <= 61) is not */
3960 /* tested. The caller should make the test. */
3961 /* > */
3962 /* **********************************************************************
3963 */
3964
3965
3966 /* Name of the routine */
3967
3968
3969 /* Common MLGDRTL: */
3970 /* This common includes POSITIVE roots of Legendre polynoms */
3971 /* AND the weight of Gauss quadrature formulas on all */
3972 /* POSITIVE roots of Legendre polynoms. */
3973
3974 /* ***********************************************************************
3975 */
3976
3977 /* FUNCTION : */
3978 /* ---------- */
3979 /* The common of Legendre roots. */
3980
3981 /* KEYWORDS : */
3982 /* ----------- */
3983 /* BASE LEGENDRE */
3984
3985
3986 /* ***********************************************************************
3987 */
3988
3989 /* ROOTAB : Table of all roots of Legendre polynoms */
3990 /* within the interval [0,1]. They are ranked for the degrees increasing from */
3991 /* 2 to 61. */
3992 /* HILTAB : Table of Legendre interpolators concerning ROOTAB. */
3993 /* The adressing is the same. */
3994 /* HI0TAB : Table of Legendre interpolators for root x=0 */
3995 /* of polynoms of UNEVEN degree. */
3996 /* RTLTB0 : Table of Li(uk) where uk are the roots of */
3997 /* Legendre polynom of EVEN degree. */
3998 /* RTLTB1 : Table of Li(uk) where uk are the roots of */
3999 /* Legendre polynom of UNEVEN degree. */
4000
4001
4002 /************************************************************************
4003 *****/
4004
4005 /* Function Body */
4006 ibb = AdvApp2Var_SysBase::mnfndeb_();
4007 if (ibb >= 3) {
4008 AdvApp2Var_SysBase::mgenmsg_("MMEXTRL", 7L);
4009 }
4010
4011 ndeg2 = *ndegre / 2;
4012 nmod2 = *ndegre % 2;
4013
4014 /* Address of the 1st strictly positive root of Legendre polynom */
4015 /* of degree NDEGRE in MLGDRTL. */
4016
4017 iadd = ndeg2 * (ndeg2 - 1) / 2 + 1;
4018
4019 /* Indice, in ROOTLG, of the 1st strictly positive root */
4020 /* of Legendre polynom of degree NDEGRE. */
4021
4022 ideb = (*ndegre + 1) / 2 + 1;
4023
4024 /* Reading of strictly positive roots. */
4025
4026 i__1 = *ndegre;
4027 for (ii = ideb; ii <= i__1; ++ii) {
4028 kpt = iadd + ii - ideb;
4029 rootlg(ii) = mlgdrtl_.rootab[kpt + nmod2 * 465 - 1];
4030 /* L100: */
4031 }
4032
4033 /* Strictly negative roots are equal to positive roots
4034 */
4035 /* to the sign i.e RT(1) = -RT(NDEGRE), RT(2) = -RT(NDEGRE-1), etc...
4036 */
4037
4038 i__1 = ndeg2;
4039 for (ii = 1; ii <= i__1; ++ii) {
4040 rootlg(ii) = -rootlg(*ndegre + 1 - ii);
4041 /* L200: */
4042 }
4043
4044 /* Case NDEGRE uneven, 0 is root of Legendre polynom. */
4045
4046 if (nmod2 == 1) {
4047 rootlg(ndeg2 + 1) = 0.;
4048 }
4049
4050 /* -------------------------------- THE END -----------------------------
4051 */
4052
4053 if (ibb >= 3) {
4054 AdvApp2Var_SysBase::mgenmsg_("MMEXTRL", 7L);
4055 }
4056 return 0;
4057 } /* mmextrl_ */
4058
4059 //=======================================================================
4060 //function : AdvApp2Var_MathBase::mmfmca8_
4061 //purpose :
4062 //=======================================================================
mmfmca8_(const integer * ndimen,const integer * ncoefu,const integer * ncoefv,const integer * ndimax,const integer * ncfumx,const integer *,doublereal * tabini,doublereal * tabres)4063 int AdvApp2Var_MathBase::mmfmca8_(const integer *ndimen,
4064 const integer *ncoefu,
4065 const integer *ncoefv,
4066 const integer *ndimax,
4067 const integer *ncfumx,
4068 const integer *,//ncfvmx,
4069 doublereal *tabini,
4070 doublereal *tabres)
4071
4072 {
4073 /* System generated locals */
4074 integer tabini_dim1, tabini_dim2, tabini_offset, tabres_dim1, tabres_dim2,
4075 tabres_offset;
4076
4077 /* Local variables */
4078 integer i__, j, k, ilong;
4079
4080
4081
4082 /* **********************************************************************
4083 */
4084
4085 /* FUNCTION : */
4086 /* ---------- */
4087 /* Expansion of a table containing only most important things into a */
4088 /* greater data table. */
4089
4090 /* KEYWORDS : */
4091 /* ----------- */
4092 /* ALL, MATH_ACCES:: CARREAU&, DECOMPRESSION, &CARREAU */
4093
4094 /* INPUT ARGUMENTS : */
4095 /* ------------------ */
4096 /* NDIMEN: Dimension of the workspace. */
4097 /* NCOEFU: Degree +1 of the table by u. */
4098 /* NCOEFV: Degree +1 of the table by v. */
4099 /* NDIMAX: Max dimension of the space. */
4100 /* NCFUMX: Max Degree +1 of the table by u. */
4101 /* NCFVMX: Max Degree +1 of the table by v. */
4102 /* TABINI: The table to be decompressed. */
4103
4104 /* OUTPUT ARGUMENTS : */
4105 /* ------------------- */
4106 /* TABRES: Decompressed table. */
4107
4108 /* COMMONS USED : */
4109 /* ---------------- */
4110
4111 /* REFERENCES CALLED : */
4112 /* ----------------------- */
4113
4114 /* DESCRIPTION/NOTES/LIMITATIONS : */
4115 /* ----------------------------------- */
4116 /* The following call : */
4117
4118 /* CALL MMFMCA8(NDIMEN,NCOEFU,NCOEFV,NDIMAX,NCFUMX,NCFVMX,TABINI,TABINI)
4119 */
4120
4121 /* where TABINI is input/output argument, is possible provided */
4122 /* that the caller has declared TABINI in (NDIMAX,NCFUMX,NCFVMX) */
4123
4124 /* ATTENTION : it is not checked that NDIMAX >= NDIMEN, */
4125 /* NCOEFU >= NCFMXU and NCOEFV >= NCFMXV. */
4126 /* > */
4127 /* **********************************************************************
4128 */
4129
4130
4131 /* Parameter adjustments */
4132 tabini_dim1 = *ndimen;
4133 tabini_dim2 = *ncoefu;
4134 tabini_offset = tabini_dim1 * (tabini_dim2 + 1) + 1;
4135 tabini -= tabini_offset;
4136 tabres_dim1 = *ndimax;
4137 tabres_dim2 = *ncfumx;
4138 tabres_offset = tabres_dim1 * (tabres_dim2 + 1) + 1;
4139 tabres -= tabres_offset;
4140
4141 /* Function Body */
4142 if (*ndimax == *ndimen) {
4143 goto L1000;
4144 }
4145
4146 /* ----------------------- decompression NDIMAX<>NDIMEN -----------------
4147 */
4148
4149 for (k = *ncoefv; k >= 1; --k) {
4150 for (j = *ncoefu; j >= 1; --j) {
4151 for (i__ = *ndimen; i__ >= 1; --i__) {
4152 tabres[i__ + (j + k * tabres_dim2) * tabres_dim1] = tabini[
4153 i__ + (j + k * tabini_dim2) * tabini_dim1];
4154 /* L300: */
4155 }
4156 /* L200: */
4157 }
4158 /* L100: */
4159 }
4160 goto L9999;
4161
4162 /* ----------------------- decompression NDIMAX=NDIMEN ------------------
4163 */
4164
4165 L1000:
4166 if (*ncoefu == *ncfumx) {
4167 goto L2000;
4168 }
4169 ilong = (*ndimen << 3) * *ncoefu;
4170 for (k = *ncoefv; k >= 1; --k) {
4171 AdvApp2Var_SysBase::mcrfill_(&ilong,
4172 &tabini[(k * tabini_dim2 + 1) * tabini_dim1 + 1],
4173 &tabres[(k * tabres_dim2 + 1) * tabres_dim1 + 1]);
4174 /* L500: */
4175 }
4176 goto L9999;
4177
4178 /* ----------------- decompression NDIMAX=NDIMEN,NCOEFU=NCFUMX ----------
4179 */
4180
4181 L2000:
4182 ilong = (*ndimen << 3) * *ncoefu * *ncoefv;
4183 AdvApp2Var_SysBase::mcrfill_(&ilong,
4184 &tabini[tabini_offset],
4185 &tabres[tabres_offset]);
4186 goto L9999;
4187
4188 /* ---------------------------- The end ---------------------------------
4189 */
4190
4191 L9999:
4192 return 0;
4193 } /* mmfmca8_ */
4194
4195 //=======================================================================
4196 //function : AdvApp2Var_MathBase::mmfmca9_
4197 //purpose :
4198 //=======================================================================
mmfmca9_(integer * ndimax,integer * ncfumx,integer *,integer * ndimen,integer * ncoefu,integer * ncoefv,doublereal * tabini,doublereal * tabres)4199 int AdvApp2Var_MathBase::mmfmca9_(integer *ndimax,
4200 integer *ncfumx,
4201 integer *,//ncfvmx,
4202 integer *ndimen,
4203 integer *ncoefu,
4204 integer *ncoefv,
4205 doublereal *tabini,
4206 doublereal *tabres)
4207
4208 {
4209 /* System generated locals */
4210 integer tabini_dim1, tabini_dim2, tabini_offset, tabres_dim1, tabres_dim2,
4211 tabres_offset, i__1, i__2, i__3;
4212
4213 /* Local variables */
4214 integer i__, j, k, ilong;
4215
4216
4217
4218 /* **********************************************************************
4219 */
4220
4221 /* FUNCTION : */
4222 /* ---------- */
4223 /* Compression of a data table in a table */
4224 /* containing only the main data (the input table is not removed). */
4225
4226 /* KEYWORDS: */
4227 /* ----------- */
4228 /* ALL, MATH_ACCES:: CARREAU&, COMPRESSION, &CARREAU */
4229
4230 /* INPUT ARGUMENTS : */
4231 /* ------------------ */
4232 /* NDIMAX: Max dimension of the space. */
4233 /* NCFUMX: Max degree +1 of the table by u. */
4234 /* NCFVMX: Max degree +1 of the table by v. */
4235 /* NDIMEN: Dimension of the workspace. */
4236 /* NCOEFU: Degree +1 of the table by u. */
4237 /* NCOEFV: Degree +1 of the table by v. */
4238 /* TABINI: The table to compress. */
4239
4240 /* OUTPUT ARGUMENTS : */
4241 /* ------------------- */
4242 /* TABRES: The compressed table. */
4243
4244 /* COMMONS USED : */
4245 /* ---------------- */
4246
4247 /* REFERENCES CALLED : */
4248 /* ----------------------- */
4249
4250 /* DESCRIPTION/NOTES/LIMITATIONS : */
4251 /* ----------------------------------- */
4252 /* The following call : */
4253
4254 /* CALL MMFMCA9(NDIMAX,NCFUMX,NCFVMX,NDIMEN,NCOEFU,NCOEFV,TABINI,TABINI)
4255 */
4256
4257 /* where TABINI is input/output argument, is possible provided */
4258 /* that the caller has checked that : */
4259
4260 /* NDIMAX > NDIMEN, */
4261 /* or NDIMAX = NDIMEN and NCFUMX > NCOEFU */
4262 /* or NDIMAX = NDIMEN, NCFUMX = NCOEFU and NCFVMX > NCOEFV */
4263
4264 /* These conditions are not tested in the program. */
4265
4266 /* > */
4267 /* **********************************************************************
4268 */
4269
4270
4271 /* Parameter adjustments */
4272 tabini_dim1 = *ndimax;
4273 tabini_dim2 = *ncfumx;
4274 tabini_offset = tabini_dim1 * (tabini_dim2 + 1) + 1;
4275 tabini -= tabini_offset;
4276 tabres_dim1 = *ndimen;
4277 tabres_dim2 = *ncoefu;
4278 tabres_offset = tabres_dim1 * (tabres_dim2 + 1) + 1;
4279 tabres -= tabres_offset;
4280
4281 /* Function Body */
4282 if (*ndimen == *ndimax) {
4283 goto L1000;
4284 }
4285
4286 /* ----------------------- Compression NDIMEN<>NDIMAX -------------------
4287 */
4288
4289 i__1 = *ncoefv;
4290 for (k = 1; k <= i__1; ++k) {
4291 i__2 = *ncoefu;
4292 for (j = 1; j <= i__2; ++j) {
4293 i__3 = *ndimen;
4294 for (i__ = 1; i__ <= i__3; ++i__) {
4295 tabres[i__ + (j + k * tabres_dim2) * tabres_dim1] = tabini[
4296 i__ + (j + k * tabini_dim2) * tabini_dim1];
4297 /* L300: */
4298 }
4299 /* L200: */
4300 }
4301 /* L100: */
4302 }
4303 goto L9999;
4304
4305 /* ----------------------- Compression NDIMEN=NDIMAX --------------------
4306 */
4307
4308 L1000:
4309 if (*ncoefu == *ncfumx) {
4310 goto L2000;
4311 }
4312 ilong = (*ndimen << 3) * *ncoefu;
4313 i__1 = *ncoefv;
4314 for (k = 1; k <= i__1; ++k) {
4315 AdvApp2Var_SysBase::mcrfill_(&ilong,
4316 &tabini[(k * tabini_dim2 + 1) * tabini_dim1 + 1],
4317 &tabres[(k * tabres_dim2 + 1) * tabres_dim1 + 1]);
4318 /* L500: */
4319 }
4320 goto L9999;
4321
4322 /* ----------------- Compression NDIMEN=NDIMAX,NCOEFU=NCFUMX ------------
4323 */
4324
4325 L2000:
4326 ilong = (*ndimen << 3) * *ncoefu * *ncoefv;
4327 AdvApp2Var_SysBase::mcrfill_(&ilong,
4328 &tabini[tabini_offset],
4329 &tabres[tabres_offset]);
4330 goto L9999;
4331
4332 /* ---------------------------- The end ---------------------------------
4333 */
4334
4335 L9999:
4336 return 0;
4337 } /* mmfmca9_ */
4338
4339 //=======================================================================
4340 //function : AdvApp2Var_MathBase::mmfmcar_
4341 //purpose :
4342 //=======================================================================
mmfmcar_(integer * ndimen,integer * ncofmx,integer * ncoefu,integer * ncoefv,doublereal * patold,doublereal * upara1,doublereal * upara2,doublereal * vpara1,doublereal * vpara2,doublereal * patnew,integer * iercod)4343 int AdvApp2Var_MathBase::mmfmcar_(integer *ndimen,
4344 integer *ncofmx,
4345 integer *ncoefu,
4346 integer *ncoefv,
4347 doublereal *patold,
4348 doublereal *upara1,
4349 doublereal *upara2,
4350 doublereal *vpara1,
4351 doublereal *vpara2,
4352 doublereal *patnew,
4353 integer *iercod)
4354
4355 {
4356 integer c__8 = 8;
4357 /* System generated locals */
4358 integer patold_dim1, patold_dim2, patnew_dim1, patnew_dim2,
4359 i__1, patold_offset,patnew_offset;
4360
4361 /* Local variables */
4362 doublereal* tbaux = 0;
4363 integer ksize, numax, kk;
4364 intptr_t iofst;
4365 integer ibb, ier;
4366
4367 /* ***********************************************************************
4368 */
4369
4370 /* FUNCTION : */
4371 /* ---------- */
4372 /* LIMITATION OF A SQUARE DEFINED ON (0,1)*(0,1) BETWEEN ISOS */
4373 /* UPARA1 AND UPARA2 (BY U) AND VPARA1 AND VPARA2 BY V. */
4374
4375 /* KEYWORDS : */
4376 /* ----------- */
4377 /* LIMITATION , SQUARE , PARAMETER */
4378
4379 /* INPUT ARGUMENTS : */
4380 /* ------------------ */
4381 /* NCOFMX: MAX NUMBER OF COEFF OF THE SQUARE BY U */
4382 /* NCOEFU: NUMBER OF COEFF OF THE SQUARE BY U */
4383 /* NCOEFV: NUMBER OF COEFF OF THE SQUARE BY V */
4384 /* PATOLD : THE SQUARE IS LIMITED BY UPARA1,UPARA2 AND VPARA1,VPARA2
4385 .*/
4386 /* UPARA1 : LOWER LIMIT OF U */
4387 /* UPARA2 : UPPER LIMIT OF U */
4388 /* VPARA1 : LOWER LIMIT OF V */
4389 /* VPARA2 : UPPER LIMIT OF V */
4390
4391 /* OUTPUT ARGUMENTS : */
4392 /* ------------------- */
4393 /* PATNEW : RELIMITED SQUARE, DEFINED ON (0,1)**2 */
4394 /* IERCOD : =10 COEFF NB TOO GREAT OR NULL */
4395 /* =13 PB IN THE DYNAMIC ALLOCATION */
4396 /* = 0 OK. */
4397
4398 /* COMMONS USED : */
4399 /* ---------------- */
4400
4401 /* DESCRIPTION/NOTES/LIMITATIONS : */
4402 /* ----------------------------------- */
4403 /* ---> The following call : */
4404 /* CALL MMFMCAR(NCOFMX,NCOEFU,NCOEFV,PATOLD,UPARA1,UPARA2,VPARA1,VPARA2
4405 */
4406 /* ,PATOLD), */
4407 /* where PATOLD is input/output argument is absolutely legal. */
4408
4409 /* ---> The max number of coeff by u and v of PATOLD is 61 */
4410
4411 /* ---> If NCOEFU < NCOFMX, the data is compressed by MMFMCA9 before */
4412 /* limitation by v to get time during the execution */
4413 /* of MMARC41 that follows (the square is processed as a curve of
4414 */
4415 /* dimension NDIMEN*NCOEFU possessing NCOEFV coefficients). */
4416 /* > */
4417 /* ***********************************************************************
4418 */
4419
4420 /* Name of the routine */
4421
4422
4423 /* Parameter adjustments */
4424 patnew_dim1 = *ndimen;
4425 patnew_dim2 = *ncofmx;
4426 patnew_offset = patnew_dim1 * (patnew_dim2 + 1) + 1;
4427 patnew -= patnew_offset;
4428 patold_dim1 = *ndimen;
4429 patold_dim2 = *ncofmx;
4430 patold_offset = patold_dim1 * (patold_dim2 + 1) + 1;
4431 patold -= patold_offset;
4432
4433 /* Function Body */
4434 ibb = AdvApp2Var_SysBase::mnfndeb_();
4435 if (ibb >= 2) {
4436 AdvApp2Var_SysBase::mgenmsg_("MMFMCAR", 7L);
4437 }
4438 *iercod = 0;
4439 iofst = 0;
4440 AdvApp2Var_SysBase anAdvApp2Var_SysBase;
4441
4442 /* **********************************************************************
4443 */
4444 /* TEST OF COEFFICIENT NUMBERS */
4445 /* **********************************************************************
4446 */
4447
4448 if (*ncofmx < *ncoefu) {
4449 *iercod = 10;
4450 goto L9999;
4451 }
4452 if (*ncoefu < 1 || *ncoefu > 61 || *ncoefv < 1 || *ncoefv > 61) {
4453 *iercod = 10;
4454 goto L9999;
4455 }
4456
4457 /* **********************************************************************
4458 */
4459 /* CASE WHEN UPARA1=VPARA1=0 AND UPARA2=VPARA2=1 */
4460 /* **********************************************************************
4461 */
4462
4463 if (*upara1 == 0. && *upara2 == 1. && *vpara1 == 0. && *vpara2 == 1.) {
4464 ksize = (*ndimen << 3) * *ncofmx * *ncoefv;
4465 AdvApp2Var_SysBase::mcrfill_(&ksize,
4466 &patold[patold_offset],
4467 &patnew[patnew_offset]);
4468 goto L9999;
4469 }
4470
4471 /* **********************************************************************
4472 */
4473 /* LIMITATION BY U */
4474 /* **********************************************************************
4475 */
4476
4477 if (*upara1 == 0. && *upara2 == 1.) {
4478 goto L2000;
4479 }
4480 i__1 = *ncoefv;
4481 for (kk = 1; kk <= i__1; ++kk) {
4482 mmarc41_(ndimen, ndimen, ncoefu, &patold[(kk * patold_dim2 + 1) *
4483 patold_dim1 + 1], upara1, upara2, &patnew[(kk * patnew_dim2 +
4484 1) * patnew_dim1 + 1], iercod);
4485 /* L100: */
4486 }
4487
4488 /* **********************************************************************
4489 */
4490 /* LIMITATION BY V */
4491 /* **********************************************************************
4492 */
4493
4494 L2000:
4495 if (*vpara1 == 0. && *vpara2 == 1.) {
4496 goto L9999;
4497 }
4498
4499 /* ----------- LIMITATION BY V (WITH COMPRESSION I.E. NCOEFU<NCOFMX) ----
4500 */
4501
4502 numax = *ndimen * *ncoefu;
4503 if (*ncofmx != *ncoefu) {
4504 /* ------------------------- Dynamic allocation -------------------
4505 ---- */
4506 ksize = *ndimen * *ncoefu * *ncoefv;
4507 anAdvApp2Var_SysBase.mcrrqst_(&c__8, &ksize, tbaux, &iofst, &ier);
4508 if (ier > 0) {
4509 *iercod = 13;
4510 goto L9900;
4511 }
4512 /* --------------- Compression by (NDIMEN,NCOEFU,NCOEFV) ------------
4513 ---- */
4514 if (*upara1 == 0. && *upara2 == 1.) {
4515 AdvApp2Var_MathBase::mmfmca9_(ndimen,
4516 ncofmx,
4517 ncoefv,
4518 ndimen,
4519 ncoefu,
4520 ncoefv,
4521 &patold[patold_offset],
4522 &tbaux[iofst]);
4523 } else {
4524 AdvApp2Var_MathBase::mmfmca9_(ndimen,
4525 ncofmx,
4526 ncoefv,
4527 ndimen,
4528 ncoefu,
4529 ncoefv,
4530 &patnew[patnew_offset],
4531 &tbaux[iofst]);
4532 }
4533 /* ------------------------- Limitation by v ------------------------
4534 ---- */
4535 mmarc41_(&numax, &numax, ncoefv, &tbaux[iofst], vpara1, vpara2, &
4536 tbaux[iofst], iercod);
4537 /* --------------------- Expansion of TBAUX into PATNEW -------------
4538 --- */
4539 AdvApp2Var_MathBase::mmfmca8_(ndimen, ncoefu, ncoefv, ndimen, ncofmx, ncoefv, &tbaux[iofst]
4540 , &patnew[patnew_offset]);
4541 goto L9900;
4542
4543 /* -------- LIMITATION BY V (WITHOUT COMPRESSION I.E. NCOEFU=NCOFMX) ---
4544 ---- */
4545
4546 } else {
4547 if (*upara1 == 0. && *upara2 == 1.) {
4548 mmarc41_(&numax, &numax, ncoefv, &patold[patold_offset], vpara1,
4549 vpara2, &patnew[patnew_offset], iercod);
4550 } else {
4551 mmarc41_(&numax, &numax, ncoefv, &patnew[patnew_offset], vpara1,
4552 vpara2, &patnew[patnew_offset], iercod);
4553 }
4554 goto L9999;
4555 }
4556
4557 /* **********************************************************************
4558 */
4559 /* DESALLOCATION */
4560 /* **********************************************************************
4561 */
4562
4563 L9900:
4564 if (iofst != 0) {
4565 anAdvApp2Var_SysBase.mcrdelt_(&c__8, &ksize, tbaux, &iofst, &ier);
4566 }
4567 if (ier > 0) {
4568 *iercod = 13;
4569 }
4570
4571 /* ------------------------------ The end -------------------------------
4572 */
4573
4574 L9999:
4575 if (*iercod > 0) {
4576 AdvApp2Var_SysBase::maermsg_("MMFMCAR", iercod, 7L);
4577 }
4578 if (ibb >= 2) {
4579 AdvApp2Var_SysBase::mgsomsg_("MMFMCAR", 7L);
4580 }
4581 return 0;
4582 } /* mmfmcar_ */
4583
4584
4585 //=======================================================================
4586 //function : AdvApp2Var_MathBase::mmfmcb5_
4587 //purpose :
4588 //=======================================================================
mmfmcb5_(integer * isenmsc,integer * ndimax,integer * ncf1mx,doublereal * courb1,integer * ncoeff,integer * ncf2mx,integer * ndimen,doublereal * courb2,integer * iercod)4589 int AdvApp2Var_MathBase::mmfmcb5_(integer *isenmsc,
4590 integer *ndimax,
4591 integer *ncf1mx,
4592 doublereal *courb1,
4593 integer *ncoeff,
4594 integer *ncf2mx,
4595 integer *ndimen,
4596 doublereal *courb2,
4597 integer *iercod)
4598
4599 {
4600 /* System generated locals */
4601 integer courb1_dim1, courb1_offset, courb2_dim1, courb2_offset, i__1,
4602 i__2;
4603
4604 /* Local variables */
4605 integer i__, nboct, nd;
4606
4607
4608 /* **********************************************************************
4609 */
4610
4611 /* FUNCTION : */
4612 /* ---------- */
4613 /* Reformating (and eventual compression/decompression) of curve */
4614 /* (ndim,.) by (.,ndim) and vice versa. */
4615
4616 /* KEYWORDS : */
4617 /* ----------- */
4618 /* ALL , MATH_ACCES :: */
4619 /* COURBE&, REORGANISATION,COMPRESSION,INVERSION , &COURBE */
4620
4621 /* INPUT ARGUMENTS : */
4622 /* -------------------- */
4623 /* ISENMSC : required direction of the transfer : */
4624 /* 1 : passage of (NDIMEN,.) ---> (.,NDIMEN) direction to AB
4625 */
4626 /* -1 : passage of (.,NDIMEN) ---> (NDIMEN,.) direction to TS,T
4627 V*/
4628 /* NDIMAX : format / dimension */
4629 /* NCF1MX : format by t of COURB1 */
4630 /* if ISENMSC= 1 : COURB1: The curve to be processed (NDIMAX,.) */
4631 /* NCOEFF : number of coeff of the curve */
4632 /* NCF2MX : format by t of COURB2 */
4633 /* NDIMEN : dimension of the curve and format of COURB2 */
4634 /* if ISENMSC=-1 : COURB2: The curve to be processed (.,NDIMEN) */
4635
4636 /* OUTPUT ARGUMENTS : */
4637 /* --------------------- */
4638 /* if ISENMSC= 1 : COURB2: The resulting curve (.,NDIMEN) */
4639 /* if ISENMSC=-1 : COURB1: The resulting curve (NDIMAX,.) */
4640
4641 /* COMMONS USED : */
4642 /* ------------------ */
4643
4644 /* REFERENCES CALLED : */
4645 /* --------------------- */
4646
4647 /* DESCRIPTION/NOTES/LIMITATIONS : */
4648 /* ----------------------------------- */
4649 /* allow to process the usual transfers as follows : */
4650 /* | ---- ISENMSC = 1 ---- | | ---- ISENMSC =-1 ----- | */
4651 /* TS (3,21) --> (21,3) AB ; AB (21,3) --> (3,21) TS */
4652 /* TS (3,21) --> (NU,3) AB ; AB (NU,3) --> (3,21) TS */
4653 /* (3,NU) --> (21,3) AB ; AB (21,3) --> (3,NU) */
4654 /* (3,NU) --> (NU,3) AB ; AB (NU,3) --> (3,NU) */
4655 /* > */
4656 /* ***********************************************************************
4657 */
4658
4659
4660 /* Parameter adjustments */
4661 courb1_dim1 = *ndimax;
4662 courb1_offset = courb1_dim1 + 1;
4663 courb1 -= courb1_offset;
4664 courb2_dim1 = *ncf2mx;
4665 courb2_offset = courb2_dim1 + 1;
4666 courb2 -= courb2_offset;
4667
4668 /* Function Body */
4669 if (*ndimen > *ndimax || *ncoeff > *ncf1mx || *ncoeff > *ncf2mx) {
4670 goto L9119;
4671 }
4672
4673 if (*ndimen == 1 && *ncf1mx == *ncf2mx) {
4674 nboct = *ncf2mx << 3;
4675 if (*isenmsc == 1) {
4676 AdvApp2Var_SysBase::mcrfill_(&nboct,
4677 &courb1[courb1_offset],
4678 &courb2[courb2_offset]);
4679 }
4680 if (*isenmsc == -1) {
4681 AdvApp2Var_SysBase::mcrfill_(&nboct,
4682 &courb2[courb2_offset],
4683 &courb1[courb1_offset]);
4684 }
4685 *iercod = -3136;
4686 goto L9999;
4687 }
4688
4689 *iercod = 0;
4690 if (*isenmsc == 1) {
4691 i__1 = *ndimen;
4692 for (nd = 1; nd <= i__1; ++nd) {
4693 i__2 = *ncoeff;
4694 for (i__ = 1; i__ <= i__2; ++i__) {
4695 courb2[i__ + nd * courb2_dim1] = courb1[nd + i__ *
4696 courb1_dim1];
4697 /* L400: */
4698 }
4699 /* L500: */
4700 }
4701 } else if (*isenmsc == -1) {
4702 i__1 = *ndimen;
4703 for (nd = 1; nd <= i__1; ++nd) {
4704 i__2 = *ncoeff;
4705 for (i__ = 1; i__ <= i__2; ++i__) {
4706 courb1[nd + i__ * courb1_dim1] = courb2[i__ + nd *
4707 courb2_dim1];
4708 /* L1400: */
4709 }
4710 /* L1500: */
4711 }
4712 } else {
4713 *iercod = 3164;
4714 }
4715
4716 goto L9999;
4717
4718 /* ***********************************************************************
4719 */
4720
4721 L9119:
4722 *iercod = 3119;
4723
4724 L9999:
4725 if (*iercod != 0) {
4726 AdvApp2Var_SysBase::maermsg_("MMFMCB5", iercod, 7L);
4727 }
4728 return 0;
4729 } /* mmfmcb5_ */
4730
4731 //=======================================================================
4732 //function : AdvApp2Var_MathBase::mmfmtb1_
4733 //purpose :
4734 //=======================================================================
mmfmtb1_(integer * maxsz1,doublereal * table1,integer * isize1,integer * jsize1,integer * maxsz2,doublereal * table2,integer * isize2,integer * jsize2,integer * iercod)4735 int AdvApp2Var_MathBase::mmfmtb1_(integer *maxsz1,
4736 doublereal *table1,
4737 integer *isize1,
4738 integer *jsize1,
4739 integer *maxsz2,
4740 doublereal *table2,
4741 integer *isize2,
4742 integer *jsize2,
4743 integer *iercod)
4744 {
4745 integer c__8 = 8;
4746
4747 /* System generated locals */
4748 integer table1_dim1, table1_offset, table2_dim1, table2_offset, i__1,
4749 i__2;
4750
4751 /* Local variables */
4752 doublereal* work = 0;
4753 integer ilong, isize, ii, jj, ier = 0;
4754 intptr_t iofst = 0,iipt, jjpt;
4755
4756
4757 /************************************************************************
4758 *******/
4759
4760 /* FUNCTION : */
4761 /* ---------- */
4762 /* Inversion of elements of a rectangular table (T1(i,j) */
4763 /* loaded in T2(j,i)) */
4764
4765 /* KEYWORDS : */
4766 /* ----------- */
4767 /* ALL, MATH_ACCES :: TABLEAU&, INVERSION, &TABLEAU */
4768
4769 /* INPUT ARGUMENTS : */
4770 /* ------------------ */
4771 /* MAXSZ1: Max Nb of elements by the 1st dimension of TABLE1. */
4772 /* TABLE1: Table of reals by two dimensions. */
4773 /* ISIZE1: Nb of useful elements of TABLE1 on the 1st dimension */
4774 /* JSIZE1: Nb of useful elements of TABLE1 on the 2nd dimension */
4775 /* MAXSZ2: Nb max of elements by the 1st dimension of TABLE2. */
4776
4777 /* OUTPUT ARGUMENTS : */
4778 /* ------------------- */
4779 /* TABLE2: Table of reals by two dimensions, containing the transposition */
4780 /* of the rectangular table TABLE1. */
4781 /* ISIZE2: Nb of useful elements of TABLE2 on the 1st dimension */
4782 /* JSIZE2: Nb of useful elements of TABLE2 on the 2nd dimension */
4783 /* IERCOD: Erroe coder. */
4784 /* = 0, ok. */
4785 /* = 1, error in the dimension of tables */
4786 /* ether MAXSZ1 < ISIZE1 (table TABLE1 too small). */
4787 /* or MAXSZ2 < JSIZE1 (table TABLE2 too small). */
4788
4789 /* COMMONS USED : */
4790 /* ---------------- */
4791
4792 /* REFERENCES CALLED : */
4793 /* ---------------------- */
4794
4795 /* DESCRIPTION/NOTES/LIMITATIONS : */
4796 /* ----------------------------------- */
4797 /* It is possible to use TABLE1 as input and output table i.e. */
4798 /* call: */
4799 /* CALL MMFMTB1(MAXSZ1,TABLE1,ISIZE1,JSIZE1,MAXSZ2,TABLE1 */
4800 /* ,ISIZE2,JSIZE2,IERCOD) */
4801 /* is valuable. */
4802 /* > */
4803 /* **********************************************************************
4804 */
4805
4806
4807 /* Parameter adjustments */
4808 table1_dim1 = *maxsz1;
4809 table1_offset = table1_dim1 + 1;
4810 table1 -= table1_offset;
4811 table2_dim1 = *maxsz2;
4812 table2_offset = table2_dim1 + 1;
4813 table2 -= table2_offset;
4814 AdvApp2Var_SysBase anAdvApp2Var_SysBase;
4815
4816 /* Function Body */
4817 *iercod = 0;
4818 if (*isize1 > *maxsz1 || *jsize1 > *maxsz2) {
4819 goto L9100;
4820 }
4821
4822 iofst = 0;
4823 isize = *maxsz2 * *isize1;
4824 anAdvApp2Var_SysBase.mcrrqst_(&c__8, &isize, work, &iofst, &ier);
4825 if (ier > 0) {
4826 goto L9200;
4827 }
4828
4829 /* DO NOT BE AFRAID OF CRUSHING. */
4830
4831 i__1 = *isize1;
4832 for (ii = 1; ii <= i__1; ++ii) {
4833 iipt = (ii - 1) * *maxsz2 + iofst;
4834 i__2 = *jsize1;
4835 for (jj = 1; jj <= i__2; ++jj) {
4836 jjpt = iipt + (jj - 1);
4837 work[jjpt] = table1[ii + jj * table1_dim1];
4838 /* L200: */
4839 }
4840 /* L100: */
4841 }
4842 ilong = isize << 3;
4843 AdvApp2Var_SysBase::mcrfill_(&ilong,
4844 &work[iofst],
4845 &table2[table2_offset]);
4846
4847 /* -------------- The number of elements of TABLE2 is returned ------------
4848 */
4849
4850 ii = *isize1;
4851 *isize2 = *jsize1;
4852 *jsize2 = ii;
4853
4854 goto L9999;
4855
4856 /* ------------------------------- THE END ------------------------------
4857 */
4858 /* --> Invalid input. */
4859 L9100:
4860 *iercod = 1;
4861 goto L9999;
4862 /* --> Pb of allocation. */
4863 L9200:
4864 *iercod = 2;
4865 goto L9999;
4866
4867 L9999:
4868 if (iofst != 0) {
4869 anAdvApp2Var_SysBase.mcrdelt_(&c__8, &isize, work, &iofst, &ier);
4870 }
4871 if (ier > 0) {
4872 *iercod = 2;
4873 }
4874 return 0;
4875 } /* mmfmtb1_ */
4876
4877 //=======================================================================
4878 //function : AdvApp2Var_MathBase::mmgaus1_
4879 //purpose :
4880 //=======================================================================
mmgaus1_(integer * ndimf,int (* bfunx)(integer * ninteg,doublereal * parame,doublereal * vfunj1,integer * iercod),integer * k,doublereal * xd,doublereal * xf,doublereal * saux1,doublereal * saux2,doublereal * somme,integer * niter,integer * iercod)4881 int AdvApp2Var_MathBase::mmgaus1_(integer *ndimf,
4882 int (*bfunx) (
4883 integer *ninteg,
4884 doublereal *parame,
4885 doublereal *vfunj1,
4886 integer *iercod
4887 ),
4888
4889 integer *k,
4890 doublereal *xd,
4891 doublereal *xf,
4892 doublereal *saux1,
4893 doublereal *saux2,
4894 doublereal *somme,
4895 integer *niter,
4896 integer *iercod)
4897 {
4898 /* System generated locals */
4899 integer i__1, i__2;
4900
4901 /* Local variables */
4902 integer ndeg;
4903 doublereal h__[20];
4904 integer j;
4905 doublereal t, u[20], x;
4906 integer idimf;
4907 doublereal c1x, c2x;
4908 /* **********************************************************************
4909 */
4910
4911 /* FUNCTION : */
4912 /* -------- */
4913
4914 /* Calculate the integral of function BFUNX passed in parameter */
4915 /* between limits XD and XF . */
4916 /* The function should be calculated for any value */
4917 /* of the variable in the given interval.. */
4918 /* The method GAUSS-LEGENDRE is used. */
4919 /* For explications refer to the book : */
4920 /* Complements de mathematiques a l'usage des Ingenieurs de */
4921 /* l'electrotechnique et des telecommunications. */
4922 /* Par Andre ANGOT - Collection technique et scientifique du CNET
4923 */
4924 /* page 772 .... */
4925 /* The degree of LEGENDRE polynoms used is passed in parameter.
4926 */
4927 /* KEYWORDS : */
4928 /* --------- */
4929 /* INTEGRATION,LEGENDRE,GAUSS */
4930
4931 /* INPUT ARGUMENTS : */
4932 /* ------------------ */
4933
4934 /* NDIMF : Dimension of the function */
4935 /* BFUNX : Function to integrate passed as argument */
4936 /* Should be declared as EXTERNAL in the call routine. */
4937 /* SUBROUTINE BFUNX(NDIMF,X,VAL,IER) */
4938 /* REAL *8 X,VAL */
4939 /* K : Parameter determining the degree of the LEGENDRE polynom that
4940 */
4941 /* can take a value between 0 and 10. */
4942 /* The degree of the polynom is equal to 4 k, that is 4, 8,
4943 */
4944 /* 12, 16, 20, 24, 28, 32, 36 and 40. */
4945 /* If K is not correct, the degree is set to 40 directly.
4946 */
4947 /* XD : Lower limit of the interval of integration. */
4948 /* XF : Upper limit of the interval of integration. */
4949 /* SAUX1 : Auxiliary table */
4950 /* SAUX2 : Auxiliary table */
4951
4952 /* OUTPUT ARGUMENTS : */
4953 /* ------------------- */
4954
4955 /* SOMME : Value of the integral */
4956 /* NITER : Number of iterations to be carried out. */
4957 /* It is equal to the degree of the polynom. */
4958
4959 /* IER : Error code : */
4960 /* < 0 ==> Attention - Warning */
4961 /* = 0 ==> Everything is OK */
4962 /* > 0 ==> Critical error - Apply special processing */
4963 /* ==> Error in the calculation of BFUNX (return code */
4964 /* of this routine */
4965
4966 /* If error => SUM = 0 */
4967
4968 /* COMMONS USED : */
4969 /* ----------------- */
4970
4971
4972
4973 /* REFERENCES CALLED : */
4974 /* ---------------------- */
4975
4976 /* Type Name */
4977 /* @ BFUNX MVGAUS0 */
4978
4979 /* DESCRIPTION/NOTES/LIMITATIONS : */
4980 /* --------------------------------- */
4981
4982 /* See the explanations detailed in the listing */
4983 /* Use of the GAUSS method (orthogonal polynoms) */
4984 /* The symmetry of roots of these polynomes is used */
4985 /* Depending on K, the degree of the interpolated polynom grows.
4986 */
4987 /* If you wish to calculate the integral with a given precision, */
4988 /* loop on k varying from 1 to 10 and test the difference of 2
4989 */
4990 /* consecutive iterations. Stop the loop if this difference is less that */
4991 /* an epsilon value set to 10E-6 for example. */
4992 /* If S1 and S2 are 2 successive iterations, test following this example :
4993 */
4994
4995 /* AF=DABS(S1-S2) */
4996 /* AS=DABS(S2) */
4997 /* If AS < 1 test if FS < eps otherwise test if AF/AS < eps
4998 */
4999 /* -- ----- ----- */
5000 /* > */
5001 /************************************************************************
5002 ******/
5003 /* DECLARATIONS */
5004 /************************************************************************
5005 ******/
5006
5007
5008
5009 /* ****** General Initialization */
5010
5011 /* Parameter adjustments */
5012 --somme;
5013 --saux2;
5014 --saux1;
5015
5016 /* Function Body */
5017 AdvApp2Var_SysBase::mvriraz_(ndimf,
5018 &somme[1]);
5019 *iercod = 0;
5020
5021 /* ****** Loading of coefficients U and H ** */
5022 /* -------------------------------------------- */
5023
5024 mvgaus0_(k, u, h__, &ndeg, iercod);
5025 if (*iercod > 0) {
5026 goto L9999;
5027 }
5028
5029 /* ****** C1X => Medium interval point [XD,XF] */
5030 /* ****** C2X => 1/2 amplitude interval [XD,XF] */
5031
5032 c1x = (*xf + *xd) * .5;
5033 c2x = (*xf - *xd) * .5;
5034
5035 /* ---------------------------------------- */
5036 /* ****** Integration for degree NDEG ** */
5037 /* ---------------------------------------- */
5038
5039 i__1 = ndeg;
5040 for (j = 1; j <= i__1; ++j) {
5041 t = c2x * u[j - 1];
5042
5043 x = c1x + t;
5044 (*bfunx)(ndimf, &x, &saux1[1], iercod);
5045 if (*iercod != 0) {
5046 goto L9999;
5047 }
5048
5049 x = c1x - t;
5050 (*bfunx)(ndimf, &x, &saux2[1], iercod);
5051 if (*iercod != 0) {
5052 goto L9999;
5053 }
5054
5055 i__2 = *ndimf;
5056 for (idimf = 1; idimf <= i__2; ++idimf) {
5057 somme[idimf] += h__[j - 1] * (saux1[idimf] + saux2[idimf]);
5058 }
5059
5060 }
5061
5062 *niter = ndeg << 1;
5063 i__1 = *ndimf;
5064 for (idimf = 1; idimf <= i__1; ++idimf) {
5065 somme[idimf] *= c2x;
5066 }
5067
5068 /* ****** End of sub-program ** */
5069
5070 L9999:
5071
5072 return 0 ;
5073 } /* mmgaus1_ */
5074 //=======================================================================
5075 //function : mmherm0_
5076 //purpose :
5077 //=======================================================================
mmherm0_(doublereal * debfin,integer * iercod)5078 int mmherm0_(doublereal *debfin,
5079 integer *iercod)
5080 {
5081 integer c__576 = 576;
5082 integer c__6 = 6;
5083
5084
5085 /* System generated locals */
5086 integer i__1, i__2;
5087 doublereal d__1;
5088
5089 /* Local variables */
5090 doublereal amat[36] /* was [6][6] */;
5091 integer iord[2];
5092 doublereal prod;
5093 integer iord1, iord2;
5094 doublereal miden[36] /* was [6][6] */;
5095 integer ncmat;
5096 doublereal epspi, d1, d2;
5097 integer ii, jj, pp, ncf;
5098 doublereal cof[6];
5099 integer iof[2], ier;
5100 doublereal mat[36] /* was [6][6] */;
5101 integer cot;
5102 doublereal abid[72] /* was [12][6] */;
5103 /* ***********************************************************************
5104 */
5105
5106 /* FUNCTION : */
5107 /* ---------- */
5108 /* INIT OF COEFFS. OF POLYNOMS OF HERMIT INTERPOLATION */
5109
5110 /* KEYWORDS : */
5111 /* ----------- */
5112 /* MATH_ACCES :: HERMITE */
5113
5114 /* INPUT ARGUMENTS */
5115 /* -------------------- */
5116 /* DEBFIN : PARAMETERS DEFINING THE CONSTRAINTS */
5117 /* DEBFIN(1) : FIRST PARAMETER */
5118 /* DEBFIN(2) : SECOND PARAMETER */
5119
5120 /* ONE SHOULD HAVE: */
5121 /* ABS (DEBFIN(I)) < 100 */
5122 /* and */
5123 /* (ABS(DEBFIN(1)+ABS(DEBFIN(2))) > 1/100 */
5124 /* (for overflows) */
5125
5126 /* ABS(DEBFIN(2)-DEBFIN(1)) / (ABS(DEBFIN(1)+ABS(DEBFIN(2))) > 1/100
5127 */
5128 /* (for the conditioning) */
5129
5130
5131 /* OUTPUT ARGUMENTS : */
5132 /* --------------------- */
5133
5134 /* IERCOD : Error code : 0 : O.K. */
5135 /* 1 : value of DEBFIN */
5136 /* are unreasonable */
5137 /* -1 : init was already done */
5138 /* (OK but no processing) */
5139
5140 /* COMMONS USED : */
5141 /* ------------------ */
5142
5143 /* REFERENCES CALLED : */
5144 /* ---------------------- */
5145 /* Type Name */
5146
5147 /* DESCRIPTION/NOTES/LIMITATIONS : */
5148 /* ----------------------------------- */
5149
5150 /* This program initializes the coefficients of Hermit polynoms */
5151 /* that are read later by MMHERM1 */
5152 /* ***********************************************************************
5153 */
5154
5155
5156
5157 /* **********************************************************************
5158 */
5159
5160 /* FUNCTION : */
5161 /* ---------- */
5162 /* Used to STORE coefficients of Hermit interpolation polynoms */
5163
5164 /* KEYWORDS : */
5165 /* ----------- */
5166 /* HERMITE */
5167
5168 /* DEMSCRIPTION/NOTES/LIMITATIONS : */
5169 /* ----------------------------------- */
5170
5171 /* The coefficients of hermit polynoms are calculated by */
5172 /* the routine MMHERM0 and read by the routine MMHERM1 */
5173 /* > */
5174 /* **********************************************************************
5175 */
5176
5177
5178
5179
5180
5181 /* NBCOEF is the size of CMHERM (see below) */
5182 /* ***********************************************************************
5183 */
5184
5185
5186
5187
5188
5189
5190
5191 /* ***********************************************************************
5192 */
5193 /* Data checking */
5194 /* ***********************************************************************
5195 */
5196
5197
5198 /* Parameter adjustments */
5199 --debfin;
5200
5201 /* Function Body */
5202 d1 = advapp_abs(debfin[1]);
5203 if (d1 > (float)100.) {
5204 goto L9101;
5205 }
5206
5207 d2 = advapp_abs(debfin[2]);
5208 if (d2 > (float)100.) {
5209 goto L9101;
5210 }
5211
5212 d2 = d1 + d2;
5213 if (d2 < (float).01) {
5214 goto L9101;
5215 }
5216
5217 d1 = (d__1 = debfin[2] - debfin[1], advapp_abs(d__1));
5218 if (d1 / d2 < (float).01) {
5219 goto L9101;
5220 }
5221
5222
5223 /* ***********************************************************************
5224 */
5225 /* Initialization */
5226 /* ***********************************************************************
5227 */
5228
5229 *iercod = 0;
5230
5231 epspi = 1e-10;
5232
5233
5234 /* ***********************************************************************
5235 */
5236
5237 /* IS IT ALREADY INITIALIZED ? */
5238
5239 d1 = advapp_abs(debfin[1]) + advapp_abs(debfin[2]);
5240 d1 *= 16111959;
5241
5242 if (debfin[1] != mmcmher_.tdebut) {
5243 goto L100;
5244 }
5245 if (debfin[2] != mmcmher_.tfinal) {
5246 goto L100;
5247 }
5248 if (d1 != mmcmher_.verifi) {
5249 goto L100;
5250 }
5251
5252
5253 goto L9001;
5254
5255
5256 /* ***********************************************************************
5257 */
5258 /* CALCULATION */
5259 /* ***********************************************************************
5260 */
5261
5262
5263 L100:
5264
5265 /* Init. matrix identity : */
5266
5267 ncmat = 36;
5268 AdvApp2Var_SysBase::mvriraz_(&ncmat,
5269 miden);
5270
5271 for (ii = 1; ii <= 6; ++ii) {
5272 miden[ii + ii * 6 - 7] = 1.;
5273 /* L110: */
5274 }
5275
5276
5277
5278 /* Init to 0 of table CMHERM */
5279
5280 AdvApp2Var_SysBase::mvriraz_(&c__576, mmcmher_.cmherm);
5281
5282 /* Calculation by solution of linear systems */
5283
5284 for (iord1 = -1; iord1 <= 2; ++iord1) {
5285 for (iord2 = -1; iord2 <= 2; ++iord2) {
5286
5287 iord[0] = iord1;
5288 iord[1] = iord2;
5289
5290
5291 iof[0] = 0;
5292 iof[1] = iord[0] + 1;
5293
5294
5295 ncf = iord[0] + iord[1] + 2;
5296
5297 /* Calculate matrix MAT to invert: */
5298
5299 for (cot = 1; cot <= 2; ++cot) {
5300
5301
5302 if (iord[cot - 1] > -1) {
5303 prod = 1.;
5304 i__1 = ncf;
5305 for (jj = 1; jj <= i__1; ++jj) {
5306 cof[jj - 1] = 1.;
5307 /* L200: */
5308 }
5309 }
5310
5311 i__1 = iord[cot - 1] + 1;
5312 for (pp = 1; pp <= i__1; ++pp) {
5313
5314 ii = pp + iof[cot - 1];
5315
5316 prod = 1.;
5317
5318 i__2 = pp - 1;
5319 for (jj = 1; jj <= i__2; ++jj) {
5320 mat[ii + jj * 6 - 7] = (float)0.;
5321 /* L300: */
5322 }
5323
5324 i__2 = ncf;
5325 for (jj = pp; jj <= i__2; ++jj) {
5326
5327 /* everything is done in these 3 lines
5328 */
5329
5330 mat[ii + jj * 6 - 7] = cof[jj - 1] * prod;
5331 cof[jj - 1] *= jj - pp;
5332 prod *= debfin[cot];
5333
5334 /* L400: */
5335 }
5336 /* L500: */
5337 }
5338
5339 /* L1000: */
5340 }
5341
5342 /* Inversion */
5343
5344 if (ncf >= 1) {
5345 AdvApp2Var_MathBase::mmmrslwd_(&c__6, &ncf, &ncf, mat, miden, &epspi, abid, amat, &
5346 ier);
5347 if (ier > 0) {
5348 goto L9101;
5349 }
5350 }
5351
5352 for (cot = 1; cot <= 2; ++cot) {
5353 i__1 = iord[cot - 1] + 1;
5354 for (pp = 1; pp <= i__1; ++pp) {
5355 i__2 = ncf;
5356 for (ii = 1; ii <= i__2; ++ii) {
5357 mmcmher_.cmherm[ii + (pp + (cot + ((iord1 + (iord2 <<
5358 2)) << 1)) * 3) * 6 + 155] = amat[ii + (pp +
5359 iof[cot - 1]) * 6 - 7];
5360 /* L1300: */
5361 }
5362 /* L1400: */
5363 }
5364 /* L1500: */
5365 }
5366
5367 /* L2000: */
5368 }
5369 /* L2010: */
5370 }
5371
5372 /* ***********************************************************************
5373 */
5374
5375 /* The initialized flag is located: */
5376
5377 mmcmher_.tdebut = debfin[1];
5378 mmcmher_.tfinal = debfin[2];
5379
5380 d1 = advapp_abs(debfin[1]) + advapp_abs(debfin[2]);
5381 mmcmher_.verifi = d1 * 16111959;
5382
5383
5384 /* ***********************************************************************
5385 */
5386
5387 goto L9999;
5388
5389 /* ***********************************************************************
5390 */
5391
5392 L9101:
5393 *iercod = 1;
5394 goto L9999;
5395
5396 L9001:
5397 *iercod = -1;
5398 goto L9999;
5399
5400 /* ***********************************************************************
5401 */
5402
5403 L9999:
5404
5405 AdvApp2Var_SysBase::maermsg_("MMHERM0", iercod, 7L);
5406
5407 /* ***********************************************************************
5408 */
5409 return 0 ;
5410 } /* mmherm0_ */
5411
5412 //=======================================================================
5413 //function : mmherm1_
5414 //purpose :
5415 //=======================================================================
mmherm1_(doublereal * debfin,integer * ordrmx,integer * iordre,doublereal * hermit,integer * iercod)5416 int mmherm1_(doublereal *debfin,
5417 integer *ordrmx,
5418 integer *iordre,
5419 doublereal *hermit,
5420 integer *iercod)
5421 {
5422 /* System generated locals */
5423 integer hermit_dim1, hermit_dim2, hermit_offset;
5424
5425 /* Local variables */
5426 integer nbval;
5427 doublereal d1;
5428 integer cot;
5429
5430 /* ***********************************************************************
5431 */
5432
5433 /* FUNCTION : */
5434 /* ---------- */
5435 /* reading of coeffs. of HERMIT interpolation polynoms */
5436
5437 /* KEYWORDS : */
5438 /* ----------- */
5439 /* MATH_ACCES :: HERMIT */
5440
5441 /* INPUT ARGUMENTS : */
5442 /* -------------------- */
5443 /* DEBFIN : PARAMETES DEFINING THE CONSTRAINTS */
5444 /* DEBFIN(1) : FIRST PARAMETER */
5445 /* DEBFIN(2) : SECOND PARAMETER */
5446
5447 /* Should be equal to the corresponding arguments during the */
5448 /* last call to MMHERM0 for the initialization of coeffs. */
5449
5450 /* ORDRMX : indicates the dimensioning of HERMIT: */
5451 /* there is no choice : ORDRMX should be equal to the value */
5452 /* of PARAMETER IORDMX of INCLUDE MMCMHER, or 2 for the moment */
5453
5454 /* IORDRE (2) : Orders of constraints in each corresponding parameter DEBFIN(I) */
5455 /* should be between -1 (no constraints) and ORDRMX. */
5456
5457
5458 /* OUTPUT ARGUMENTS : */
5459 /* --------------------- */
5460
5461 /* HERMIT : HERMIT(1:IORDRE(1)+IORDRE(2)+2, j, cote) are the */
5462 /* coefficients in the canonic base of Hermit polynom */
5463 /* corresponding to orders IORDRE with parameters DEBFIN for */
5464 /* the constraint of order j on DEBFIN(cote). j is between 0 and IORDRE(cote). */
5465
5466
5467 /* IERCOD : Error code : */
5468 /* -1: O.K but necessary to reinitialize the coefficients */
5469 /* (info for optimization) */
5470 /* 0 : O.K. */
5471 /* 1 : Error in MMHERM0 */
5472 /* 2 : arguments invalid */
5473
5474 /* COMMONS USED : */
5475 /* ------------------ */
5476
5477 /* REFERENCES CALLED : */
5478 /* ---------------------- */
5479 /* Type Name */
5480
5481 /* DESCRIPTION/NOTES/LIMITATIONS : */
5482 /* ----------------------------------- */
5483
5484 /* This program reads coefficients of Hermit polynoms */
5485 /* that were earlier initialized by MMHERM0 */
5486
5487 /* PMN : initialisation is no more done by the caller. */
5488
5489
5490 /* ***********************************************************************
5491 */
5492
5493
5494
5495 /* **********************************************************************
5496 */
5497
5498 /* FUNCTION : */
5499 /* ---------- */
5500 /* Serves to STORE the coefficients of Hermit interpolation polynoms */
5501
5502 /* KEYWORDS : */
5503 /* ----------- */
5504 /* HERMITE */
5505
5506 /* DEMSCRIPTION/NOTES/LIMITATIONS : */
5507 /* ----------------------------------- */
5508
5509 /* the coefficients of Hetmit polynoms are calculated by */
5510 /* routine MMHERM0 and read by routine MMHERM1 */
5511
5512 /* > */
5513 /* **********************************************************************
5514 */
5515
5516
5517
5518
5519
5520 /* NBCOEF is the size of CMHERM (see lower) */
5521
5522
5523
5524 /* ***********************************************************************
5525 */
5526
5527
5528
5529
5530
5531 /* ***********************************************************************
5532 */
5533 /* Initializations */
5534 /* ***********************************************************************
5535 */
5536
5537 /* Parameter adjustments */
5538 --debfin;
5539 hermit_dim1 = (*ordrmx << 1) + 2;
5540 hermit_dim2 = *ordrmx + 1;
5541 hermit_offset = hermit_dim1 * hermit_dim2 + 1;
5542 hermit -= hermit_offset;
5543 --iordre;
5544
5545 /* Function Body */
5546 *iercod = 0;
5547
5548
5549 /* ***********************************************************************
5550 */
5551 /* Data Checking */
5552 /* ***********************************************************************
5553 */
5554
5555
5556 if (*ordrmx != 2) {
5557 goto L9102;
5558 }
5559
5560 for (cot = 1; cot <= 2; ++cot) {
5561 if (iordre[cot] < -1) {
5562 goto L9102;
5563 }
5564 if (iordre[cot] > *ordrmx) {
5565 goto L9102;
5566 }
5567 /* L100: */
5568 }
5569
5570
5571 /* IS-IT CORRECTLY INITIALIZED ? */
5572
5573 d1 = advapp_abs(debfin[1]) + advapp_abs(debfin[2]);
5574 d1 *= 16111959;
5575
5576 /* OTHERWISE IT IS INITIALIZED */
5577
5578 if (debfin[1] != mmcmher_.tdebut || debfin[2] != mmcmher_.tfinal || d1
5579 != mmcmher_.verifi) {
5580 *iercod = -1;
5581 mmherm0_(&debfin[1], iercod);
5582 if (*iercod > 0) {
5583 goto L9101;
5584 }
5585 }
5586
5587
5588 /* ***********************************************************************
5589 */
5590 /* READING */
5591 /* ***********************************************************************
5592 */
5593
5594 nbval = 36;
5595
5596 AdvApp2Var_SysBase::msrfill_(&nbval, &mmcmher_.cmherm[((((iordre[1] + (iordre[2] << 2)) << 1)
5597 + 1) * 3 + 1) * 6 + 156], &hermit[hermit_offset]);
5598
5599 /* ***********************************************************************
5600 */
5601
5602 goto L9999;
5603
5604 /* ***********************************************************************
5605 */
5606
5607 L9101:
5608 *iercod = 1;
5609 goto L9999;
5610
5611 L9102:
5612 *iercod = 2;
5613 goto L9999;
5614
5615 /* ***********************************************************************
5616 */
5617
5618 L9999:
5619
5620 AdvApp2Var_SysBase::maermsg_("MMHERM1", iercod, 7L);
5621
5622 /* ***********************************************************************
5623 */
5624 return 0 ;
5625 } /* mmherm1_ */
5626
5627 //=======================================================================
5628 //function : AdvApp2Var_MathBase::mmhjcan_
5629 //purpose :
5630 //=======================================================================
mmhjcan_(integer * ndimen,integer * ncourb,integer * ncftab,integer * orcont,integer * ncflim,doublereal * tcbold,doublereal * tdecop,doublereal * tcbnew,integer * iercod)5631 int AdvApp2Var_MathBase::mmhjcan_(integer *ndimen,
5632 integer *ncourb,
5633 integer *ncftab,
5634 integer *orcont,
5635 integer *ncflim,
5636 doublereal *tcbold,
5637 doublereal *tdecop,
5638 doublereal *tcbnew,
5639 integer *iercod)
5640
5641 {
5642 integer c__2 = 2;
5643 integer c__21 = 21;
5644 /* System generated locals */
5645 integer tcbold_dim1, tcbold_dim2, tcbold_offset, tcbnew_dim1, tcbnew_dim2,
5646 tcbnew_offset, i__1, i__2, i__3, i__4, i__5;
5647
5648
5649 /* Local variables */
5650 logical ldbg;
5651 integer ndeg;
5652 doublereal taux1[21];
5653 integer d__, e, i__, k;
5654 doublereal mfact;
5655 integer ncoeff;
5656 doublereal tjacap[21];
5657 integer iordre[2];
5658 doublereal hermit[36]/* was [6][3][2] */, ctenor, bornes[2];
5659 integer ier;
5660 integer aux1, aux2;
5661
5662 /* ***********************************************************************
5663 */
5664
5665 /* FUNCTION : */
5666 /* ---------- */
5667 /* CONVERSION OF TABLE TCBOLD OF POLYNOMIAL CURVE COEFFICIENTS */
5668 /* EXPRESSED IN HERMIT JACOBI BASE, INTO A */
5669 /* TABLE OF COEFFICIENTS TCBNEW OF COURVES EXPRESSED IN THE CANONIC BASE */
5670
5671 /* KEYWORDS : */
5672 /* ----------- */
5673 /* CANNONIC, HERMIT, JACCOBI */
5674
5675 /* INPUT ARGUMENTS : */
5676 /* -------------------- */
5677 /* ORDHER : ORDER OF HERMIT POLYNOMS OR ORDER OF CONTINUITY */
5678 /* NCOEFS : NUMBER OF COEFFICIENTS OF A POLYNOMIAL CURVE */
5679 /* FOR ONE OF ITS NDIM COMPONENTS;(DEGREE+1 OF THE CURVE)
5680 */
5681 /* NDIM : DIMENSION OF THE CURVE */
5682 /* CBHEJA : TABLE OF COEFFICIENTS OF THE CURVE IN THE BASE */
5683 /* HERMIT JACOBI */
5684 /* (H(0,-1),..,H(ORDHER,-1),H(0,1),..,H(ORDHER,1), */
5685 /* JA(ORDHER+1,2*ORDHER+2),....,JA(ORDHER+1,NCOEFS-1) */
5686
5687 /* OUTPUT ARGUMENTS : */
5688 /* --------------------- */
5689 /* CBRCAN : TABLE OF COEFFICIENTS OF THE CURVE IN THE CANONIC BASE */
5690 /* (1, t, ...) */
5691
5692 /* COMMONS USED : */
5693 /* ------------------ */
5694
5695
5696 /* REFERENCES CALLED : */
5697 /* --------------------- */
5698
5699
5700 /* ***********************************************************************
5701 */
5702
5703
5704 /* ***********************************************************************
5705 */
5706
5707 /* FUNCTION : */
5708 /* ---------- */
5709 /* Providesinteger constants from 0 to 1000 */
5710
5711 /* KEYWORDS : */
5712 /* ----------- */
5713 /* ALL, INTEGER */
5714
5715 /* DEMSCRIPTION/NOTES/LIMITATIONS : */
5716 /* ----------------------------------- */
5717 /* > */
5718 /* ***********************************************************************
5719 */
5720
5721
5722 /* ***********************************************************************
5723 */
5724
5725
5726
5727
5728 /* ***********************************************************************
5729 */
5730 /* INITIALIZATION */
5731 /* ***********************************************************************
5732 */
5733
5734 /* Parameter adjustments */
5735 --ncftab;
5736 tcbnew_dim1 = *ndimen;
5737 tcbnew_dim2 = *ncflim;
5738 tcbnew_offset = tcbnew_dim1 * (tcbnew_dim2 + 1) + 1;
5739 tcbnew -= tcbnew_offset;
5740 tcbold_dim1 = *ndimen;
5741 tcbold_dim2 = *ncflim;
5742 tcbold_offset = tcbold_dim1 * (tcbold_dim2 + 1) + 1;
5743 tcbold -= tcbold_offset;
5744
5745 /* Function Body */
5746 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 2;
5747 if (ldbg) {
5748 AdvApp2Var_SysBase::mgenmsg_("MMHJCAN", 7L);
5749 }
5750 *iercod = 0;
5751
5752 bornes[0] = -1.;
5753 bornes[1] = 1.;
5754
5755 /* ***********************************************************************
5756 */
5757 /* PROCESSING */
5758 /* ***********************************************************************
5759 */
5760
5761 if (*orcont > 2) {
5762 goto L9101;
5763 }
5764 if (*ncflim > 21) {
5765 goto L9101;
5766 }
5767
5768 /* CALCULATION OF HERMIT POLYNOMS IN THE CANONIC BASE ON (-1,1) */
5769
5770
5771 iordre[0] = *orcont;
5772 iordre[1] = *orcont;
5773 mmherm1_(bornes, &c__2, iordre, hermit, &ier);
5774 if (ier > 0) {
5775 goto L9102;
5776 }
5777
5778
5779 aux1 = *orcont + 1;
5780 aux2 = aux1 << 1;
5781
5782 i__1 = *ncourb;
5783 for (e = 1; e <= i__1; ++e) {
5784
5785 ctenor = (tdecop[e] - tdecop[e - 1]) / 2;
5786 ncoeff = ncftab[e];
5787 ndeg = ncoeff - 1;
5788 if (ncoeff > 21) {
5789 goto L9101;
5790 }
5791
5792 i__2 = *ndimen;
5793 for (d__ = 1; d__ <= i__2; ++d__) {
5794
5795 /* CONVERSION OF THE COEFFICIENTS OF THE PART OF THE CURVE EXPRESSED */
5796 /* IN HERMIT BASE, INTO THE CANONIC BASE */
5797
5798 AdvApp2Var_SysBase::mvriraz_(&ncoeff, taux1);
5799
5800 i__3 = aux2;
5801 for (k = 1; k <= i__3; ++k) {
5802 i__4 = aux1;
5803 for (i__ = 1; i__ <= i__4; ++i__) {
5804 i__5 = i__ - 1;
5805 mfact = AdvApp2Var_MathBase::pow__di(&ctenor, &i__5);
5806 taux1[k - 1] += (tcbold[d__ + (i__ + e * tcbold_dim2) *
5807 tcbold_dim1] * hermit[k + (i__ + 2) * 6 - 19] +
5808 tcbold[d__ + (i__ + aux1 + e * tcbold_dim2) *
5809 tcbold_dim1] * hermit[k + (i__ + 5) * 6 - 19]) *
5810 mfact;
5811 }
5812 }
5813
5814
5815 i__3 = ncoeff;
5816 for (i__ = aux2 + 1; i__ <= i__3; ++i__) {
5817 taux1[i__ - 1] = tcbold[d__ + (i__ + e * tcbold_dim2) *
5818 tcbold_dim1];
5819 }
5820
5821 /* CONVERSION OF THE COEFFICIENTS OF THE PART OF THE CURVE EXPRESSED */
5822 /* IN CANONIC-JACOBI BASE, INTO THE CANONIC BASE */
5823
5824
5825
5826 AdvApp2Var_MathBase::mmapcmp_(&minombr_.nbr[1], &c__21, &ncoeff, taux1, tjacap);
5827 AdvApp2Var_MathBase::mmjacan_(orcont, &ndeg, tjacap, taux1);
5828
5829 /* RECOPY THE COEFS RESULTING FROM THE CONVERSION IN THE TABLE */
5830 /* OF RESULTS */
5831
5832 i__3 = ncoeff;
5833 for (i__ = 1; i__ <= i__3; ++i__) {
5834 tcbnew[d__ + (i__ + e * tcbnew_dim2) * tcbnew_dim1] = taux1[
5835 i__ - 1];
5836 }
5837
5838 }
5839 }
5840
5841 goto L9999;
5842
5843 /* ***********************************************************************
5844 */
5845 /* PROCESSING OF ERRORS */
5846 /* ***********************************************************************
5847 */
5848
5849 L9101:
5850 *iercod = 1;
5851 goto L9999;
5852 L9102:
5853 *iercod = 2;
5854 goto L9999;
5855
5856 /* ***********************************************************************
5857 */
5858 /* RETURN CALLING PROGRAM */
5859 /* ***********************************************************************
5860 */
5861
5862 L9999:
5863
5864 AdvApp2Var_SysBase::maermsg_("MMHJCAN", iercod, 7L);
5865 if (ldbg) {
5866 AdvApp2Var_SysBase::mgsomsg_("MMHJCAN", 7L);
5867 }
5868 return 0 ;
5869 } /* mmhjcan_ */
5870
5871 //=======================================================================
5872 //function : AdvApp2Var_MathBase::mminltt_
5873 //purpose :
5874 //=======================================================================
mminltt_(integer * ncolmx,integer * nlgnmx,doublereal * tabtri,integer * nbrcol,integer * nbrlgn,doublereal * ajoute,doublereal *,integer * iercod)5875 int AdvApp2Var_MathBase::mminltt_(integer *ncolmx,
5876 integer *nlgnmx,
5877 doublereal *tabtri,
5878 integer *nbrcol,
5879 integer *nbrlgn,
5880 doublereal *ajoute,
5881 doublereal *,//epseg,
5882 integer *iercod)
5883 {
5884 /* System generated locals */
5885 integer tabtri_dim1, tabtri_offset, i__1, i__2;
5886
5887 /* Local variables */
5888 logical idbg;
5889 integer icol, ilgn, nlgn, noct, inser;
5890 doublereal epsega = 0.;
5891 integer ibb;
5892
5893 /* ***********************************************************************
5894 */
5895
5896 /* FUNCTION : */
5897 /* ---------- */
5898 /* . Insert a line in a table parsed without redundance */
5899
5900 /* KEYWORDS : */
5901 /* ----------- */
5902 /* TOUS,MATH_ACCES :: TABLEAU&,INSERTION,&TABLEAU */
5903
5904 /* INPUT ARGUMENTS : */
5905 /* -------------------- */
5906 /* . NCOLMX : Number of columns in the table */
5907 /* . NLGNMX : Number of lines in the table */
5908 /* . TABTRI : Table parsed by lines without redundances */
5909 /* . NBRCOL : Number of columns used */
5910 /* . NBRLGN : Number of lines used */
5911 /* . AJOUTE : Line to be added */
5912 /* . EPSEGA : Epsilon to test the redundance */
5913
5914 /* OUTPUT ARGUMENTS : */
5915 /* --------------------- */
5916 /* . TABTRI : Table parsed by lines without redundances */
5917 /* . NBRLGN : Number of lines used */
5918 /* . IERCOD : 0 -> No problem */
5919 /* 1 -> The table is full */
5920
5921 /* COMMONS USED : */
5922 /* ------------------ */
5923
5924 /* REFERENCES CALLED : */
5925 /* --------------------- */
5926
5927 /* DESCRIPTION/NOTES/LIMITATIONS : */
5928 /* ----------------------------------- */
5929 /* . The line is inserted only if there is no line with all
5930 */
5931 /* elements equl to those which are planned to be insered, to epsilon. */
5932
5933 /* . Level of de debug = 3 */
5934
5935
5936 /**/
5937 /* DECLARATIONS , CONTROL OF INPUT ARGUMENTS , INITIALIZATION */
5938 /* ***********************************************************************
5939 */
5940
5941 /* --- Parameters */
5942
5943
5944 /* --- Functions */
5945
5946
5947 /* --- Local variables */
5948
5949
5950 /* --- Messages */
5951
5952 /* Parameter adjustments */
5953 tabtri_dim1 = *ncolmx;
5954 tabtri_offset = tabtri_dim1 + 1;
5955 tabtri -= tabtri_offset;
5956 --ajoute;
5957
5958 /* Function Body */
5959 ibb = AdvApp2Var_SysBase::mnfndeb_();
5960 idbg = ibb >= 3;
5961 if (idbg) {
5962 AdvApp2Var_SysBase::mgenmsg_("MMINLTT", 7L);
5963 }
5964
5965 /* --- Control arguments */
5966
5967 if (*nbrlgn >= *nlgnmx) {
5968 goto L9001;
5969 }
5970
5971 /* -------------------- */
5972 /* *** INITIALIZATION */
5973 /* -------------------- */
5974
5975 *iercod = 0;
5976
5977 /* ---------------------------- */
5978 /* *** SEARCH OF REDUNDANCE */
5979 /* ---------------------------- */
5980
5981 i__1 = *nbrlgn;
5982 for (ilgn = 1; ilgn <= i__1; ++ilgn) {
5983 if (tabtri[ilgn * tabtri_dim1 + 1] >= ajoute[1] - epsega) {
5984 if (tabtri[ilgn * tabtri_dim1 + 1] <= ajoute[1] + epsega) {
5985 i__2 = *nbrcol;
5986 for (icol = 1; icol <= i__2; ++icol) {
5987 if (tabtri[icol + ilgn * tabtri_dim1] < ajoute[icol] -
5988 epsega || tabtri[icol + ilgn * tabtri_dim1] >
5989 ajoute[icol] + epsega) {
5990 goto L20;
5991 }
5992 /* L10: */
5993 }
5994 goto L9999;
5995 } else {
5996 goto L30;
5997 }
5998 }
5999 L20:
6000 ;
6001 }
6002
6003 /* ----------------------------------- */
6004 /* *** SEARCH OF THE INSERTION POINT */
6005 /* ----------------------------------- */
6006
6007 L30:
6008
6009 i__1 = *nbrlgn;
6010 for (ilgn = 1; ilgn <= i__1; ++ilgn) {
6011 i__2 = *nbrcol;
6012 for (icol = 1; icol <= i__2; ++icol) {
6013 if (tabtri[icol + ilgn * tabtri_dim1] < ajoute[icol]) {
6014 goto L50;
6015 }
6016 if (tabtri[icol + ilgn * tabtri_dim1] > ajoute[icol]) {
6017 goto L70;
6018 }
6019 /* L60: */
6020 }
6021 L50:
6022 ;
6023 }
6024
6025 ilgn = *nbrlgn + 1;
6026
6027 /* -------------- */
6028 /* *** INSERTION */
6029 /* -------------- */
6030
6031 L70:
6032
6033 inser = ilgn;
6034 ++(*nbrlgn);
6035
6036 /* --- Shift lower */
6037
6038 nlgn = *nbrlgn - inser;
6039 if (nlgn > 0) {
6040 noct = (*ncolmx << 3) * nlgn;
6041 AdvApp2Var_SysBase::mcrfill_(&noct,
6042 &tabtri[inser * tabtri_dim1 + 1],
6043 &tabtri[(inser + 1)* tabtri_dim1 + 1]);
6044 }
6045
6046 /* --- Copy line */
6047
6048 noct = *nbrcol << 3;
6049 AdvApp2Var_SysBase::mcrfill_(&noct,
6050 &ajoute[1],
6051 &tabtri[inser * tabtri_dim1 + 1]);
6052
6053 goto L9999;
6054
6055 /* ******************************************************************** */
6056 /* OUTPUT ERROR , RETURN CALLING PROGRAM , MESSAGES */
6057 /* ******************************************************************** */
6058
6059 /* --- The table is already full */
6060
6061 L9001:
6062 *iercod = 1;
6063
6064 /* --- End */
6065
6066 L9999:
6067 if (*iercod != 0) {
6068 AdvApp2Var_SysBase::maermsg_("MMINLTT", iercod, 7L);
6069 }
6070 if (idbg) {
6071 AdvApp2Var_SysBase::mgsomsg_("MMINLTT", 7L);
6072 }
6073 return 0 ;
6074 } /* mminltt_ */
6075
6076 //=======================================================================
6077 //function : AdvApp2Var_MathBase::mmjacan_
6078 //purpose :
6079 //=======================================================================
mmjacan_(const integer * ideriv,integer * ndeg,doublereal * poljac,doublereal * polcan)6080 int AdvApp2Var_MathBase::mmjacan_(const integer *ideriv,
6081 integer *ndeg,
6082 doublereal *poljac,
6083 doublereal *polcan)
6084 {
6085 /* System generated locals */
6086 integer poljac_dim1, i__1, i__2;
6087
6088 /* Local variables */
6089 integer iptt, i__, j, ibb;
6090 doublereal bid;
6091
6092 /* ***********************************************************************
6093 */
6094
6095 /* FUNCTION : */
6096 /* ---------- */
6097 /* Routine of transfer of Jacobi normalized to canonic [-1,1], */
6098 /* the tables are ranked by even, then by uneven degree. */
6099
6100 /* KEYWORDS : */
6101 /* ----------- */
6102 /* LEGENDRE,JACOBI,PASSAGE. */
6103
6104 /* INPUT ARGUMENTS : */
6105 /* ------------------ */
6106 /* IDERIV : Order of Jacobi between -1 and 2. */
6107 /* NDEG : The true degree of the polynom. */
6108 /* POLJAC : The polynom in the Jacobi base. */
6109
6110 /* OUTPUT ARGUMENTS : */
6111 /* ------------------- */
6112 /* POLCAN : The curve expressed in the canonic base [-1,1]. */
6113
6114 /* COMMONS USED : */
6115 /* ---------------- */
6116
6117 /* REFERENCES CALLED : */
6118 /* ----------------------- */
6119
6120 /* DESCRIPTION/NOTES/LIMITATIONS : */
6121 /* ----------------------------------- */
6122
6123 /* > */
6124 /* ***********************************************************************
6125 */
6126
6127 /* Name of the routine */
6128
6129 /* Matrices of conversion */
6130
6131
6132 /* ***********************************************************************
6133 */
6134
6135 /* FUNCTION : */
6136 /* ---------- */
6137 /* MATRIX OF TRANSFORMATION OF LEGENDRE BASE */
6138
6139 /* KEYWORDS : */
6140 /* ----------- */
6141 /* MATH */
6142
6143 /* DEMSCRIPTION/NOTES/LIMITATIONS : */
6144 /* ----------------------------------- */
6145
6146 /* > */
6147 /* ***********************************************************************
6148 */
6149
6150
6151
6152 /* Legendre common / Restricted Casteljau. */
6153
6154 /* 0:1 0 Concerns the even terms, 1 the uneven terms. */
6155 /* CANPLG : Matrix of passage to canonic from Jacobi with calculated parities */
6156 /* PLGCAN : Matrix of passage from Jacobi to canonic with calculated parities */
6157
6158
6159 /* ***********************************************************************
6160 */
6161
6162 /* Parameter adjustments */
6163 poljac_dim1 = *ndeg / 2 + 1;
6164
6165 /* Function Body */
6166 ibb = AdvApp2Var_SysBase::mnfndeb_();
6167 if (ibb >= 5) {
6168 AdvApp2Var_SysBase::mgenmsg_("MMJACAN", 7L);
6169 }
6170
6171 /* ----------------- Expression of terms of even degree ----------------
6172 */
6173
6174 i__1 = *ndeg / 2;
6175 for (i__ = 0; i__ <= i__1; ++i__) {
6176 bid = 0.;
6177 iptt = i__ * 31 - (i__ + 1) * i__ / 2 + 1;
6178 i__2 = *ndeg / 2;
6179 for (j = i__; j <= i__2; ++j) {
6180 bid += mmjcobi_.plgcan[iptt + j + *ideriv * 992 + 991] * poljac[
6181 j];
6182 /* L310: */
6183 }
6184 polcan[i__ * 2] = bid;
6185 /* L300: */
6186 }
6187
6188 /* --------------- Expression of terms of uneven degree ----------------
6189 */
6190
6191 if (*ndeg == 0) {
6192 goto L9999;
6193 }
6194
6195 i__1 = (*ndeg - 1) / 2;
6196 for (i__ = 0; i__ <= i__1; ++i__) {
6197 bid = 0.;
6198 iptt = i__ * 31 - (i__ + 1) * i__ / 2 + 1;
6199 i__2 = (*ndeg - 1) / 2;
6200 for (j = i__; j <= i__2; ++j) {
6201 bid += mmjcobi_.plgcan[iptt + j + ((*ideriv << 1) + 1) * 496 +
6202 991] * poljac[j + poljac_dim1];
6203 /* L410: */
6204 }
6205 polcan[(i__ << 1) + 1] = bid;
6206 /* L400: */
6207 }
6208
6209 /* -------------------------------- The end -----------------------------
6210 */
6211
6212 L9999:
6213 if (ibb >= 5) {
6214 AdvApp2Var_SysBase::mgsomsg_("MMJACAN", 7L);
6215 }
6216 return 0;
6217 } /* mmjacan_ */
6218
6219 //=======================================================================
6220 //function : AdvApp2Var_MathBase::mmjaccv_
6221 //purpose :
6222 //=======================================================================
mmjaccv_(const integer * ncoef,const integer * ndim,const integer * ider,const doublereal * crvlgd,doublereal * polaux,doublereal * crvcan)6223 int AdvApp2Var_MathBase::mmjaccv_(const integer *ncoef,
6224 const integer *ndim,
6225 const integer *ider,
6226 const doublereal *crvlgd,
6227 doublereal *polaux,
6228 doublereal *crvcan)
6229
6230 {
6231 /* Initialized data */
6232
6233 static char nomprg[8+1] = "MMJACCV ";
6234
6235 /* System generated locals */
6236 integer crvlgd_dim1, crvlgd_offset, crvcan_dim1, crvcan_offset,
6237 polaux_dim1, i__1, i__2;
6238
6239 /* Local variables */
6240 integer ndeg, i__, nd, ii, ibb;
6241
6242 /* ***********************************************************************
6243 */
6244
6245 /* FUNCTION : */
6246 /* ---------- */
6247 /* Passage from the normalized Jacobi base to the canonic base. */
6248
6249 /* KEYWORDS : */
6250 /* ----------- */
6251 /* SMOOTHING, BASE, LEGENDRE */
6252
6253
6254 /* INPUT ARGUMENTS : */
6255 /* ------------------ */
6256 /* NDIM: Space Dimension. */
6257 /* NCOEF: Degree +1 of the polynom. */
6258 /* IDER: Order of Jacobi polynoms. */
6259 /* CRVLGD : Curve in the base of Jacobi. */
6260
6261 /* OUTPUT ARGUMENTS : */
6262 /* ------------------- */
6263 /* POLAUX : Auxilliary space. */
6264 /* CRVCAN : The curve in the canonic base [-1,1] */
6265
6266 /* COMMONS USED : */
6267 /* ---------------- */
6268
6269 /* REFERENCES CALLED : */
6270 /* ----------------------- */
6271
6272 /* DESCRIPTION/NOTES/LIMITATIONS : */
6273 /* ----------------------------------- */
6274
6275 /* > */
6276 /* *********************************************************************
6277 */
6278
6279 /* Name of the routine */
6280 /* Parameter adjustments */
6281 polaux_dim1 = (*ncoef - 1) / 2 + 1;
6282 crvcan_dim1 = *ncoef - 1 + 1;
6283 crvcan_offset = crvcan_dim1;
6284 crvcan -= crvcan_offset;
6285 crvlgd_dim1 = *ncoef - 1 + 1;
6286 crvlgd_offset = crvlgd_dim1;
6287 crvlgd -= crvlgd_offset;
6288
6289 /* Function Body */
6290
6291 ibb = AdvApp2Var_SysBase::mnfndeb_();
6292 if (ibb >= 3) {
6293 AdvApp2Var_SysBase::mgenmsg_(nomprg, 6L);
6294 }
6295
6296 ndeg = *ncoef - 1;
6297
6298 i__1 = *ndim;
6299 for (nd = 1; nd <= i__1; ++nd) {
6300 /* Loading of the auxilliary table. */
6301 ii = 0;
6302 i__2 = ndeg / 2;
6303 for (i__ = 0; i__ <= i__2; ++i__) {
6304 polaux[i__] = crvlgd[ii + nd * crvlgd_dim1];
6305 ii += 2;
6306 /* L310: */
6307 }
6308
6309 ii = 1;
6310 if (ndeg >= 1) {
6311 i__2 = (ndeg - 1) / 2;
6312 for (i__ = 0; i__ <= i__2; ++i__) {
6313 polaux[i__ + polaux_dim1] = crvlgd[ii + nd * crvlgd_dim1];
6314 ii += 2;
6315 /* L320: */
6316 }
6317 }
6318 /* Call the routine of base change. */
6319 AdvApp2Var_MathBase::mmjacan_(ider, &ndeg, polaux, &crvcan[nd * crvcan_dim1]);
6320 /* L300: */
6321 }
6322
6323
6324 /* L9999: */
6325 return 0;
6326 } /* mmjaccv_ */
6327
6328 //=======================================================================
6329 //function : mmloncv_
6330 //purpose :
6331 //=======================================================================
mmloncv_(integer * ndimax,integer * ndimen,integer * ncoeff,doublereal * courbe,doublereal * tdebut,doublereal * tfinal,doublereal * xlongc,integer * iercod)6332 int mmloncv_(integer *ndimax,
6333 integer *ndimen,
6334 integer *ncoeff,
6335 doublereal *courbe,
6336 doublereal *tdebut,
6337 doublereal *tfinal,
6338 doublereal *xlongc,
6339 integer *iercod)
6340
6341 {
6342 /* Initialized data */
6343
6344 integer kgar = 0;
6345
6346 /* System generated locals */
6347 integer courbe_dim1, courbe_offset, i__1, i__2;
6348
6349 /* Local variables */
6350 doublereal tran;
6351 integer ngaus = 0;
6352 doublereal c1, c2, d1, d2,
6353 wgaus[20] = {0.}, uroot[20] = {0.}, x1, x2, dd;
6354 integer ii, jj, kk;
6355 doublereal som;
6356 doublereal der1, der2;
6357
6358
6359
6360
6361 /* **********************************************************************
6362 */
6363
6364 /* FUNCTION : Length of an arc of curve on a given interval */
6365 /* ---------- for a function the mathematic representation */
6366 /* which of is a multidimensional polynom. */
6367 /* The polynom is a set of polynoms the coefficients which of are ranked */
6368 /* in a table with 2 indices, each line relative to 1 polynom. */
6369 /* The polynom is defined by its coefficients ordered by increasing
6370 * power of the variable. */
6371 /* All polynoms have the same number of coefficients (and the same degree). */
6372
6373 /* KEYWORDS : LENGTH, CURVE */
6374 /* ----------- */
6375
6376 /* INPUT ARGUMENTS : */
6377 /* -------------------- */
6378
6379 /* NDIMAX : Max number of lines of tables (max number of polynoms). */
6380 /* NDIMEN : Dimension of the polynom (Nomber of polynoms). */
6381 /* NCOEFF : Number of coefficients of the polynom (no limitation) */
6382 /* This is degree + 1 */
6383 /* COURBE : Coefficients of the polynom ordered by increasing power */
6384 /* Dimension to (NDIMAX,NCOEFF). */
6385 /* TDEBUT : Lower limit of integration for length calculation. */
6386 /* TFINAL : Upper limit of integration for length calculation. */
6387
6388 /* OUTPUT ARGUMENTS : */
6389 /* --------------------- */
6390 /* XLONGC : Length of arc of curve */
6391
6392 /* IERCOD : Error code : */
6393 /* = 0 ==> All is OK */
6394 /* = 1 ==> NDIMEN or NCOEFF negative or null */
6395 /* = 2 ==> Pb loading Legendre roots and Gauss weight */
6396 /* by MVGAUS0. */
6397
6398 /* If error => XLONGC = 0 */
6399
6400 /* COMMONS USED : */
6401 /* ------------------ */
6402
6403 /* .Neant. */
6404
6405 /* REFERENCES CALLED : */
6406 /* ---------------------- */
6407 /* Type Name */
6408 /* MAERMSG R*8 DSQRT I*4 MIN */
6409 /* MVGAUS0 */
6410
6411 /* DESCRIPTION/NOTES/LIMITATIONS : */
6412 /* ----------------------------------- */
6413
6414 /* See VGAUSS to understand well the technique. */
6415 /* Actually SQRT (dpi^2) is integrated for i=1,nbdime */
6416 /* Calculation of the derivative is included in the code to avoid an additional */
6417 /* call of the routine. */
6418
6419 /* The integrated function is strictly increasing, it */
6420 /* is not necessary to use a high degree for the GAUSS method GAUSS. */
6421
6422 /* The degree of LEGENDRE polynom results from the degree of the */
6423 /* polynom to be integrated. It can vary from 4 to 40 (with step of 4). */
6424
6425 /* The precision (relative) of integration is of order 1.D-8. */
6426
6427 /* ATTENTION : if TDEBUT > TFINAL, the length is NEGATIVE. */
6428
6429 /* Attention : the precision of the result is not controlled. */
6430 /* If you wish to control it, use MMCGLC1, taking into account that */
6431 /* the performance (in time) will be worse. */
6432
6433 /* >=====================================================================
6434 */
6435
6436 /* ATTENTION : SAVE KGAR WGAUS and UROOT EVENTUALLY */
6437 /* ,IERXV */
6438 /* INTEGER I1,I20 */
6439 /* PARAMETER (I1=1,I20=20) */
6440
6441 /* Parameter adjustments */
6442 courbe_dim1 = *ndimax;
6443 courbe_offset = courbe_dim1 + 1;
6444 courbe -= courbe_offset;
6445
6446 /* Function Body */
6447
6448 /* ****** General initialization ** */
6449
6450 *iercod = 999999;
6451 *xlongc = 0.;
6452
6453 /* ****** Initialization of UROOT, WGAUS, NGAUS and KGAR ** */
6454
6455 /* CALL MXVINIT(IERXV,'INTEGER',I1,KGAR,'INTEGER',I1,NGAUS */
6456 /* 1 ,'DOUBLE PRECISION',I20,UROOT,'DOUBLE PRECISION',I20,WGAUS) */
6457 /* IF (IERXV.GT.0) KGAR=0 */
6458
6459 /* ****** Test the equity of limits ** */
6460
6461 if (*tdebut == *tfinal) {
6462 *iercod = 0;
6463 goto L9900;
6464 }
6465
6466 /* ****** Test the dimension and the number of coefficients ** */
6467
6468 if (*ndimen <= 0 || *ncoeff <= 0) {
6469 *iercod = 1;
6470 goto L9900;
6471 }
6472
6473 /* ****** Calculate the optimal degree ** */
6474
6475 kk = *ncoeff / 4 + 1;
6476 kk = advapp_min(kk,10);
6477
6478 /* ****** Return the coefficients for the integral (DEGRE=4*KK) */
6479 /* if KK <> KGAR. */
6480
6481 if (kk != kgar) {
6482 mvgaus0_(&kk, uroot, wgaus, &ngaus, iercod);
6483 if (*iercod > 0) {
6484 kgar = 0;
6485 *iercod = 2;
6486 goto L9900;
6487 }
6488 kgar = kk;
6489 }
6490
6491 /* C1 => Point medium interval */
6492 /* C2 => 1/2 amplitude interval */
6493
6494 c1 = (*tfinal + *tdebut) * .5;
6495 c2 = (*tfinal - *tdebut) * .5;
6496
6497 /* ----------------------------------------------------------- */
6498 /* ****** Integration - Loop on GAUSS intervals ** */
6499 /* ----------------------------------------------------------- */
6500
6501 som = 0.;
6502
6503 i__1 = ngaus;
6504 for (jj = 1; jj <= i__1; ++jj) {
6505
6506 /* ****** Integration taking the symmetry into account ** */
6507
6508 tran = c2 * uroot[jj - 1];
6509 x1 = c1 + tran;
6510 x2 = c1 - tran;
6511
6512 /* ****** Derivation on the dimension of the space ** */
6513
6514 der1 = 0.;
6515 der2 = 0.;
6516 i__2 = *ndimen;
6517 for (kk = 1; kk <= i__2; ++kk) {
6518 d1 = (*ncoeff - 1) * courbe[kk + *ncoeff * courbe_dim1];
6519 d2 = d1;
6520 for (ii = *ncoeff - 1; ii >= 2; --ii) {
6521 dd = (ii - 1) * courbe[kk + ii * courbe_dim1];
6522 d1 = d1 * x1 + dd;
6523 d2 = d2 * x2 + dd;
6524 /* L100: */
6525 }
6526 der1 += d1 * d1;
6527 der2 += d2 * d2;
6528 /* L200: */
6529 }
6530
6531 /* ****** Integration ** */
6532
6533 som += wgaus[jj - 1] * c2 * (sqrt(der1) + sqrt(der2));
6534
6535 /* ****** End of loop on GAUSS intervals ** */
6536
6537 /* L300: */
6538 }
6539
6540 /* ****** Work ended ** */
6541
6542 *xlongc = som;
6543
6544 /* ****** It is forced IERCOD = 0 ** */
6545
6546 *iercod = 0;
6547
6548 /* ****** Final processing ** */
6549
6550 L9900:
6551
6552 /* ****** Save UROOT, WGAUS, NGAUS and KGAR ** */
6553
6554 /* CALL MXVSAVE(IERXV,'INTEGER',I1,KGAR,'INTEGER',I1,NGAUS */
6555 /* 1 ,'DOUBLE PRECISION',I20,UROOT,'DOUBLE PRECISION',I20,WGAUS) */
6556 /* IF (IERXV.GT.0) KGAR=0 */
6557
6558 /* ****** End of sub-program ** */
6559
6560 if (*iercod != 0) {
6561 AdvApp2Var_SysBase::maermsg_("MMLONCV", iercod, 7L);
6562 }
6563 return 0 ;
6564 } /* mmloncv_ */
6565
6566 //=======================================================================
6567 //function : AdvApp2Var_MathBase::mmpobas_
6568 //purpose :
6569 //=======================================================================
mmpobas_(doublereal * tparam,integer * iordre,integer * ncoeff,integer * nderiv,doublereal * valbas,integer * iercod)6570 int AdvApp2Var_MathBase::mmpobas_(doublereal *tparam,
6571 integer *iordre,
6572 integer *ncoeff,
6573 integer *nderiv,
6574 doublereal *valbas,
6575 integer *iercod)
6576
6577 {
6578 integer c__2 = 2;
6579 integer c__1 = 1;
6580
6581
6582 /* Initialized data */
6583
6584 doublereal moin11[2] = { -1.,1. };
6585
6586 /* System generated locals */
6587 integer valbas_dim1 = 0, i__1 = 0;
6588
6589 /* Local variables */
6590 doublereal vjacc[80] = {};
6591 doublereal herm[24] = {};
6592 NCollection_Array1<doublereal> vjac (vjacc[0], 1, 80);
6593 integer iord[2] = {};
6594 doublereal wval[4] = {};
6595 integer nwcof = 0, iunit = 0;
6596 doublereal wpoly[7] = {};
6597 integer ii = 0, jj = 0, iorjac = 0;
6598 doublereal hermit[36] = {}; // was [6][3][2]
6599 integer kk1 = 0, kk2 = 0, kk3 = 0;
6600 integer khe = 0, ier = 0;
6601
6602
6603 /* ***********************************************************************
6604 */
6605
6606 /* FUNCTION : */
6607 /* ---------- */
6608 /* Position on the polynoms of base hermit-Jacobi */
6609 /* and their succesive derivatives */
6610
6611 /* KEYWORDS : */
6612 /* ----------- */
6613 /* PUBLIC, POSITION, HERMIT, JACOBI */
6614
6615 /* INPUT ARGUMENTS : */
6616 /* -------------------- */
6617 /* TPARAM : Parameter for which the position is found. */
6618 /* IORDRE : Orderof hermit-Jacobi (-1,0,1, ou 2) */
6619 /* NCOEFF : Number of coefficients of polynoms (Nb of value to calculate) */
6620 /* NDERIV : Number of derivative to calculate (0<= N <=3) */
6621 /* 0 -> Position simple on base functions */
6622 /* N -> Position on base functions and derivative */
6623 /* of order 1 to N */
6624
6625 /* OUTPUT ARGUMENTS : */
6626 /* --------------------- */
6627 /* VALBAS (NCOEFF, 0:NDERIV) : calculated value */
6628 /* i */
6629 /* d vj(t) = VALBAS(J, I) */
6630 /* -- i */
6631 /* dt */
6632
6633 /* IERCOD : Error code */
6634 /* 0 : Ok */
6635 /* 1 : Incoherence of input arguments */
6636
6637 /* COMMONS USED : */
6638 /* -------------- */
6639
6640
6641 /* REFERENCES CALLED : */
6642 /* ------------------- */
6643
6644
6645 /* DESCRIPTION/NOTES/LIMITATIONS : */
6646 /* ----------------------------------- */
6647
6648 /* > */
6649 /* ***********************************************************************
6650 */
6651 /* DECLARATIONS */
6652 /* ***********************************************************************
6653 */
6654
6655
6656
6657 /* Parameter adjustments */
6658 valbas_dim1 = *ncoeff;
6659 --valbas;
6660
6661 /* Function Body */
6662
6663 /* ***********************************************************************
6664 */
6665 /* INITIALIZATIONS */
6666 /* ***********************************************************************
6667 */
6668
6669 *iercod = 0;
6670
6671 /* ***********************************************************************
6672 */
6673 /* PROCESSING */
6674 /* ***********************************************************************
6675 */
6676
6677 if (*nderiv > 3) {
6678 goto L9101;
6679 }
6680 if (*ncoeff > 20) {
6681 goto L9101;
6682 }
6683 if (*iordre > 2) {
6684 goto L9101;
6685 }
6686
6687 iord[0] = *iordre;
6688 iord[1] = *iordre;
6689 iorjac = (*iordre + 1) << 1;
6690
6691 /* (1) Generic Calculations .... */
6692
6693 /* (1.a) Calculation of hermit polynoms */
6694
6695 if (*iordre >= 0) {
6696 mmherm1_(moin11, &c__2, iord, hermit, &ier);
6697 if (ier > 0) {
6698 goto L9102;
6699 }
6700 }
6701
6702 /* (1.b) Evaluation of hermit polynoms */
6703
6704 jj = 1;
6705 iunit = *nderiv + 1;
6706 khe = (*iordre + 1) * iunit;
6707
6708 if (*nderiv > 0) {
6709
6710 i__1 = *iordre;
6711 for (ii = 0; ii <= i__1; ++ii) {
6712 mmdrvcb_(nderiv, &c__1, &iorjac, &hermit[(ii + 3) * 6 - 18],
6713 tparam, &herm[jj - 1], &ier);
6714 if (ier > 0) {
6715 goto L9102;
6716 }
6717
6718 mmdrvcb_(nderiv, &c__1, &iorjac, &hermit[(ii + 6) * 6 - 18],
6719 tparam, &herm[jj + khe - 1], &ier);
6720 if (ier > 0) {
6721 goto L9102;
6722 }
6723 jj += iunit;
6724 }
6725
6726 } else {
6727
6728 i__1 = *iordre;
6729 for (ii = 0; ii <= i__1; ++ii) {
6730 AdvApp2Var_MathBase::mmpocrb_(&c__1, &iorjac, &hermit[(ii + 3) * 6 - 18], &c__1,
6731 tparam, &herm[jj - 1]);
6732
6733 AdvApp2Var_MathBase::mmpocrb_(&c__1, &iorjac, &hermit[(ii + 6) * 6 - 18], &c__1,
6734 tparam, &herm[jj + khe - 1]);
6735 jj += iunit;
6736 }
6737 }
6738
6739 /* (1.c) Evaluation of Jacobi polynoms */
6740
6741 ii = *ncoeff - iorjac;
6742
6743 mmpojac_(tparam, &iorjac, &ii, nderiv, vjac, &ier);
6744 if (ier > 0) {
6745 goto L9102;
6746 }
6747
6748 /* (1.d) Evaluation of W(t) */
6749
6750 /* Computing MAX */
6751 i__1 = iorjac + 1;
6752 nwcof = advapp_max(i__1,1);
6753 AdvApp2Var_SysBase::mvriraz_(&nwcof,
6754 wpoly);
6755 wpoly[0] = 1.;
6756 if (*iordre == 2) {
6757 wpoly[2] = -3.;
6758 wpoly[4] = 3.;
6759 wpoly[6] = -1.;
6760 } else if (*iordre == 1) {
6761 wpoly[2] = -2.;
6762 wpoly[4] = 1.;
6763 } else if (*iordre == 0) {
6764 wpoly[2] = -1.;
6765 }
6766
6767 mmdrvcb_(nderiv, &c__1, &nwcof, wpoly, tparam, wval, &ier);
6768 if (ier > 0) {
6769 goto L9102;
6770 }
6771
6772 kk1 = *ncoeff - iorjac;
6773 kk2 = kk1 << 1;
6774 kk3 = kk1 * 3;
6775
6776 /* (2) Evaluation of order 0 */
6777
6778 jj = 1;
6779 i__1 = iorjac;
6780 for (ii = 1; ii <= i__1; ++ii) {
6781 valbas[ii] = herm[jj - 1];
6782 jj += iunit;
6783 }
6784
6785 i__1 = kk1;
6786 for (ii = 1; ii <= i__1; ++ii) {
6787 valbas[ii + iorjac] = wval[0] * vjac(ii);
6788 }
6789
6790 /* (3) Evaluation of order 1 */
6791
6792 if (*nderiv >= 1) {
6793 jj = 2;
6794 i__1 = iorjac;
6795 for (ii = 1; ii <= i__1; ++ii) {
6796 valbas[ii + valbas_dim1] = herm[jj - 1];
6797 jj += iunit;
6798 }
6799
6800
6801 i__1 = kk1;
6802 for (ii = 1; ii <= i__1; ++ii) {
6803 valbas[ii + iorjac + valbas_dim1] = wval[0] * vjac(ii + kk1)
6804 + wval[1] * vjac(ii);
6805 }
6806 }
6807
6808 /* (4) Evaluation of order 2 */
6809
6810 if (*nderiv >= 2) {
6811 jj = 3;
6812 i__1 = iorjac;
6813 for (ii = 1; ii <= i__1; ++ii) {
6814 valbas[ii + (valbas_dim1 << 1)] = herm[jj - 1];
6815 jj += iunit;
6816 }
6817
6818 i__1 = kk1;
6819 for (ii = 1; ii <= i__1; ++ii) {
6820 valbas[ii + iorjac + (valbas_dim1 << 1)] = wval[0] * vjac(ii +
6821 kk2) + wval[1] * 2 * vjac(ii + kk1) + wval[2] *
6822 vjac(ii);
6823 }
6824 }
6825
6826 /* (5) Evaluation of order 3 */
6827
6828 if (*nderiv >= 3) {
6829 jj = 4;
6830 i__1 = iorjac;
6831 for (ii = 1; ii <= i__1; ++ii) {
6832 valbas[ii + valbas_dim1 * 3] = herm[jj - 1];
6833 jj += iunit;
6834 }
6835
6836 i__1 = kk1;
6837 for (ii = 1; ii <= i__1; ++ii) {
6838 valbas[ii + iorjac + valbas_dim1 * 3] = wval[0] * vjac(ii + kk3)
6839 + wval[1] * 3 * vjac(ii + kk2) + wval[2] * 3 *
6840 vjac(ii + kk1) + wval[3] * vjac(ii);
6841 }
6842 }
6843
6844 goto L9999;
6845
6846 /* ***********************************************************************
6847 */
6848 /* ERROR PROCESSING */
6849 /* ***********************************************************************
6850 */
6851
6852 L9101:
6853 *iercod = 1;
6854 goto L9999;
6855
6856 L9102:
6857 *iercod = 2;
6858
6859 /* ***********************************************************************
6860 */
6861 /* RETURN CALLING PROGRAM */
6862 /* ***********************************************************************
6863 */
6864
6865 L9999:
6866
6867 if (*iercod > 0) {
6868 AdvApp2Var_SysBase::maermsg_("MMPOBAS", iercod, 7L);
6869 }
6870 return 0 ;
6871 } /* mmpobas_ */
6872
6873 //=======================================================================
6874 //function : AdvApp2Var_MathBase::mmpocrb_
6875 //purpose :
6876 //=======================================================================
mmpocrb_(integer * ndimax,integer * ncoeff,doublereal * courbe,integer * ndim,doublereal * tparam,doublereal * pntcrb)6877 int AdvApp2Var_MathBase::mmpocrb_(integer *ndimax,
6878 integer *ncoeff,
6879 doublereal *courbe,
6880 integer *ndim,
6881 doublereal *tparam,
6882 doublereal *pntcrb)
6883
6884 {
6885 /* System generated locals */
6886 integer courbe_dim1, courbe_offset, i__1, i__2;
6887
6888 /* Local variables */
6889 integer ncof2;
6890 integer isize, nd, kcf, ncf;
6891
6892
6893 /* ***********************************************************************
6894 */
6895
6896 /* FUNCTION : */
6897 /* ---------- */
6898 /* CALCULATE THE COORDINATES OF A POINT OF A CURVE OF GIVEN PARAMETER */
6899 /* TPARAM ( IN 2D, 3D OR MORE) */
6900
6901 /* KEYWORDS : */
6902 /* ----------- */
6903 /* TOUS , MATH_ACCES :: COURBE&,PARAMETRE& , POSITIONNEMENT , &POINT
6904 */
6905
6906 /* INPUT ARGUMENTS : */
6907 /* ------------------ */
6908 /* NDIMAX : format / dimension of the curve */
6909 /* NCOEFF : Nb of coefficients of the curve */
6910 /* COURBE : Matrix of coefficients of the curve */
6911 /* NDIM : Dimension useful of the workspace */
6912 /* TPARAM : Value of the parameter where the point is calculated */
6913
6914 /* OUTPUT ARGUMENTS : */
6915 /* ------------------- */
6916 /* PNTCRB : Coordinates of the calculated point */
6917
6918 /* COMMONS USED : */
6919 /* ---------------- */
6920
6921 /* .Neant. */
6922
6923 /* REFERENCES CALLED : */
6924 /* ---------------------- */
6925 /* Type Name */
6926 /* MIRAZ MVPSCR2 MVPSCR3 */
6927
6928 /* DESCRIPTION/NOTES/LIMITATIONS : */
6929 /* ----------------------------------- */
6930
6931 /* > */
6932 /* ***********************************************************************
6933 */
6934
6935
6936 /* ***********************************************************************
6937 */
6938
6939 /* Parameter adjustments */
6940 courbe_dim1 = *ndimax;
6941 courbe_offset = courbe_dim1 + 1;
6942 courbe -= courbe_offset;
6943 --pntcrb;
6944
6945 /* Function Body */
6946 isize = *ndim << 3;
6947 AdvApp2Var_SysBase::miraz_(&isize,
6948 &pntcrb[1]);
6949
6950 if (*ncoeff <= 0) {
6951 goto L9999;
6952 }
6953
6954 /* optimal processing 3d */
6955
6956 if (*ndim == 3 && *ndimax == 3) {
6957 mvpscr3_(ncoeff, &courbe[courbe_offset], tparam, &pntcrb[1]);
6958
6959 /* optimal processing 2d */
6960
6961 } else if (*ndim == 2 && *ndimax == 2) {
6962 mvpscr2_(ncoeff, &courbe[courbe_offset], tparam, &pntcrb[1]);
6963
6964 /* Any dimension - scheme of HORNER */
6965
6966 } else if (*tparam == 0.) {
6967 i__1 = *ndim;
6968 for (nd = 1; nd <= i__1; ++nd) {
6969 pntcrb[nd] = courbe[nd + courbe_dim1];
6970 /* L100: */
6971 }
6972 } else if (*tparam == 1.) {
6973 i__1 = *ncoeff;
6974 for (ncf = 1; ncf <= i__1; ++ncf) {
6975 i__2 = *ndim;
6976 for (nd = 1; nd <= i__2; ++nd) {
6977 pntcrb[nd] += courbe[nd + ncf * courbe_dim1];
6978 /* L300: */
6979 }
6980 /* L200: */
6981 }
6982 } else {
6983 ncof2 = *ncoeff + 2;
6984 i__1 = *ndim;
6985 for (nd = 1; nd <= i__1; ++nd) {
6986 i__2 = *ncoeff;
6987 for (ncf = 2; ncf <= i__2; ++ncf) {
6988 kcf = ncof2 - ncf;
6989 pntcrb[nd] = (pntcrb[nd] + courbe[nd + kcf * courbe_dim1]) * *
6990 tparam;
6991 /* L500: */
6992 }
6993 pntcrb[nd] += courbe[nd + courbe_dim1];
6994 /* L400: */
6995 }
6996 }
6997
6998 L9999:
6999 return 0 ;
7000 } /* mmpocrb_ */
7001
7002 //=======================================================================
7003 //function : AdvApp2Var_MathBase::mmmpocur_
7004 //purpose :
7005 //=======================================================================
mmmpocur_(integer * ncofmx,integer * ndim,integer * ndeg,doublereal * courbe,doublereal * tparam,doublereal * tabval)7006 int AdvApp2Var_MathBase::mmmpocur_(integer *ncofmx,
7007 integer *ndim,
7008 integer *ndeg,
7009 doublereal *courbe,
7010 doublereal *tparam,
7011 doublereal *tabval)
7012
7013 {
7014 /* System generated locals */
7015 integer courbe_dim1, courbe_offset, i__1;
7016
7017 /* Local variables */
7018 integer i__, nd;
7019 doublereal fu;
7020
7021
7022 /* ***********************************************************************
7023 */
7024
7025 /* FUNCTION : */
7026 /* ---------- */
7027 /* Position of a point on curve (ncofmx,ndim). */
7028
7029 /* KEYWORDS : */
7030 /* ----------- */
7031 /* TOUS , AB_SPECIFI :: COURBE&,POLYNOME&,POSITIONNEMENT,&POINT */
7032
7033 /* INPUT ARGUMENTS : */
7034 /* ------------------ */
7035 /* NCOFMX: Format / degree of the CURVE. */
7036 /* NDIM : Dimension of the space. */
7037 /* NDEG : Degree of the polynom. */
7038 /* COURBE: Coefficients of the curve. */
7039 /* TPARAM: Parameter on the curve */
7040
7041 /* OUTPUT ARGUMENTS : */
7042 /* ------------------- */
7043 /* TABVAL(NDIM): The resulting point (or table of values) */
7044
7045 /* COMMONS USED : */
7046 /* ---------------- */
7047
7048 /* REFERENCES CALLED : */
7049 /* ----------------------- */
7050
7051 /* DESCRIPTION/NOTES/LIMITATIONS : */
7052 /* ----------------------------------- */
7053
7054 /* > */
7055 /* ***********************************************************************
7056 */
7057
7058 /* Parameter adjustments */
7059 --tabval;
7060 courbe_dim1 = *ncofmx;
7061 courbe_offset = courbe_dim1 + 1;
7062 courbe -= courbe_offset;
7063
7064 /* Function Body */
7065 if (*ndeg < 1) {
7066 i__1 = *ndim;
7067 for (nd = 1; nd <= i__1; ++nd) {
7068 tabval[nd] = 0.;
7069 /* L290: */
7070 }
7071 } else {
7072 i__1 = *ndim;
7073 for (nd = 1; nd <= i__1; ++nd) {
7074 fu = courbe[*ndeg + nd * courbe_dim1];
7075 for (i__ = *ndeg - 1; i__ >= 1; --i__) {
7076 fu = fu * *tparam + courbe[i__ + nd * courbe_dim1];
7077 /* L120: */
7078 }
7079 tabval[nd] = fu;
7080 /* L300: */
7081 }
7082 }
7083 return 0 ;
7084 } /* mmmpocur_ */
7085
7086 //=======================================================================
7087 //function : mmpojac_
7088 //purpose :
7089 //=======================================================================
mmpojac_(doublereal * tparam,integer * iordre,integer * ncoeff,integer * nderiv,NCollection_Array1<doublereal> & valjac,integer * iercod)7090 int mmpojac_(doublereal *tparam,
7091 integer *iordre,
7092 integer *ncoeff,
7093 integer *nderiv,
7094 NCollection_Array1<doublereal>& valjac,
7095 integer *iercod)
7096
7097 {
7098 integer c__2 = 2;
7099
7100 /* System generated locals */
7101 integer valjac_dim1, i__1, i__2;
7102
7103 /* Local variables */
7104 doublereal cofa, cofb, denom, tnorm[100];
7105 integer ii, jj, kk1, kk2;
7106 doublereal aux1, aux2;
7107
7108
7109 /* ***********************************************************************
7110 */
7111
7112 /* FUNCTION : */
7113 /* ---------- */
7114 /* Positioning on Jacobi polynoms and their derivatives */
7115 /* successive by a recurrent algorithm */
7116
7117 /* KEYWORDS : */
7118 /* ----------- */
7119 /* RESERVE, POSITIONING, JACOBI */
7120
7121 /* INPUT ARGUMENTS : */
7122 /* -------------------- */
7123 /* TPARAM : Parameter for which positioning is done. */
7124 /* IORDRE : Order of hermit-?? (-1,0,1, or 2) */
7125 /* NCOEFF : Number of coeeficients of polynoms (Nb of value to */
7126 /* calculate) */
7127 /* NDERIV : Number of derivative to calculate (0<= N <=3) */
7128 /* 0 -> Position simple on jacobi functions */
7129 /* N -> Position on jacobi functions and their */
7130 /* derivatives of order 1 to N. */
7131
7132 /* OUTPUT ARGUMENTS : */
7133 /* --------------------- */
7134 /* VALJAC (NCOEFF, 0:NDERIV) : the calculated values */
7135 /* i */
7136 /* d vj(t) = VALJAC(J, I) */
7137 /* -- i */
7138 /* dt */
7139
7140 /* IERCOD : Error Code */
7141 /* 0 : Ok */
7142 /* 1 : Incoherence of input arguments */
7143
7144 /* COMMONS USED : */
7145 /* ------------------ */
7146
7147
7148 /* REFERENCES CALLED : */
7149 /* --------------------- */
7150
7151
7152 /* DESCRIPTION/NOTES/LIMITATIONS : */
7153 /* ----------------------------------- */
7154
7155 /* > */
7156 /* ***********************************************************************
7157 */
7158 /* DECLARATIONS */
7159 /* ***********************************************************************
7160 */
7161
7162
7163 /* static varaibles */
7164
7165
7166
7167 /* Parameter adjustments */
7168 valjac_dim1 = *ncoeff;
7169
7170 /* Function Body */
7171
7172 /* ***********************************************************************
7173 */
7174 /* INITIALISATIONS */
7175 /* ***********************************************************************
7176 */
7177
7178 *iercod = 0;
7179
7180 /* ***********************************************************************
7181 */
7182 /* Processing */
7183 /* ***********************************************************************
7184 */
7185
7186 if (*nderiv > 3) {
7187 goto L9101;
7188 }
7189 if (*ncoeff > 100) {
7190 goto L9101;
7191 }
7192
7193 /* --- Calculation of norms */
7194
7195 /* IF (NCOEFF.GT.NBCOF) THEN */
7196 i__1 = *ncoeff;
7197 for (ii = 1; ii <= i__1; ++ii) {
7198 kk1 = ii - 1;
7199 aux2 = 1.;
7200 i__2 = *iordre;
7201 for (jj = 1; jj <= i__2; ++jj) {
7202 aux2 = aux2 * (doublereal) (kk1 + *iordre + jj) / (doublereal) (
7203 kk1 + jj);
7204 }
7205 i__2 = (*iordre << 1) + 1;
7206 tnorm[ii - 1] = sqrt(aux2 * (kk1 * 2. + (*iordre << 1) + 1) / pow__ii(&
7207 c__2, &i__2));
7208 }
7209
7210 /* END IF */
7211
7212 /* --- Trivial Positions ----- */
7213
7214 valjac(1) = 1.;
7215 aux1 = (doublereal) (*iordre + 1);
7216 valjac(2) = aux1 * *tparam;
7217
7218 if (*nderiv >= 1) {
7219 valjac(valjac_dim1 + 1) = 0.;
7220 valjac(valjac_dim1 + 2) = aux1;
7221
7222 if (*nderiv >= 2) {
7223 valjac((valjac_dim1 << 1) + 1) = 0.;
7224 valjac((valjac_dim1 << 1) + 2) = 0.;
7225
7226 if (*nderiv >= 3) {
7227 valjac(valjac_dim1 * 3 + 1) = 0.;
7228 valjac(valjac_dim1 * 3 + 2) = 0.;
7229 }
7230 }
7231 }
7232
7233 /* --- Positioning by recurrence */
7234
7235 i__1 = *ncoeff;
7236 for (ii = 3; ii <= i__1; ++ii) {
7237
7238 kk1 = ii - 1;
7239 kk2 = ii - 2;
7240 aux1 = (doublereal) (*iordre + kk2);
7241 aux2 = aux1 * 2;
7242 cofa = aux2 * (aux2 + 1) * (aux2 + 2);
7243 cofb = (aux2 + 2) * -2. * aux1 * aux1;
7244 denom = kk1 * 2. * (kk2 + (*iordre << 1) + 1) * aux2;
7245 denom = 1. / denom;
7246
7247 /* --> Pi(t) */
7248 valjac(ii) = (cofa * *tparam * valjac(kk1) + cofb * valjac(kk2)) *
7249 denom;
7250 /* --> P'i(t) */
7251 if (*nderiv >= 1) {
7252 valjac(ii + valjac_dim1) = (cofa * *tparam * valjac(kk1 +
7253 valjac_dim1) + cofa * valjac(kk1) + cofb * valjac(kk2 +
7254 valjac_dim1)) * denom;
7255 /* --> P''i(t) */
7256 if (*nderiv >= 2) {
7257 valjac(ii + (valjac_dim1 << 1)) = (cofa * *tparam * valjac(
7258 kk1 + (valjac_dim1 << 1)) + cofa * 2 * valjac(kk1 +
7259 valjac_dim1) + cofb * valjac(kk2 + (valjac_dim1 << 1))
7260 ) * denom;
7261 }
7262 /* --> P'i(t) */
7263 if (*nderiv >= 3) {
7264 valjac(ii + valjac_dim1 * 3) = (cofa * *tparam * valjac(kk1 +
7265 valjac_dim1 * 3) + cofa * 3 * valjac(kk1 + (
7266 valjac_dim1 << 1)) + cofb * valjac(kk2 + valjac_dim1 *
7267 3)) * denom;
7268 }
7269 }
7270 }
7271
7272 /* ---> Normalization */
7273
7274 i__1 = *ncoeff;
7275 for (ii = 1; ii <= i__1; ++ii) {
7276 i__2 = *nderiv;
7277 for (jj = 0; jj <= i__2; ++jj) {
7278 valjac(ii + jj * valjac_dim1) = tnorm[ii - 1] * valjac(ii + jj *
7279 valjac_dim1);
7280 }
7281 }
7282
7283 goto L9999;
7284
7285 /* ***********************************************************************
7286 */
7287 /* PROCESSING OF ERRORS */
7288 /* ***********************************************************************
7289 */
7290
7291 L9101:
7292 *iercod = 1;
7293 goto L9999;
7294
7295
7296 /* ***********************************************************************
7297 */
7298 /* RETURN CALLING PROGRAM */
7299 /* ***********************************************************************
7300 */
7301
7302 L9999:
7303
7304 if (*iercod > 0) {
7305 AdvApp2Var_SysBase::maermsg_("MMPOJAC", iercod, 7L);
7306 }
7307 return 0 ;
7308 } /* mmpojac_ */
7309
7310 //=======================================================================
7311 //function : AdvApp2Var_MathBase::mmposui_
7312 //purpose :
7313 //=======================================================================
mmposui_(integer * dimmat,integer *,integer * aposit,integer * posuiv,integer * iercod)7314 int AdvApp2Var_MathBase::mmposui_(integer *dimmat,
7315 integer *,//nistoc,
7316 integer *aposit,
7317 integer *posuiv,
7318 integer *iercod)
7319
7320 {
7321 /* System generated locals */
7322 integer i__1, i__2;
7323
7324 /* Local variables */
7325 logical ldbg;
7326 integer imin, jmin, i__, j, k;
7327 logical trouve;
7328
7329 /* ***********************************************************************
7330 */
7331
7332 /* FUNCTION : */
7333 /* ---------- */
7334 /* FILL THE TABLE OF POSITIONING POSUIV WHICH ALLOWS TO */
7335 /* PARSE BY COLUMN THE INFERIOR TRIANGULAR PART OF THE */
7336 /* MATRIX IN FORM OF PROFILE */
7337
7338
7339 /* KEYWORDS : */
7340 /* ----------- */
7341 /* RESERVE, MATRIX, PROFILE */
7342
7343 /* INPUT ARGUMENTS : */
7344 /* -------------------- */
7345
7346 /* NISTOC: NUMBER OF COEFFICIENTS IN THE PROFILE */
7347 /* DIMMAT: NUMBER OF LINE OF THE SYMMETRIC SQUARE MATRIX */
7348 /* APOSIT: TABLE OF POSITIONING OF STORAGE TERMS */
7349 /* APOSIT(1,I) CONTAINS THE NUMBER OF TERMES-1 ON LINE */
7350 /* I IN THE PROFILE OF THE MATRIX */
7351 /* APOSIT(2,I) CONTAINS THE INDEX OF STORAGE OF DIAGONAL TERM */
7352 /* OF LINE I */
7353
7354
7355 /* OUTPUT ARGUMENTS : */
7356 /* --------------------- */
7357 /* POSUIV: POSUIV(K) (WHERE K IS THE INDEX OF STORAGE OF MAT(I,J)) */
7358 /* CONTAINS THE SMALLEST NUMBER IMIN>I OF THE LINE THAT */
7359 /* POSSESSES A TERM MAT(IMIN,J) THAT IS IN THE PROFILE. */
7360 /* IF THERE IS NO TERM MAT(IMIN,J) IN THE PROFILE THEN POSUIV(K)=-1 */
7361
7362
7363 /* COMMONS USED : */
7364 /* ------------------ */
7365
7366
7367 /* REFERENCES CALLED : */
7368 /* --------------------- */
7369
7370
7371 /* DESCRIPTION/NOTES/LIMITATIONS : */
7372 /* ----------------------------------- */
7373
7374
7375 /* ***********************************************************************
7376 */
7377 /* DECLARATIONS */
7378 /* ***********************************************************************
7379 */
7380
7381
7382
7383 /* ***********************************************************************
7384 */
7385 /* INITIALIZATIONS */
7386 /* ***********************************************************************
7387 */
7388
7389 /* Parameter adjustments */
7390 aposit -= 3;
7391 --posuiv;
7392
7393 /* Function Body */
7394 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 2;
7395 if (ldbg) {
7396 AdvApp2Var_SysBase::mgenmsg_("MMPOSUI", 7L);
7397 }
7398 *iercod = 0;
7399
7400
7401 /* ***********************************************************************
7402 */
7403 /* PROCESSING */
7404 /* ***********************************************************************
7405 */
7406
7407
7408
7409 i__1 = *dimmat;
7410 for (i__ = 1; i__ <= i__1; ++i__) {
7411 jmin = i__ - aposit[(i__ << 1) + 1];
7412 i__2 = i__;
7413 for (j = jmin; j <= i__2; ++j) {
7414 imin = i__ + 1;
7415 trouve = FALSE_;
7416 while(! trouve && imin <= *dimmat) {
7417 if (imin - aposit[(imin << 1) + 1] <= j) {
7418 trouve = TRUE_;
7419 } else {
7420 ++imin;
7421 }
7422 }
7423 k = aposit[(i__ << 1) + 2] - i__ + j;
7424 if (trouve) {
7425 posuiv[k] = imin;
7426 } else {
7427 posuiv[k] = -1;
7428 }
7429 }
7430 }
7431
7432
7433
7434
7435
7436 goto L9999;
7437
7438 /* ***********************************************************************
7439 */
7440 /* ERROR PROCESSING */
7441 /* ***********************************************************************
7442 */
7443
7444
7445
7446
7447 /* ***********************************************************************
7448 */
7449 /* RETURN CALLING PROGRAM */
7450 /* ***********************************************************************
7451 */
7452
7453 L9999:
7454
7455 /* ___ DESALLOCATION, ... */
7456
7457 AdvApp2Var_SysBase::maermsg_("MMPOSUI", iercod, 7L);
7458 if (ldbg) {
7459 AdvApp2Var_SysBase::mgsomsg_("MMPOSUI", 7L);
7460 }
7461 return 0 ;
7462 } /* mmposui_ */
7463
7464 //=======================================================================
7465 //function : AdvApp2Var_MathBase::mmresol_
7466 //purpose :
7467 //=======================================================================
mmresol_(integer * hdimen,integer * gdimen,integer * hnstoc,integer * gnstoc,integer * mnstoc,doublereal * matsyh,doublereal * matsyg,doublereal * vecsyh,doublereal * vecsyg,integer * hposit,integer * hposui,integer * gposit,integer * mmposui,integer * mposit,doublereal * vecsol,integer * iercod)7468 int AdvApp2Var_MathBase::mmresol_(integer *hdimen,
7469 integer *gdimen,
7470 integer *hnstoc,
7471 integer *gnstoc,
7472 integer *mnstoc,
7473 doublereal *matsyh,
7474 doublereal *matsyg,
7475 doublereal *vecsyh,
7476 doublereal *vecsyg,
7477 integer *hposit,
7478 integer *hposui,
7479 integer *gposit,
7480 integer *mmposui,
7481 integer *mposit,
7482 doublereal *vecsol,
7483 integer *iercod)
7484
7485 {
7486 integer c__100 = 100;
7487
7488 /* System generated locals */
7489 integer i__1, i__2;
7490
7491 /* Local variables */
7492 logical ldbg;
7493 doublereal* mcho = 0;
7494 integer jmin, jmax, i__, j, k, l;
7495 intptr_t iofv1, iofv2, iofv3, iofv4;
7496 doublereal *v1 = 0, *v2 = 0, *v3 = 0, *v4 = 0;
7497 integer deblig, dimhch;
7498 doublereal* hchole = 0;
7499 intptr_t iofmch, iofmam, iofhch;
7500 doublereal* matsym = 0;
7501 integer ier;
7502 integer aux;
7503
7504
7505
7506 /* ***********************************************************************
7507 */
7508
7509 /* FUNCTION : */
7510 /* ---------- */
7511 /* SOLUTION OF THE SYSTEM */
7512 /* H t(G) V B */
7513 /* = */
7514 /* G 0 L C */
7515
7516 /* KEYWORDS : */
7517 /* ----------- */
7518 /* RESERVE, SOLUTION, SYSTEM, LAGRANGIAN */
7519
7520 /* INPUT ARGUMENTS : */
7521 /* -------------------- */
7522 /* HDIMEN: NOMBER OF LINE (OR COLUMN) OF THE HESSIAN MATRIX */
7523 /* GDIMEN: NOMBER OF LINE OF THE MATRIX OF CONSTRAINTS */
7524 /* HNSTOC: NOMBErS OF TERMS IN THE PROFILE OF HESSIAN MATRIX
7525 */
7526 /* GNSTOC: NOMBERS OF TERMS IN THE PROFILE OF THE MATRIX OF CONSTRAINTS */
7527 /* MNSTOC: NOMBERS OF TERMS IN THE PROFILE OF THE MATRIX M= G H t(G) */
7528 /* where H IS THE HESSIAN MATRIX AND G IS THE MATRIX OF CONSTRAINTS */
7529 /* MATSYH: TRIANGULAR INFERIOR PART OF THE HESSIAN MATRIX */
7530 /* IN FORM OF PROFILE */
7531 /* MATSYG: MATRIX OF CONSTRAINTS IN FORM OF PROFILE */
7532 /* VECSYH: VECTOR OF THE SECOND MEMBER ASSOCIATED TO MATSYH */
7533 /* VECSYG: VECTOR OF THE SECOND MEMBER ASSOCIATED TO MATSYG */
7534 /* HPOSIT: TABLE OF POSITIONING OF THE HESSIAN MATRIX */
7535 /* HPOSIT(1,I) CONTAINS THE NUMBER OF TERMS -1 */
7536 /* WHICH ARE IN THE PROFILE AT LINE I */
7537 /* HPOSIT(2,I) CONTAINS THE INDEX OF STORAGE OF TERM */
7538 /* DIAGONAL OF THE MATRIX AT LINE I */
7539 /* HPOSUI: TABLE ALLOWING TO PARSE THE HESSIAN MATRIX BY COLUMN */
7540 /* IN FORM OF PROFILE */
7541 /* HPOSUI(K) CONTAINS THE NUMBER OF LINE IMIN FOLLOWING THE CURRENT LINE*/
7542 /* I WHERE H(I,J)=MATSYH(K) AS IT EXISTS IN THE */
7543 /* SAME COLUMN J A TERM IN THE PROFILE OF LINE IMIN */
7544 /* IF SUCH TERM DOES NOT EXIST IMIN=-1 */
7545 /* GPOSIT: TABLE OF POSITIONING OF THE MATRIX OF CONSTRAINTS */
7546 /* GPOSIT(1,I) CONTAINS THE NUMBER OF TERMS OF LINE I */
7547 /* WHICH ARE IN THE PROFILE */
7548 /* GPOSIT(2,I) CONTAINS THE INDEX OF STORAGE OF THE LAST TERM */
7549 /* OF LINE I WHICH IS IN THE PROFILE */
7550 /* GPOSIT(3,I) CONTAINS THE NUMBER OF COLUMN CORRESPONDING */
7551 /* TO THE FIRST TERM OF LINE I WHICH IS IN THE PROFILE */
7552 /* MMPOSUI, MPOSIT: SAME STRUCTURE AS HPOSUI, BUT FOR MATRIX */
7553 /* M=G H t(G) */
7554
7555
7556 /* OUTPUT ARGUMENTS : */
7557 /* --------------------- */
7558 /* VECSOL: VECTOR SOLUTION V OF THE SYSTEM */
7559 /* IERCOD: ERROR CODE */
7560
7561 /* COMMONS USED : */
7562 /* ------------------ */
7563
7564
7565 /* REFERENCES CALLED : */
7566 /* --------------------- */
7567
7568
7569 /* DESCRIPTION/NOTES/LIMITATIONS : */
7570 /* ----------------------------------- */
7571 /* > */
7572 /* ***********************************************************************
7573 */
7574 /* DECLARATIONS */
7575 /* ***********************************************************************
7576 */
7577
7578 /* ***********************************************************************
7579 */
7580 /* INITIALISATIONS */
7581 /* ***********************************************************************
7582 */
7583
7584 /* Parameter adjustments */
7585 --vecsol;
7586 hposit -= 3;
7587 --vecsyh;
7588 --hposui;
7589 --matsyh;
7590 --matsyg;
7591 --vecsyg;
7592 gposit -= 4;
7593 --mmposui;
7594 mposit -= 3;
7595
7596 /* Function Body */
7597 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 2;
7598 if (ldbg) {
7599 AdvApp2Var_SysBase::mgenmsg_("MMRESOL", 7L);
7600 }
7601 *iercod = 0;
7602 iofhch = 0;
7603 iofv1 = 0;
7604 iofv2 = 0;
7605 iofv3 = 0;
7606 iofv4 = 0;
7607 iofmam = 0;
7608 iofmch = 0;
7609
7610 /* ***********************************************************************
7611 */
7612 /* PROCESSING */
7613 /* ***********************************************************************
7614 */
7615
7616 /* Dynamic allocation */
7617 AdvApp2Var_SysBase anAdvApp2Var_SysBase;
7618 anAdvApp2Var_SysBase.macrar8_(hdimen, &c__100, v1, &iofv1, &ier);
7619 if (ier > 0) {
7620 goto L9102;
7621 }
7622 dimhch = hposit[(*hdimen << 1) + 2];
7623 anAdvApp2Var_SysBase.macrar8_(&dimhch, &c__100, hchole, &iofhch, &ier);
7624 if (ier > 0) {
7625 goto L9102;
7626 }
7627
7628 /* solution of system 1 H V1 = b */
7629 /* where H=MATSYH and b=VECSYH */
7630
7631 mmchole_(hnstoc, hdimen, &matsyh[1], &hposit[3], &hposui[1], &hchole[
7632 iofhch], &ier);
7633 if (ier > 0) {
7634 goto L9101;
7635 }
7636 mmrslss_(hnstoc, hdimen, &hchole[iofhch], &hposit[3], &hposui[1], &vecsyh[
7637 1], &v1[iofv1], &ier);
7638 if (ier > 0) {
7639 goto L9102;
7640 }
7641
7642 /* Case when there are constraints */
7643
7644 if (*gdimen > 0) {
7645
7646 /* Calculate the vector of the second member V2=G H(-1) b -c = G v1-c */
7647 /* of system of unknown Lagrangian vector MULTIP */
7648 /* where G=MATSYG */
7649 /* c=VECSYG */
7650
7651 anAdvApp2Var_SysBase.macrar8_(gdimen, &c__100, v2, &iofv2, &ier);
7652 if (ier > 0) {
7653 goto L9102;
7654 }
7655 anAdvApp2Var_SysBase.macrar8_(hdimen, &c__100, v3, &iofv3, &ier);
7656 if (ier > 0) {
7657 goto L9102;
7658 }
7659 anAdvApp2Var_SysBase.macrar8_(gdimen, &c__100, v4, &iofv4, &ier);
7660 if (ier > 0) {
7661 goto L9102;
7662 }
7663 anAdvApp2Var_SysBase.macrar8_(mnstoc, &c__100, matsym, &iofmam, &ier);
7664 if (ier > 0) {
7665 goto L9102;
7666 }
7667
7668 deblig = 1;
7669 mmatvec_(gdimen, hdimen, &gposit[4], gnstoc, &matsyg[1], &v1[iofv1], &
7670 deblig, &v2[iofv2], &ier);
7671 if (ier > 0) {
7672 goto L9101;
7673 }
7674 i__1 = *gdimen;
7675 for (i__ = 1; i__ <= i__1; ++i__) {
7676 v2[i__ + iofv2 - 1] -= vecsyg[i__];
7677 }
7678
7679 /* Calculate the matrix M= G H(-1) t(G) */
7680 /* RESOL DU SYST 2 : H qi = gi */
7681 /* where is a vector column of t(G) */
7682 /* qi=v3 */
7683 /* then calculate G qi */
7684 /* then construct M in form of profile */
7685
7686
7687
7688 i__1 = *gdimen;
7689 for (i__ = 1; i__ <= i__1; ++i__) {
7690 AdvApp2Var_SysBase::mvriraz_(hdimen, &v1[iofv1]);
7691 AdvApp2Var_SysBase::mvriraz_(hdimen, &v3[iofv3]);
7692 AdvApp2Var_SysBase::mvriraz_(gdimen, &v4[iofv4]);
7693 jmin = gposit[i__ * 3 + 3];
7694 jmax = gposit[i__ * 3 + 1] + gposit[i__ * 3 + 3] - 1;
7695 aux = gposit[i__ * 3 + 2] - gposit[i__ * 3 + 1] - jmin + 1;
7696 i__2 = jmax;
7697 for (j = jmin; j <= i__2; ++j) {
7698 k = j + aux;
7699 v1[j + iofv1 - 1] = matsyg[k];
7700 }
7701 mmrslss_(hnstoc, hdimen, &hchole[iofhch], &hposit[3], &hposui[1],
7702 &v1[iofv1], &v3[iofv3], &ier);
7703 if (ier > 0) {
7704 goto L9101;
7705 }
7706
7707 deblig = i__;
7708 mmatvec_(gdimen, hdimen, &gposit[4], gnstoc, &matsyg[1], &v3[
7709 iofv3], &deblig, &v4[iofv4], &ier);
7710 if (ier > 0) {
7711 goto L9101;
7712 }
7713
7714 k = mposit[(i__ << 1) + 2];
7715 matsym[k + iofmam - 1] = v4[i__ + iofv4 - 1];
7716 while(mmposui[k] > 0) {
7717 l = mmposui[k];
7718 k = mposit[(l << 1) + 2] - l + i__;
7719 matsym[k + iofmam - 1] = v4[l + iofv4 - 1];
7720 }
7721 }
7722
7723
7724 /* SOLVE SYST 3 M L = V2 */
7725 /* WITH L=V4 */
7726
7727
7728 AdvApp2Var_SysBase::mvriraz_(gdimen, &v4[iofv4]);
7729 anAdvApp2Var_SysBase.macrar8_(mnstoc, &c__100, mcho, &iofmch, &ier);
7730 if (ier > 0) {
7731 goto L9102;
7732 }
7733 mmchole_(mnstoc, gdimen, &matsym[iofmam], &mposit[3], &mmposui[1], &
7734 mcho[iofmch], &ier);
7735 if (ier > 0) {
7736 goto L9101;
7737 }
7738 mmrslss_(mnstoc, gdimen, &mcho[iofmch], &mposit[3], &mmposui[1], &v2[
7739 iofv2], &v4[iofv4], &ier);
7740 if (ier > 0) {
7741 goto L9102;
7742 }
7743
7744
7745 /* CALCULATE THE VECTOR OF THE SECOND MEMBER OF THE SYSTEM Hx = b - t(G) L
7746 */
7747 /* = V1 */
7748
7749 AdvApp2Var_SysBase::mvriraz_(hdimen, &v1[iofv1]);
7750 mmtmave_(gdimen, hdimen, &gposit[4], gnstoc, &matsyg[1], &v4[iofv4], &
7751 v1[iofv1], &ier);
7752 if (ier > 0) {
7753 goto L9101;
7754 }
7755 i__1 = *hdimen;
7756 for (i__ = 1; i__ <= i__1; ++i__) {
7757 v1[i__ + iofv1 - 1] = vecsyh[i__] - v1[i__ + iofv1 - 1];
7758 }
7759
7760 /* RESOL SYST 4 Hx = b - t(G) L */
7761
7762
7763 mmrslss_(hnstoc, hdimen, &hchole[iofhch], &hposit[3], &hposui[1], &v1[
7764 iofv1], &vecsol[1], &ier);
7765 if (ier > 0) {
7766 goto L9102;
7767 }
7768 } else {
7769 i__1 = *hdimen;
7770 for (i__ = 1; i__ <= i__1; ++i__) {
7771 vecsol[i__] = v1[i__ + iofv1 - 1];
7772 }
7773 }
7774
7775 goto L9999;
7776
7777 /* ***********************************************************************
7778 */
7779 /* PROCESSING OF ERRORS */
7780 /* ***********************************************************************
7781 */
7782
7783
7784 L9101:
7785 *iercod = 1;
7786 goto L9999;
7787
7788 L9102:
7789 AdvApp2Var_SysBase::mswrdbg_("MMRESOL : PROBLEM WITH DIMMAT", 30L);
7790 *iercod = 2;
7791
7792 /* ***********************************************************************
7793 */
7794 /* RETURN CALLING PROGRAM */
7795 /* ***********************************************************************
7796 */
7797
7798 L9999:
7799
7800 /* ___ DESALLOCATION, ... */
7801 anAdvApp2Var_SysBase.macrdr8_(hdimen, &c__100, v1, &iofv1, &ier);
7802 if (*iercod == 0 && ier > 0) {
7803 *iercod = 3;
7804 }
7805 anAdvApp2Var_SysBase.macrdr8_(&dimhch, &c__100, hchole, &iofhch, &ier);
7806 if (*iercod == 0 && ier > 0) {
7807 *iercod = 3;
7808 }
7809 anAdvApp2Var_SysBase.macrdr8_(gdimen, &c__100, v2, &iofv2, &ier);
7810 if (*iercod == 0 && ier > 0) {
7811 *iercod = 3;
7812 }
7813 anAdvApp2Var_SysBase.macrdr8_(hdimen, &c__100, v3, &iofv3, &ier);
7814 if (*iercod == 0 && ier > 0) {
7815 *iercod = 3;
7816 }
7817 anAdvApp2Var_SysBase.macrdr8_(gdimen, &c__100, v4, &iofv4, &ier);
7818 if (*iercod == 0 && ier > 0) {
7819 *iercod = 3;
7820 }
7821 anAdvApp2Var_SysBase.macrdr8_(mnstoc, &c__100, matsym, &iofmam, &ier);
7822 if (*iercod == 0 && ier > 0) {
7823 *iercod = 3;
7824 }
7825 anAdvApp2Var_SysBase.macrdr8_(mnstoc, &c__100, mcho, &iofmch, &ier);
7826 if (*iercod == 0 && ier > 0) {
7827 *iercod = 3;
7828 }
7829
7830 AdvApp2Var_SysBase::maermsg_("MMRESOL", iercod, 7L);
7831 if (ldbg) {
7832 AdvApp2Var_SysBase::mgsomsg_("MMRESOL", 7L);
7833 }
7834 return 0 ;
7835 } /* mmresol_ */
7836
7837 //=======================================================================
7838 //function : mmrslss_
7839 //purpose :
7840 //=======================================================================
mmrslss_(integer *,integer * dimens,doublereal * smatri,integer * sposit,integer * posuiv,doublereal * mscnmbr,doublereal * soluti,integer * iercod)7841 int mmrslss_(integer *,//mxcoef,
7842 integer *dimens,
7843 doublereal *smatri,
7844 integer *sposit,
7845 integer *posuiv,
7846 doublereal *mscnmbr,
7847 doublereal *soluti,
7848 integer *iercod)
7849 {
7850 /* System generated locals */
7851 integer i__1, i__2;
7852
7853 /* Local variables */
7854 logical ldbg;
7855 integer i__, j;
7856 doublereal somme;
7857 integer pointe, ptcour;
7858
7859 /* ***********************************************************************
7860 */
7861
7862 /* FuNCTION : */
7863 /* ---------- T */
7864 /* Solves linear system SS x = b where S is a */
7865 /* triangular lower matrix given in form of profile */
7866
7867 /* KEYWORDS : */
7868 /* ----------- */
7869 /* RESERVE, MATRICE_PROFILE, RESOLUTION, CHOLESKI */
7870
7871 /* INPUT ARGUMENTS : */
7872 /* -------------------- */
7873 /* MXCOEF : Maximum number of non-null coefficient in the matrix */
7874 /* DIMENS : Dimension of the matrix */
7875 /* SMATRI(MXCOEF) : Values of coefficients of the matrix */
7876 /* SPOSIT(2,DIMENS): */
7877 /* SPOSIT(1,*) : Distance diagonal-extremity of the line */
7878 /* SPOSIT(2,*) : Position of diagonal terms in AMATRI */
7879 /* POSUIV(MXCOEF): first line inferior not out of profile */
7880 /* MSCNMBR(DIMENS): Vector second member of the equation */
7881
7882 /* OUTPUT ARGUMENTS : */
7883 /* --------------------- */
7884 /* SOLUTI(NDIMEN) : Result vector */
7885 /* IERCOD : Error code 0 : ok */
7886
7887 /* COMMONS USED : */
7888 /* ------------------ */
7889
7890
7891 /* REFERENCES CALLED : */
7892 /* --------------------- */
7893
7894
7895 /* DESCRIPTION/NOTES/LIMITATIONS : */
7896 /* ----------------------------------- */
7897 /* T */
7898 /* SS is the decomposition of choleski of a symmetric matrix */
7899 /* defined postive, that can result from routine MMCHOLE. */
7900
7901 /* For a full matrix it is possible to use MRSLMSC */
7902
7903 /* LEVEL OF DEBUG = 4 */
7904 /* > */
7905 /* ***********************************************************************
7906 */
7907 /* DECLARATIONS */
7908 /* ***********************************************************************
7909 */
7910
7911
7912
7913 /* ***********************************************************************
7914 */
7915 /* INITIALISATIONS */
7916 /* ***********************************************************************
7917 */
7918
7919 /* Parameter adjustments */
7920 --posuiv;
7921 --smatri;
7922 --soluti;
7923 --mscnmbr;
7924 sposit -= 3;
7925
7926 /* Function Body */
7927 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 4;
7928 if (ldbg) {
7929 AdvApp2Var_SysBase::mgenmsg_("MMRSLSS", 7L);
7930 }
7931 *iercod = 0;
7932
7933 /* ***********************************************************************
7934 */
7935 /* PROCESSING */
7936 /* ***********************************************************************
7937 */
7938
7939 /* ----- Solution of Sw = b */
7940
7941 i__1 = *dimens;
7942 for (i__ = 1; i__ <= i__1; ++i__) {
7943
7944 pointe = sposit[(i__ << 1) + 2];
7945 somme = 0.;
7946 i__2 = i__ - 1;
7947 for (j = i__ - sposit[(i__ << 1) + 1]; j <= i__2; ++j) {
7948 somme += smatri[pointe - (i__ - j)] * soluti[j];
7949 }
7950
7951 soluti[i__] = (mscnmbr[i__] - somme) / smatri[pointe];
7952 }
7953 /* T */
7954 /* ----- Solution of S u = w */
7955
7956 for (i__ = *dimens; i__ >= 1; --i__) {
7957
7958 pointe = sposit[(i__ << 1) + 2];
7959 j = posuiv[pointe];
7960 somme = 0.;
7961 while(j > 0) {
7962 ptcour = sposit[(j << 1) + 2] - (j - i__);
7963 somme += smatri[ptcour] * soluti[j];
7964 j = posuiv[ptcour];
7965 }
7966
7967 soluti[i__] = (soluti[i__] - somme) / smatri[pointe];
7968 }
7969
7970 goto L9999;
7971
7972 /* ***********************************************************************
7973 */
7974 /* ERROR PROCESSING */
7975 /* ***********************************************************************
7976 */
7977
7978
7979 /* ***********************************************************************
7980 */
7981 /* RETURN PROGRAM CALLING */
7982 /* ***********************************************************************
7983 */
7984
7985 L9999:
7986
7987 AdvApp2Var_SysBase::maermsg_("MMRSLSS", iercod, 7L);
7988 if (ldbg) {
7989 AdvApp2Var_SysBase::mgsomsg_("MMRSLSS", 7L);
7990 }
7991 return 0 ;
7992 } /* mmrslss_ */
7993
7994 //=======================================================================
7995 //function : mmrslw_
7996 //purpose :
7997 //=======================================================================
mmrslw_(integer * normax,integer * nordre,integer * ndimen,doublereal * epspiv,doublereal * abmatr,doublereal * xmatri,integer * iercod)7998 int mmrslw_(integer *normax,
7999 integer *nordre,
8000 integer *ndimen,
8001 doublereal *epspiv,
8002 doublereal *abmatr,
8003 doublereal *xmatri,
8004 integer *iercod)
8005 {
8006 /* System generated locals */
8007 integer abmatr_dim1, abmatr_offset, xmatri_dim1, xmatri_offset, i__1,
8008 i__2, i__3;
8009 doublereal d__1;
8010
8011 /* Local variables */
8012 integer kpiv;
8013 doublereal pivot;
8014 integer ii, jj, kk;
8015 doublereal akj;
8016
8017
8018 /* **********************************************************************
8019 */
8020
8021 /* FUNCTION : */
8022 /* ---------- */
8023 /* Solution of a linear system A.x = B of N equations to N */
8024 /* unknown by Gauss method (partial pivot) or : */
8025 /* A is matrix NORDRE * NORDRE, */
8026 /* B is matrix NORDRE (lines) * NDIMEN (columns), */
8027 /* x is matrix NORDRE (lines) * NDIMEN (columns). */
8028 /* In this program, A and B are stored in matrix ABMATR */
8029 /* the lines and columns which of were inverted. ABMATR(k,j) is */
8030 /* term A(j,k) if k <= NORDRE, B(j,k-NORDRE) otherwise (see example). */
8031
8032 /* KEYWORDS : */
8033 /* ----------- */
8034 /* TOUS, MATH_ACCES::EQUATION&, MATRICE&, RESOLUTION, GAUSS, &SOLUTION */
8035
8036 /* INPUT ARGUMENTS : */
8037 /* ------------------ */
8038 /* NORMAX : Max size of the first index of XMATRI. This argument */
8039 /* serves only for the declaration of dimension of XMATRI and should be */
8040 /* above or equal to NORDRE. */
8041 /* NORDRE : Order of the matrix i.e. number of equations and */
8042 /* unknown quantities of the linear system to be solved. */
8043 /* NDIMEN : Number of the second member. */
8044 /* EPSPIV : Minimal value of a pivot. If during the calculation */
8045 /* the absolute value of the pivot is below EPSPIV, the */
8046 /* system of equations is declared singular. EPSPIV should */
8047 /* be a "small" real. */
8048
8049 /* ABMATR(NORDRE+NDIMEN,NORDRE) : Auxiliary matrix containing */
8050 /* matrix A and matrix B. */
8051
8052 /* OUTPUT ARGUMENTS : */
8053 /* ------------------- */
8054 /* XMATRI : Matrix containing NORDRE*NDIMEN solutions. */
8055 /* IERCOD=0 shows that all solutions are calculated. */
8056 /* IERCOD=1 shows that the matrix is of lower rank than NORDRE */
8057 /* (the system is singular). */
8058
8059 /* COMMONS USED : */
8060 /* ---------------- */
8061
8062 /* REFERENCES CALLED : */
8063 /* ----------------------- */
8064
8065 /* DESCRIPTION/NOTES/LIMITATIONS : */
8066 /* ----------------------------------- */
8067 /* ATTENTION : the indices of line and column are inverted */
8068 /* compared to usual indices. */
8069 /* System : */
8070 /* a1*x + b1*y = c1 */
8071 /* a2*x + b2*y = c2 */
8072 /* should be represented by matrix ABMATR : */
8073
8074 /* ABMATR(1,1) = a1 ABMATR(1,2) = a2 */
8075 /* ABMATR(2,1) = b1 ABMATR(2,2) = b2 */
8076 /* ABMATR(3,1) = c1 ABMATR(3,2) = c2 */
8077
8078 /* To solve this system, it is necessary to set : */
8079
8080 /* NORDRE = 2 (there are 2 equations with 2 unknown values), */
8081 /* NDIMEN = 1 (there is only one second member), */
8082 /* any NORMAX can be taken >= NORDRE. */
8083
8084 /* To use this routine, it is recommended to use one of */
8085 /* interfaces : MMRSLWI or MMMRSLWD. */
8086 /* > */
8087 /* **********************************************************************
8088 */
8089
8090 /* Name of the routine */
8091
8092 /* INTEGER IBB,MNFNDEB */
8093
8094 /* IBB=MNFNDEB() */
8095 /* IF (IBB.GE.2) CALL MGENMSG(NOMPR) */
8096 /* Parameter adjustments */
8097 xmatri_dim1 = *normax;
8098 xmatri_offset = xmatri_dim1 + 1;
8099 xmatri -= xmatri_offset;
8100 abmatr_dim1 = *nordre + *ndimen;
8101 abmatr_offset = abmatr_dim1 + 1;
8102 abmatr -= abmatr_offset;
8103
8104 /* Function Body */
8105 *iercod = 0;
8106
8107 /* *********************************************************************
8108 */
8109 /* Triangulation of matrix ABMATR. */
8110 /* *********************************************************************
8111 */
8112
8113 i__1 = *nordre;
8114 for (kk = 1; kk <= i__1; ++kk) {
8115
8116 /* ---------- Find max pivot in column KK. ------------
8117 --- */
8118
8119 pivot = *epspiv;
8120 kpiv = 0;
8121 i__2 = *nordre;
8122 for (jj = kk; jj <= i__2; ++jj) {
8123 akj = (d__1 = abmatr[kk + jj * abmatr_dim1], advapp_abs(d__1));
8124 if (akj > pivot) {
8125 pivot = akj;
8126 kpiv = jj;
8127 }
8128 /* L100: */
8129 }
8130 if (kpiv == 0) {
8131 goto L9900;
8132 }
8133
8134 /* --------- Swapping of line KPIV with line KK. ------
8135 --- */
8136
8137 if (kpiv != kk) {
8138 i__2 = *nordre + *ndimen;
8139 for (jj = kk; jj <= i__2; ++jj) {
8140 akj = abmatr[jj + kk * abmatr_dim1];
8141 abmatr[jj + kk * abmatr_dim1] = abmatr[jj + kpiv *
8142 abmatr_dim1];
8143 abmatr[jj + kpiv * abmatr_dim1] = akj;
8144 /* L200: */
8145 }
8146 }
8147
8148 /* ---------- Removal and triangularization. -----------
8149 --- */
8150
8151 pivot = -abmatr[kk + kk * abmatr_dim1];
8152 i__2 = *nordre;
8153 for (ii = kk + 1; ii <= i__2; ++ii) {
8154 akj = abmatr[kk + ii * abmatr_dim1] / pivot;
8155 i__3 = *nordre + *ndimen;
8156 for (jj = kk + 1; jj <= i__3; ++jj) {
8157 abmatr[jj + ii * abmatr_dim1] += akj * abmatr[jj + kk *
8158 abmatr_dim1];
8159 /* L400: */
8160 }
8161 /* L300: */
8162 }
8163
8164
8165 /* L1000: */
8166 }
8167
8168 /* *********************************************************************
8169 */
8170 /* Solution of the system of triangular equations. */
8171 /* Matrix ABMATR(NORDRE+JJ,II), contains second members */
8172 /* of the system for 1<=j<=NDIMEN and 1<=i<=NORDRE. */
8173 /* *********************************************************************
8174 */
8175
8176
8177 /* ---------------- Calculation of solutions by ascending. -----------------
8178 */
8179
8180 for (kk = *nordre; kk >= 1; --kk) {
8181 pivot = abmatr[kk + kk * abmatr_dim1];
8182 i__1 = *ndimen;
8183 for (ii = 1; ii <= i__1; ++ii) {
8184 akj = abmatr[ii + *nordre + kk * abmatr_dim1];
8185 i__2 = *nordre;
8186 for (jj = kk + 1; jj <= i__2; ++jj) {
8187 akj -= abmatr[jj + kk * abmatr_dim1] * xmatri[jj + ii *
8188 xmatri_dim1];
8189 /* L800: */
8190 }
8191 xmatri[kk + ii * xmatri_dim1] = akj / pivot;
8192 /* L700: */
8193 }
8194 /* L600: */
8195 }
8196 goto L9999;
8197
8198 /* ------If the absolute value of a pivot is smaller than -------- */
8199 /* ---------- EPSPIV: return the code of error. ------------
8200 */
8201
8202 L9900:
8203 *iercod = 1;
8204
8205
8206
8207 L9999:
8208 if (*iercod > 0) {
8209 AdvApp2Var_SysBase::maermsg_("MMRSLW ", iercod, 7L);
8210 }
8211 /* IF (IBB.GE.2) CALL MGSOMSG(NOMPR) */
8212 return 0 ;
8213 } /* mmrslw_ */
8214
8215 //=======================================================================
8216 //function : AdvApp2Var_MathBase::mmmrslwd_
8217 //purpose :
8218 //=======================================================================
mmmrslwd_(integer * normax,integer * nordre,integer * ndim,doublereal * amat,doublereal * bmat,doublereal * epspiv,doublereal * aaux,doublereal * xmat,integer * iercod)8219 int AdvApp2Var_MathBase::mmmrslwd_(integer *normax,
8220 integer *nordre,
8221 integer *ndim,
8222 doublereal *amat,
8223 doublereal *bmat,
8224 doublereal *epspiv,
8225 doublereal *aaux,
8226 doublereal *xmat,
8227 integer *iercod)
8228
8229 {
8230 /* System generated locals */
8231 integer amat_dim1, amat_offset, bmat_dim1, bmat_offset, xmat_dim1,
8232 xmat_offset, aaux_dim1, aaux_offset, i__1, i__2;
8233
8234 /* Local variables */
8235 integer i__, j;
8236 integer ibb;
8237
8238 /* IMPLICIT DOUBLE PRECISION (A-H,O-Z) */
8239 /* IMPLICIT INTEGER (I-N) */
8240
8241
8242 /* **********************************************************************
8243 */
8244
8245 /* FUNCTION : */
8246 /* ---------- */
8247 /* Solution of a linear system by Gauss method where */
8248 /* the second member is a table of vectors. Method of partial pivot. */
8249
8250 /* KEYWORDS : */
8251 /* ----------- */
8252 /* ALL, MATH_ACCES :: */
8253 /* SYSTEME&,EQUATION&, RESOLUTION,GAUSS ,&VECTEUR */
8254
8255 /* INPUT ARGUMENTS : */
8256 /* ------------------ */
8257 /* NORMAX : Max. Dimension of AMAT. */
8258 /* NORDRE : Order of the matrix. */
8259 /* NDIM : Number of columns of BMAT and XMAT. */
8260 /* AMAT(NORMAX,NORDRE) : The processed matrix. */
8261 /* BMAT(NORMAX,NDIM) : The matrix of second member. */
8262 /* XMAT(NORMAX,NDIM) : The matrix of solutions. */
8263 /* EPSPIV : Min value of a pivot. */
8264
8265 /* OUTPUT ARGUMENTS : */
8266 /* ------------------- */
8267 /* AAUX(NORDRE+NDIM,NORDRE) : Auxiliary matrix. */
8268 /* XMAT(NORMAX,NDIM) : Matrix of solutions. */
8269 /* IERCOD=0 shows that solutions in XMAT are valid. */
8270 /* IERCOD=1 shows that matrix AMAT is of lower rank than NORDRE. */
8271
8272 /* COMMONS USED : */
8273 /* ---------------- */
8274
8275 /* .Neant. */
8276
8277 /* REFERENCES CALLED : */
8278 /* ---------------------- */
8279 /* Type Name */
8280 /* MAERMSG MGENMSG MGSOMSG */
8281 /* MMRSLW I*4 MNFNDEB */
8282
8283 /* DESCRIPTION/NOTES/LIMITATIONS : */
8284 /* ----------------------------------- */
8285 /* ATTENTION : lines and columns are located in usual order : */
8286 /* 1st index = index line */
8287 /* 2nd index = index column */
8288 /* Example, the system : */
8289 /* a1*x + b1*y = c1 */
8290 /* a2*x + b2*y = c2 */
8291 /* is represented by matrix AMAT : */
8292
8293 /* AMAT(1,1) = a1 AMAT(2,1) = a2 */
8294 /* AMAT(1,2) = b1 AMAT(2,2) = b2 */
8295
8296 /* The first index is the index of line, the second index */
8297 /* is the index of columns (Compare with MMRSLWI which is faster). */
8298
8299 /* > */
8300 /* **********************************************************************
8301 */
8302
8303 /* Name of the routine */
8304
8305 /* Parameter adjustments */
8306 amat_dim1 = *normax;
8307 amat_offset = amat_dim1 + 1;
8308 amat -= amat_offset;
8309 xmat_dim1 = *normax;
8310 xmat_offset = xmat_dim1 + 1;
8311 xmat -= xmat_offset;
8312 aaux_dim1 = *nordre + *ndim;
8313 aaux_offset = aaux_dim1 + 1;
8314 aaux -= aaux_offset;
8315 bmat_dim1 = *normax;
8316 bmat_offset = bmat_dim1 + 1;
8317 bmat -= bmat_offset;
8318
8319 /* Function Body */
8320 ibb = AdvApp2Var_SysBase::mnfndeb_();
8321 if (ibb >= 3) {
8322 AdvApp2Var_SysBase::mgenmsg_("MMMRSLW", 7L);
8323 }
8324
8325 /* Initialization of the auxiliary matrix. */
8326
8327 i__1 = *nordre;
8328 for (i__ = 1; i__ <= i__1; ++i__) {
8329 i__2 = *nordre;
8330 for (j = 1; j <= i__2; ++j) {
8331 aaux[j + i__ * aaux_dim1] = amat[i__ + j * amat_dim1];
8332 /* L200: */
8333 }
8334 /* L100: */
8335 }
8336
8337 /* Second member. */
8338
8339 i__1 = *nordre;
8340 for (i__ = 1; i__ <= i__1; ++i__) {
8341 i__2 = *ndim;
8342 for (j = 1; j <= i__2; ++j) {
8343 aaux[j + *nordre + i__ * aaux_dim1] = bmat[i__ + j * bmat_dim1];
8344 /* L400: */
8345 }
8346 /* L300: */
8347 }
8348
8349 /* Solution of the system of equations. */
8350
8351 mmrslw_(normax, nordre, ndim, epspiv, &aaux[aaux_offset], &xmat[
8352 xmat_offset], iercod);
8353
8354
8355 if (*iercod != 0) {
8356 AdvApp2Var_SysBase::maermsg_("MMMRSLW", iercod, 7L);
8357 }
8358 if (ibb >= 3) {
8359 AdvApp2Var_SysBase::mgsomsg_("MMMRSLW", 7L);
8360 }
8361 return 0 ;
8362 } /* mmmrslwd_ */
8363
8364 //=======================================================================
8365 //function : AdvApp2Var_MathBase::mmrtptt_
8366 //purpose :
8367 //=======================================================================
mmrtptt_(integer * ndglgd,doublereal * rtlegd)8368 int AdvApp2Var_MathBase::mmrtptt_(integer *ndglgd,
8369 doublereal *rtlegd)
8370
8371 {
8372 integer ideb, nmod2, nsur2, ilong, ibb;
8373
8374
8375 /* **********************************************************************
8376 */
8377
8378 /* FUNCTION : */
8379 /* ---------- */
8380 /* Extracts from Common LDGRTL the STRICTLY positive roots of the */
8381 /* Legendre polynom of degree NDGLGD, for 2 <= NDGLGD <= 61. */
8382
8383 /* KEYWORDS : */
8384 /* ----------- */
8385 /* TOUS, AB_SPECIFI::COMMON&, EXTRACTION, &RACINE, &LEGENDRE. */
8386
8387 /* INPUT ARGUMENTS : */
8388 /* ------------------ */
8389 /* NDGLGD : Mathematic degree of Legendre polynom. */
8390 /* This degree should be above or equal to 2 and */
8391 /* below or equal to 61. */
8392
8393 /* OUTPUT ARGUMENTS : */
8394 /* ------------------- */
8395 /* RTLEGD : The table of strictly positive roots of */
8396 /* Legendre polynom of degree NDGLGD. */
8397
8398 /* COMMONS USED : */
8399 /* ---------------- */
8400
8401 /* REFERENCES CALLED : */
8402 /* ----------------------- */
8403
8404 /* DESCRIPTION/NOTES/LIMITATIONS : */
8405 /* ----------------------------------- */
8406 /* ATTENTION: the condition on NDEGRE ( 2 <= NDEGRE <= 61) is not */
8407 /* tested. The caller should make the test. */
8408
8409 /* > */
8410 /* **********************************************************************
8411 */
8412 /* Nome of the routine */
8413
8414
8415 /* Common MLGDRTL: */
8416 /* This common includes POSITIVE roots of Legendre polynoms */
8417 /* AND the weight of Gauss quadrature formulas on all */
8418 /* POSITIVE roots of Legendre polynoms. */
8419
8420
8421 /* ***********************************************************************
8422 */
8423
8424 /* FUNCTION : */
8425 /* ---------- */
8426 /* The common of Legendre roots. */
8427
8428 /* KEYWORDS : */
8429 /* ----------- */
8430 /* BASE LEGENDRE */
8431
8432 /* DEMSCRIPTION/NOTES/LIMITATIONS : */
8433 /* ----------------------------------- */
8434
8435 /* > */
8436 /* ***********************************************************************
8437 */
8438
8439
8440
8441
8442 /* ROOTAB : Table of all rotts of Legendre polynoms */
8443 /* between [0,1]. They are ranked for degrees increasing from 2 to 61. */
8444 /* HILTAB : Table of Legendre interpolators concerning ROOTAB. */
8445 /* The address is the same. */
8446 /* HI0TAB : Table of Legendre interpolators for root x=0 */
8447 /* the polynoms of UNEVEN degree. */
8448 /* RTLTB0 : Table of Li(uk) where uk are roots of a */
8449 /* Legendre polynom of EVEN degree. */
8450 /* RTLTB1 : Table of Li(uk) where uk are roots of a */
8451 /* Legendre polynom of UNEVEN degree. */
8452
8453
8454 /************************************************************************
8455 *****/
8456 /* Parameter adjustments */
8457 --rtlegd;
8458
8459 /* Function Body */
8460 ibb = AdvApp2Var_SysBase::mnfndeb_();
8461 if (ibb >= 3) {
8462 AdvApp2Var_SysBase::mgenmsg_("MMRTPTT", 7L);
8463 }
8464 if (*ndglgd < 2) {
8465 goto L9999;
8466 }
8467
8468 nsur2 = *ndglgd / 2;
8469 nmod2 = *ndglgd % 2;
8470
8471 ilong = nsur2 << 3;
8472 ideb = nsur2 * (nsur2 - 1) / 2 + 1;
8473 AdvApp2Var_SysBase::mcrfill_(&ilong,
8474 &mlgdrtl_.rootab[ideb + nmod2 * 465 - 1],
8475 &rtlegd[1]);
8476
8477 /* ----------------------------- The end --------------------------------
8478 */
8479
8480 L9999:
8481 if (ibb >= 3) {
8482 AdvApp2Var_SysBase::mgsomsg_("MMRTPTT", 7L);
8483 }
8484 return 0;
8485 } /* mmrtptt_ */
8486
8487 //=======================================================================
8488 //function : AdvApp2Var_MathBase::mmsrre2_
8489 //purpose :
8490 //=======================================================================
mmsrre2_(doublereal * tparam,integer * nbrval,doublereal * tablev,doublereal * epsil,integer * numint,integer * itypen,integer * iercod)8491 int AdvApp2Var_MathBase::mmsrre2_(doublereal *tparam,
8492 integer *nbrval,
8493 doublereal *tablev,
8494 doublereal *epsil,
8495 integer *numint,
8496 integer *itypen,
8497 integer *iercod)
8498 {
8499 /* System generated locals */
8500 doublereal d__1;
8501
8502 /* Local variables */
8503 integer ideb, ifin, imil, ibb;
8504
8505 /* ***********************************************************************
8506 */
8507
8508 /* FUNCTION : */
8509 /* -------- */
8510
8511 /* Find the interval corresponding to a valueb given in */
8512 /* increasing order of real numbers with double precision. */
8513
8514 /* KEYWORDS : */
8515 /* --------- */
8516 /* TOUS,MATH_ACCES::TABLEAU&,POINT&,CORRESPONDANCE,&RANG */
8517
8518 /* INPUT ARGUMENTS : */
8519 /* ------------------ */
8520
8521 /* TPARAM : Value to be tested. */
8522 /* NBRVAL : Size of TABLEV */
8523 /* TABLEV : Table of reals. */
8524 /* EPSIL : Epsilon of precision */
8525
8526 /* OUTPUT ARGUMENTS : */
8527 /* ------------------- */
8528
8529 /* NUMINT : Number of the interval (between 1 and NBRVAL-1). */
8530 /* ITYPEN : = 0 TPARAM is inside the interval NUMINT */
8531 /* = 1 : TPARAM corresponds to the lower limit of */
8532 /* the provided interval. */
8533 /* = 2 : TPARAM corresponds to the upper limit of */
8534 /* the provided interval. */
8535
8536 /* IERCOD : Error code. */
8537 /* = 0 : OK */
8538 /* = 1 : TABLEV does not contain enough elements. */
8539 /* = 2 : TPARAM out of limits of TABLEV. */
8540
8541 /* COMMONS USED : */
8542 /* ---------------- */
8543
8544 /* REFERENCES CALLED : */
8545 /* ------------------- */
8546
8547 /* DESCRIPTION/NOTES/LIMITATIONS : */
8548 /* --------------------------------- */
8549 /* There are NBRVAL values in TABLEV which stands for NBRVAL-1 intervals. */
8550 /* One searches the interval containing TPARAM by */
8551 /* dichotomy. Complexity of the algorithm : Log(n)/Log(2).(RBD). */
8552 /* > */
8553 /* ***********************************************************************
8554 */
8555
8556
8557 /* Initialisations */
8558
8559 /* Parameter adjustments */
8560 --tablev;
8561
8562 /* Function Body */
8563 ibb = AdvApp2Var_SysBase::mnfndeb_();
8564 if (ibb >= 6) {
8565 AdvApp2Var_SysBase::mgenmsg_("MMSRRE2", 7L);
8566 }
8567
8568 *iercod = 0;
8569 *numint = 0;
8570 *itypen = 0;
8571 ideb = 1;
8572 ifin = *nbrval;
8573
8574 /* TABLEV should contain at least two values */
8575
8576 if (*nbrval < 2) {
8577 *iercod = 1;
8578 goto L9999;
8579 }
8580
8581 /* TPARAM should be between extreme limits of TABLEV. */
8582
8583 if (*tparam < tablev[1] || *tparam > tablev[*nbrval]) {
8584 *iercod = 2;
8585 goto L9999;
8586 }
8587
8588 /* ----------------------- SEARCH OF THE INTERVAL --------------------
8589 */
8590
8591 L1000:
8592
8593 /* Test end of loop (found). */
8594
8595 if (ideb + 1 == ifin) {
8596 *numint = ideb;
8597 goto L2000;
8598 }
8599
8600 /* Find by dichotomy on increasing values of TABLEV. */
8601
8602 imil = (ideb + ifin) / 2;
8603 if (*tparam >= tablev[ideb] && *tparam <= tablev[imil]) {
8604 ifin = imil;
8605 } else {
8606 ideb = imil;
8607 }
8608
8609 goto L1000;
8610
8611 /* -------------- TEST IF TPARAM IS NOT A VALUE --------- */
8612 /* ------------------------OF TABLEV UP TO EPSIL ----------------------
8613 */
8614
8615 L2000:
8616 if ((d__1 = *tparam - tablev[ideb], advapp_abs(d__1)) < *epsil) {
8617 *itypen = 1;
8618 goto L9999;
8619 }
8620 if ((d__1 = *tparam - tablev[ifin], advapp_abs(d__1)) < *epsil) {
8621 *itypen = 2;
8622 goto L9999;
8623 }
8624
8625 /* --------------------------- THE END ----------------------------------
8626 */
8627
8628 L9999:
8629 if (*iercod > 0) {
8630 AdvApp2Var_SysBase::maermsg_("MMSRRE2", iercod, 7L);
8631 }
8632 if (ibb >= 6) {
8633 AdvApp2Var_SysBase::mgsomsg_("MMSRRE2", 7L);
8634 }
8635 return 0 ;
8636 } /* mmsrre2_ */
8637
8638 //=======================================================================
8639 //function : mmtmave_
8640 //purpose :
8641 //=======================================================================
mmtmave_(integer * nligne,integer * ncolon,integer * gposit,integer *,doublereal * gmatri,doublereal * vecin,doublereal * vecout,integer * iercod)8642 int mmtmave_(integer *nligne,
8643 integer *ncolon,
8644 integer *gposit,
8645 integer *,//gnstoc,
8646 doublereal *gmatri,
8647 doublereal *vecin,
8648 doublereal *vecout,
8649 integer *iercod)
8650
8651 {
8652 /* System generated locals */
8653 integer i__1, i__2;
8654
8655 /* Local variables */
8656 logical ldbg;
8657 integer imin, imax, i__, j, k;
8658 doublereal somme;
8659 integer aux;
8660
8661
8662 /* ***********************************************************************
8663 */
8664
8665 /* FUNCTION : */
8666 /* ---------- */
8667 /* t */
8668 /* CREATES PRODUCT G V */
8669 /* WHERE THE MATRIX IS IN FORM OF PROFILE */
8670
8671 /* KEYWORDS : */
8672 /* ----------- */
8673 /* RESERVE, PRODUCT, MATRIX, PROFILE, VECTOR */
8674
8675 /* INPUT ARGUMENTS : */
8676 /* -------------------- */
8677 /* NLIGNE : NUMBER OF LINE OF THE MATRIX */
8678 /* NCOLON : NOMBER OF COLUMN OF THE MATRIX */
8679 /* GPOSIT: TABLE OF POSITIONING OF TERMS OF STORAGE */
8680 /* GPOSIT(1,I) CONTAINS THE NUMBER of TERMS-1 ON LINE */
8681 /* I IN THE PROFILE OF THE MATRIX */
8682 /* GPOSIT(2,I) CONTAINS THE INDEX OF STORAGE OF THE DIAGONAL TERM*/
8683 /* OF LINE I */
8684 /* GPOSIT(3,I) CONTAINS THE INDEX COLUMN OF THE FIRST TERM OF */
8685 /* PROFILE OF LINE I */
8686 /* GNSTOC : NOMBER OF TERM IN THE PROFILE OF GMATRI */
8687 /* GMATRI : MATRIX OF CONSTRAINTS IN FORM OF PROFILE */
8688 /* VECIN : INPUT VECTOR */
8689
8690 /* OUTPUT ARGUMENTS : */
8691 /* --------------------- */
8692 /* VECOUT : VECTOR PRODUCT */
8693 /* IERCOD : ERROR CODE */
8694
8695
8696 /* COMMONS USED : */
8697 /* ------------------ */
8698
8699
8700 /* REFERENCES CALLED : */
8701 /* --------------------- */
8702
8703
8704 /* DESCRIPTION/NOTES/LIMITATIONS : */
8705 /* ----------------------------------- */
8706 /* > */
8707 /* ***********************************************************************
8708 */
8709 /* DECLARATIONS */
8710 /* ***********************************************************************
8711 */
8712
8713
8714
8715 /* ***********************************************************************
8716 */
8717 /* INITIALISATIONS */
8718 /* ***********************************************************************
8719 */
8720
8721 /* Parameter adjustments */
8722 --vecin;
8723 gposit -= 4;
8724 --vecout;
8725 --gmatri;
8726
8727 /* Function Body */
8728 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 2;
8729 if (ldbg) {
8730 AdvApp2Var_SysBase::mgenmsg_("MMTMAVE", 7L);
8731 }
8732 *iercod = 0;
8733
8734 /* ***********************************************************************
8735 */
8736 /* PROCESSING */
8737 /* ***********************************************************************
8738 */
8739
8740
8741
8742 i__1 = *ncolon;
8743 for (i__ = 1; i__ <= i__1; ++i__) {
8744 somme = 0.;
8745 i__2 = *nligne;
8746 for (j = 1; j <= i__2; ++j) {
8747 imin = gposit[j * 3 + 3];
8748 imax = gposit[j * 3 + 1] + gposit[j * 3 + 3] - 1;
8749 aux = gposit[j * 3 + 2] - gposit[j * 3 + 1] - imin + 1;
8750 if (imin <= i__ && i__ <= imax) {
8751 k = i__ + aux;
8752 somme += gmatri[k] * vecin[j];
8753 }
8754 }
8755 vecout[i__] = somme;
8756 }
8757
8758
8759
8760
8761
8762 goto L9999;
8763
8764 /* ***********************************************************************
8765 */
8766 /* ERROR PROCESSING */
8767 /* ***********************************************************************
8768 */
8769
8770
8771 /* ***********************************************************************
8772 */
8773 /* RETURN CALLING PROGRAM */
8774 /* ***********************************************************************
8775 */
8776
8777 L9999:
8778
8779 /* ___ DESALLOCATION, ... */
8780
8781 AdvApp2Var_SysBase::maermsg_("MMTMAVE", iercod, 7L);
8782 if (ldbg) {
8783 AdvApp2Var_SysBase::mgsomsg_("MMTMAVE", 7L);
8784 }
8785 return 0 ;
8786 } /* mmtmave_ */
8787
8788 //=======================================================================
8789 //function : mmtrpj0_
8790 //purpose :
8791 //=======================================================================
mmtrpj0_(integer * ncofmx,integer * ndimen,integer * ncoeff,doublereal * epsi3d,doublereal * crvlgd,doublereal * ycvmax,doublereal * epstrc,integer * ncfnew)8792 int mmtrpj0_(integer *ncofmx,
8793 integer *ndimen,
8794 integer *ncoeff,
8795 doublereal *epsi3d,
8796 doublereal *crvlgd,
8797 doublereal *ycvmax,
8798 doublereal *epstrc,
8799 integer *ncfnew)
8800
8801 {
8802 /* System generated locals */
8803 integer crvlgd_dim1, crvlgd_offset, i__1, i__2;
8804 doublereal d__1;
8805
8806 /* Local variables */
8807 integer ncut, i__;
8808 doublereal bidon, error;
8809 integer nd;
8810
8811
8812 /* ***********************************************************************
8813 */
8814
8815 /* FUNCTION : */
8816 /* ---------- */
8817 /* Lowers the degree of a curve defined on (-1,1) in the direction of */
8818 /* Legendre with a given precision. */
8819
8820 /* KEYWORDS : */
8821 /* ----------- */
8822 /* LEGENDRE, POLYGON, TRUNCATION, CURVE, SMOOTHING. */
8823
8824 /* INPUT ARGUMENTS : */
8825 /* ------------------ */
8826 /* NCOFMX : Max Nb of coeff. of the curve (dimensioning). */
8827 /* NDIMEN : Dimension of the space. */
8828 /* NCOEFF : Degree +1 of the polynom. */
8829 /* EPSI3D : Precision required for the approximation. */
8830 /* CRVLGD : The curve the degree which of it is required to lower. */
8831
8832 /* OUTPUT ARGUMENTS : */
8833 /* ------------------- */
8834 /* EPSTRC : Precision of the approximation. */
8835 /* NCFNEW : Degree +1 of the resulting polynom. */
8836
8837 /* COMMONS USED : */
8838 /* ---------------- */
8839
8840 /* REFERENCES CALLED : */
8841 /* ----------------------- */
8842
8843 /* DESCRIPTION/NOTES/LIMITATIONS : */
8844 /* ----------------------------------- */
8845 /* > */
8846 /* ***********************************************************************
8847 */
8848
8849
8850 /* ------- Minimum degree that can be attained : Stop at 1 (RBD) ---------
8851 */
8852
8853 /* Parameter adjustments */
8854 --ycvmax;
8855 crvlgd_dim1 = *ncofmx;
8856 crvlgd_offset = crvlgd_dim1 + 1;
8857 crvlgd -= crvlgd_offset;
8858
8859 /* Function Body */
8860 *ncfnew = 1;
8861 /* ------------------- Init for error calculation -----------------------
8862 */
8863 i__1 = *ndimen;
8864 for (i__ = 1; i__ <= i__1; ++i__) {
8865 ycvmax[i__] = 0.;
8866 /* L100: */
8867 }
8868 *epstrc = 0.;
8869 error = 0.;
8870
8871 /* Cutting of coefficients. */
8872
8873 ncut = 2;
8874 /* ------ Loop on the series of Legendre :NCOEFF --> 2 (RBD) -----------
8875 */
8876 i__1 = ncut;
8877 for (i__ = *ncoeff; i__ >= i__1; --i__) {
8878 /* Factor of renormalization. */
8879 bidon = ((i__ - 1) * 2. + 1.) / 2.;
8880 bidon = sqrt(bidon);
8881 i__2 = *ndimen;
8882 for (nd = 1; nd <= i__2; ++nd) {
8883 ycvmax[nd] += (d__1 = crvlgd[i__ + nd * crvlgd_dim1], advapp_abs(d__1)) *
8884 bidon;
8885 /* L310: */
8886 }
8887 /* Cutting is stopped if the norm becomes too great. */
8888 error = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
8889 if (error > *epsi3d) {
8890 *ncfnew = i__;
8891 goto L9999;
8892 }
8893
8894 /* --- Max error cumulee when the I-th coeff is removed. */
8895
8896 *epstrc = error;
8897
8898 /* L300: */
8899 }
8900
8901 /* --------------------------------- End --------------------------------
8902 */
8903
8904 L9999:
8905 return 0;
8906 } /* mmtrpj0_ */
8907
8908 //=======================================================================
8909 //function : mmtrpj2_
8910 //purpose :
8911 //=======================================================================
mmtrpj2_(integer * ncofmx,integer * ndimen,integer * ncoeff,doublereal * epsi3d,doublereal * crvlgd,doublereal * ycvmax,doublereal * epstrc,integer * ncfnew)8912 int mmtrpj2_(integer *ncofmx,
8913 integer *ndimen,
8914 integer *ncoeff,
8915 doublereal *epsi3d,
8916 doublereal *crvlgd,
8917 doublereal *ycvmax,
8918 doublereal *epstrc,
8919 integer *ncfnew)
8920
8921 {
8922 /* Initialized data */
8923
8924 static doublereal xmaxj[57] = { .9682458365518542212948163499456,
8925 .986013297183269340427888048593603,
8926 1.07810420343739860362585159028115,
8927 1.17325804490920057010925920756025,
8928 1.26476561266905634732910520370741,
8929 1.35169950227289626684434056681946,
8930 1.43424378958284137759129885012494,
8931 1.51281316274895465689402798226634,
8932 1.5878364329591908800533936587012,
8933 1.65970112228228167018443636171226,
8934 1.72874345388622461848433443013543,
8935 1.7952515611463877544077632304216,
8936 1.85947199025328260370244491818047,
8937 1.92161634324190018916351663207101,
8938 1.98186713586472025397859895825157,
8939 2.04038269834980146276967984252188,
8940 2.09730119173852573441223706382076,
8941 2.15274387655763462685970799663412,
8942 2.20681777186342079455059961912859,
8943 2.25961782459354604684402726624239,
8944 2.31122868752403808176824020121524,
8945 2.36172618435386566570998793688131,
8946 2.41117852396114589446497298177554,
8947 2.45964731268663657873849811095449,
8948 2.50718840313973523778244737914028,
8949 2.55385260994795361951813645784034,
8950 2.59968631659221867834697883938297,
8951 2.64473199258285846332860663371298,
8952 2.68902863641518586789566216064557,
8953 2.73261215675199397407027673053895,
8954 2.77551570192374483822124304745691,
8955 2.8177699459714315371037628127545,
8956 2.85940333797200948896046563785957,
8957 2.90044232019793636101516293333324,
8958 2.94091151970640874812265419871976,
8959 2.98083391718088702956696303389061,
8960 3.02023099621926980436221568258656,
8961 3.05912287574998661724731962377847,
8962 3.09752842783622025614245706196447,
8963 3.13546538278134559341444834866301,
8964 3.17295042316122606504398054547289,
8965 3.2099992681699613513775259670214,
8966 3.24662674946606137764916854570219,
8967 3.28284687953866689817670991319787,
8968 3.31867291347259485044591136879087,
8969 3.35411740487202127264475726990106,
8970 3.38919225660177218727305224515862,
8971 3.42390876691942143189170489271753,
8972 3.45827767149820230182596660024454,
8973 3.49230918177808483937957161007792,
8974 3.5260130200285724149540352829756,
8975 3.55939845146044235497103883695448,
8976 3.59247431368364585025958062194665,
8977 3.62524904377393592090180712976368,
8978 3.65773070318071087226169680450936,
8979 3.68992700068237648299565823810245,
8980 3.72184531357268220291630708234186 };
8981
8982 /* System generated locals */
8983 integer crvlgd_dim1, crvlgd_offset, i__1, i__2;
8984 doublereal d__1;
8985
8986 /* Local variables */
8987 integer ncut, i__;
8988 doublereal bidon, error;
8989 integer ia, nd;
8990 doublereal bid, eps1;
8991
8992
8993 /* ***********************************************************************
8994 */
8995
8996 /* FUNCTION : */
8997 /* ---------- */
8998 /* Lower the degree of a curve defined on (-1,1) in the direction of */
8999 /* Legendre with a given precision. */
9000
9001 /* KEYWORDS : */
9002 /* ----------- */
9003 /* LEGENDRE, POLYGON, TRUNCATION, CURVE, SMOOTHING. */
9004
9005 /* INPUT ARGUMENTS : */
9006 /* ------------------ */
9007 /* NCOFMX : Max nb of coeff. of the curve (dimensioning). */
9008 /* NDIMEN : Dimension of the space. */
9009 /* NCOEFF : Degree +1 of the polynom. */
9010 /* EPSI3D : Precision required for the approximation. */
9011 /* CRVLGD : The curve the degree which of will be lowered. */
9012
9013 /* OUTPUT ARGUMENTS : */
9014 /* ------------------- */
9015 /* YCVMAX : Auxiliary table (error max on each dimension).
9016 */
9017 /* EPSTRC : Precision of the approximation. */
9018 /* NCFNEW : Degree +1 of the resulting polynom. */
9019
9020 /* COMMONS USED : */
9021 /* ---------------- */
9022
9023 /* REFERENCES CALLED : */
9024 /* ----------------------- */
9025
9026 /* DESCRIPTION/NOTES/LIMITATIONS : */
9027 /* ----------------------------------- */
9028 /* > */
9029 /* ***********************************************************************
9030 */
9031
9032
9033 /* Parameter adjustments */
9034 --ycvmax;
9035 crvlgd_dim1 = *ncofmx;
9036 crvlgd_offset = crvlgd_dim1 + 1;
9037 crvlgd -= crvlgd_offset;
9038
9039 /* Function Body */
9040
9041
9042
9043 /* Minimum degree that can be reached : Stop at IA (RBD). -------------
9044 */
9045 ia = 2;
9046 *ncfnew = ia;
9047 /* Init for calculation of error. */
9048 i__1 = *ndimen;
9049 for (i__ = 1; i__ <= i__1; ++i__) {
9050 ycvmax[i__] = 0.;
9051 /* L100: */
9052 }
9053 *epstrc = 0.;
9054 error = 0.;
9055
9056 /* Cutting of coefficients. */
9057
9058 ncut = ia + 1;
9059 /* ------ Loop on the series of Jacobi :NCOEFF --> IA+1 (RBD) ----------
9060 */
9061 i__1 = ncut;
9062 for (i__ = *ncoeff; i__ >= i__1; --i__) {
9063 /* Factor of renormalization. */
9064 bidon = xmaxj[i__ - ncut];
9065 i__2 = *ndimen;
9066 for (nd = 1; nd <= i__2; ++nd) {
9067 ycvmax[nd] += (d__1 = crvlgd[i__ + nd * crvlgd_dim1], advapp_abs(d__1)) *
9068 bidon;
9069 /* L310: */
9070 }
9071 /* One stops to cut if the norm becomes too great. */
9072 error = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
9073 if (error > *epsi3d) {
9074 *ncfnew = i__;
9075 goto L400;
9076 }
9077
9078 /* --- Max error cumulated when the I-th coeff is removed. */
9079
9080 *epstrc = error;
9081
9082 /* L300: */
9083 }
9084
9085 /* ------- Cutting of zero coeffs of interpolation (RBD) -------
9086 */
9087
9088 L400:
9089 if (*ncfnew == ia) {
9090 AdvApp2Var_MathBase::mmeps1_(&eps1);
9091 for (i__ = ia; i__ >= 2; --i__) {
9092 bid = 0.;
9093 i__1 = *ndimen;
9094 for (nd = 1; nd <= i__1; ++nd) {
9095 bid += (d__1 = crvlgd[i__ + nd * crvlgd_dim1], advapp_abs(d__1));
9096 /* L600: */
9097 }
9098 if (bid > eps1) {
9099 *ncfnew = i__;
9100 goto L9999;
9101 }
9102 /* L500: */
9103 }
9104 /* --- If all coeffs can be removed, this is a point. */
9105 *ncfnew = 1;
9106 }
9107
9108 /* --------------------------------- End --------------------------------
9109 */
9110
9111 L9999:
9112 return 0;
9113 } /* mmtrpj2_ */
9114
9115 //=======================================================================
9116 //function : mmtrpj4_
9117 //purpose :
9118 //=======================================================================
mmtrpj4_(integer * ncofmx,integer * ndimen,integer * ncoeff,doublereal * epsi3d,doublereal * crvlgd,doublereal * ycvmax,doublereal * epstrc,integer * ncfnew)9119 int mmtrpj4_(integer *ncofmx,
9120 integer *ndimen,
9121 integer *ncoeff,
9122 doublereal *epsi3d,
9123 doublereal *crvlgd,
9124 doublereal *ycvmax,
9125 doublereal *epstrc,
9126 integer *ncfnew)
9127 {
9128 /* Initialized data */
9129
9130 static doublereal xmaxj[55] = { 1.1092649593311780079813740546678,
9131 1.05299572648705464724876659688996,
9132 1.0949715351434178709281698645813,
9133 1.15078388379719068145021100764647,
9134 1.2094863084718701596278219811869,
9135 1.26806623151369531323304177532868,
9136 1.32549784426476978866302826176202,
9137 1.38142537365039019558329304432581,
9138 1.43575531950773585146867625840552,
9139 1.48850442653629641402403231015299,
9140 1.53973611681876234549146350844736,
9141 1.58953193485272191557448229046492,
9142 1.63797820416306624705258190017418,
9143 1.68515974143594899185621942934906,
9144 1.73115699602477936547107755854868,
9145 1.77604489805513552087086912113251,
9146 1.81989256661534438347398400420601,
9147 1.86276344480103110090865609776681,
9148 1.90471563564740808542244678597105,
9149 1.94580231994751044968731427898046,
9150 1.98607219357764450634552790950067,
9151 2.02556989246317857340333585562678,
9152 2.06433638992049685189059517340452,
9153 2.10240936014742726236706004607473,
9154 2.13982350649113222745523925190532,
9155 2.17661085564771614285379929798896,
9156 2.21280102016879766322589373557048,
9157 2.2484214321456956597803794333791,
9158 2.28349755104077956674135810027654,
9159 2.31805304852593774867640120860446,
9160 2.35210997297725685169643559615022,
9161 2.38568889602346315560143377261814,
9162 2.41880904328694215730192284109322,
9163 2.45148841120796359750021227795539,
9164 2.48374387161372199992570528025315,
9165 2.5155912654873773953959098501893,
9166 2.54704548720896557684101746505398,
9167 2.57812056037881628390134077704127,
9168 2.60882970619319538196517982945269,
9169 2.63918540521920497868347679257107,
9170 2.66919945330942891495458446613851,
9171 2.69888301230439621709803756505788,
9172 2.72824665609081486737132853370048,
9173 2.75730041251405791603760003778285,
9174 2.78605380158311346185098508516203,
9175 2.81451587035387403267676338931454,
9176 2.84269522483114290814009184272637,
9177 2.87060005919012917988363332454033,
9178 2.89823818258367657739520912946934,
9179 2.92561704377132528239806135133273,
9180 2.95274375377994262301217318010209,
9181 2.97962510678256471794289060402033,
9182 3.00626759936182712291041810228171,
9183 3.03267744830655121818899164295959,
9184 3.05886060707437081434964933864149 };
9185
9186 /* System generated locals */
9187 integer crvlgd_dim1, crvlgd_offset, i__1, i__2;
9188 doublereal d__1;
9189
9190 /* Local variables */
9191 integer ncut, i__;
9192 doublereal bidon, error;
9193 integer ia, nd;
9194 doublereal bid, eps1;
9195
9196
9197
9198 /* ***********************************************************************
9199 */
9200
9201 /* FUNCTION : */
9202 /* ---------- */
9203 /* Lowers the degree of a curve defined on (-1,1) in the direction of */
9204 /* Legendre with a given precision. */
9205
9206 /* KEYWORDS : */
9207 /* ----------- */
9208 /* LEGENDRE, POLYGON, TRONCATION, CURVE, SMOOTHING. */
9209
9210 /* INPUT ARGUMENTS : */
9211 /* ------------------ */
9212 /* NCOFMX : Max nb of coeff. of the curve (dimensioning). */
9213 /* NDIMEN : Dimension of the space. */
9214 /* NCOEFF : Degree +1 of the polynom. */
9215 /* EPSI3D : Precision required for the approximation. */
9216 /* CRVLGD : The curve which wishes to lower the degree. */
9217
9218 /* OUTPUT ARGUMENTS : */
9219 /* ------------------- */
9220 /* YCVMAX : Auxiliary table (max error on each dimension).
9221 */
9222 /* EPSTRC : Precision of the approximation. */
9223 /* NCFNEW : Degree +1 of the resulting polynom. */
9224
9225 /* COMMONS USED : */
9226 /* ---------------- */
9227
9228 /* REFERENCES CALLED : */
9229 /* ----------------------- */
9230
9231 /* DESCRIPTION/NOTES/LIMITATIONS : */
9232 /* ----------------------------------- */
9233 /* > */
9234 /* ***********************************************************************
9235 */
9236
9237
9238 /* Parameter adjustments */
9239 --ycvmax;
9240 crvlgd_dim1 = *ncofmx;
9241 crvlgd_offset = crvlgd_dim1 + 1;
9242 crvlgd -= crvlgd_offset;
9243
9244 /* Function Body */
9245
9246
9247
9248 /* Minimum degree that can be reached : Stop at IA (RBD). -------------
9249 */
9250 ia = 4;
9251 *ncfnew = ia;
9252 /* Init for error calculation. */
9253 i__1 = *ndimen;
9254 for (i__ = 1; i__ <= i__1; ++i__) {
9255 ycvmax[i__] = 0.;
9256 /* L100: */
9257 }
9258 *epstrc = 0.;
9259 error = 0.;
9260
9261 /* Cutting of coefficients. */
9262
9263 ncut = ia + 1;
9264 /* ------ Loop on the series of Jacobi :NCOEFF --> IA+1 (RBD) ----------
9265 */
9266 i__1 = ncut;
9267 for (i__ = *ncoeff; i__ >= i__1; --i__) {
9268 /* Factor of renormalization. */
9269 bidon = xmaxj[i__ - ncut];
9270 i__2 = *ndimen;
9271 for (nd = 1; nd <= i__2; ++nd) {
9272 ycvmax[nd] += (d__1 = crvlgd[i__ + nd * crvlgd_dim1], advapp_abs(d__1)) *
9273 bidon;
9274 /* L310: */
9275 }
9276 /* Stop cutting if the norm becomes too great. */
9277 error = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
9278 if (error > *epsi3d) {
9279 *ncfnew = i__;
9280 goto L400;
9281 }
9282
9283 /* -- Error max cumulated when the I-eme coeff is removed. */
9284
9285 *epstrc = error;
9286
9287 /* L300: */
9288 }
9289
9290 /* ------- Cutting of zero coeffs of the pole of interpolation (RBD) -------
9291 */
9292
9293 L400:
9294 if (*ncfnew == ia) {
9295 AdvApp2Var_MathBase::mmeps1_(&eps1);
9296 for (i__ = ia; i__ >= 2; --i__) {
9297 bid = 0.;
9298 i__1 = *ndimen;
9299 for (nd = 1; nd <= i__1; ++nd) {
9300 bid += (d__1 = crvlgd[i__ + nd * crvlgd_dim1], advapp_abs(d__1));
9301 /* L600: */
9302 }
9303 if (bid > eps1) {
9304 *ncfnew = i__;
9305 goto L9999;
9306 }
9307 /* L500: */
9308 }
9309 /* --- If all coeffs can be removed, this is a point. */
9310 *ncfnew = 1;
9311 }
9312
9313 /* --------------------------------- End --------------------------------
9314 */
9315
9316 L9999:
9317 return 0;
9318 } /* mmtrpj4_ */
9319
9320 //=======================================================================
9321 //function : mmtrpj6_
9322 //purpose :
9323 //=======================================================================
mmtrpj6_(integer * ncofmx,integer * ndimen,integer * ncoeff,doublereal * epsi3d,doublereal * crvlgd,doublereal * ycvmax,doublereal * epstrc,integer * ncfnew)9324 int mmtrpj6_(integer *ncofmx,
9325 integer *ndimen,
9326 integer *ncoeff,
9327 doublereal *epsi3d,
9328 doublereal *crvlgd,
9329 doublereal *ycvmax,
9330 doublereal *epstrc,
9331 integer *ncfnew)
9332
9333 {
9334 /* Initialized data */
9335
9336 static doublereal xmaxj[53] = { 1.21091229812484768570102219548814,
9337 1.11626917091567929907256116528817,
9338 1.1327140810290884106278510474203,
9339 1.1679452722668028753522098022171,
9340 1.20910611986279066645602153641334,
9341 1.25228283758701572089625983127043,
9342 1.29591971597287895911380446311508,
9343 1.3393138157481884258308028584917,
9344 1.3821288728999671920677617491385,
9345 1.42420414683357356104823573391816,
9346 1.46546895108549501306970087318319,
9347 1.50590085198398789708599726315869,
9348 1.54550385142820987194251585145013,
9349 1.58429644271680300005206185490937,
9350 1.62230484071440103826322971668038,
9351 1.65955905239130512405565733793667,
9352 1.69609056468292429853775667485212,
9353 1.73193098017228915881592458573809,
9354 1.7671112206990325429863426635397,
9355 1.80166107681586964987277458875667,
9356 1.83560897003644959204940535551721,
9357 1.86898184653271388435058371983316,
9358 1.90180515174518670797686768515502,
9359 1.93410285411785808749237200054739,
9360 1.96589749778987993293150856865539,
9361 1.99721027139062501070081653790635,
9362 2.02806108474738744005306947877164,
9363 2.05846864831762572089033752595401,
9364 2.08845055210580131460156962214748,
9365 2.11802334209486194329576724042253,
9366 2.14720259305166593214642386780469,
9367 2.17600297710595096918495785742803,
9368 2.20443832785205516555772788192013,
9369 2.2325216999457379530416998244706,
9370 2.2602654243075083168599953074345,
9371 2.28768115912702794202525264301585,
9372 2.3147799369092684021274946755348,
9373 2.34157220782483457076721300512406,
9374 2.36806787963276257263034969490066,
9375 2.39427635443992520016789041085844,
9376 2.42020656255081863955040620243062,
9377 2.44586699364757383088888037359254,
9378 2.47126572552427660024678584642791,
9379 2.49641045058324178349347438430311,
9380 2.52130850028451113942299097584818,
9381 2.54596686772399937214920135190177,
9382 2.5703922285006754089328998222275,
9383 2.59459096001908861492582631591134,
9384 2.61856915936049852435394597597773,
9385 2.64233265984385295286445444361827,
9386 2.66588704638685848486056711408168,
9387 2.68923766976735295746679957665724,
9388 2.71238965987606292679677228666411 };
9389
9390 /* System generated locals */
9391 integer crvlgd_dim1, crvlgd_offset, i__1, i__2;
9392 doublereal d__1;
9393
9394 /* Local variables */
9395 integer ncut, i__;
9396 doublereal bidon, error;
9397 integer ia, nd;
9398 doublereal bid, eps1;
9399
9400
9401
9402 /* ***********************************************************************
9403 */
9404
9405 /* FUNCTION : */
9406 /* ---------- */
9407 /* Lowers the degree of a curve defined on (-1,1) in the direction of */
9408 /* Legendre to a given precision. */
9409
9410 /* KEYWORDS : */
9411 /* ----------- */
9412 /* LEGENDRE,POLYGON,TRUNCATION,CURVE,SMOOTHING. */
9413
9414 /* INPUT ARGUMENTS : */
9415 /* ------------------ */
9416 /* NCOFMX : Max nb of coeff. of the curve (dimensioning). */
9417 /* NDIMEN : Dimension of the space. */
9418 /* NCOEFF : Degree +1 of the polynom. */
9419 /* EPSI3D : Precision required for the approximation. */
9420 /* CRVLGD : The curve the degree which of will be lowered. */
9421
9422 /* OUTPUT ARGUMENTS : */
9423 /* ------------------- */
9424 /* YCVMAX : Auxiliary table (max error on each dimension). */
9425 /* EPSTRC : Precision of the approximation. */
9426 /* NCFNEW : Degree +1 of the resulting polynom. */
9427
9428 /* COMMONS USED : */
9429 /* ---------------- */
9430
9431 /* REFERENCES CALLED : */
9432 /* ----------------------- */
9433
9434 /* DESCRIPTION/NOTES/LIMITATIONS : */
9435 /* ----------------------------------- */
9436 /* > */
9437 /* ***********************************************************************
9438 */
9439
9440
9441 /* Parameter adjustments */
9442 --ycvmax;
9443 crvlgd_dim1 = *ncofmx;
9444 crvlgd_offset = crvlgd_dim1 + 1;
9445 crvlgd -= crvlgd_offset;
9446
9447 /* Function Body */
9448
9449
9450
9451 /* Minimum degree that can be reached : Stop at IA (RBD). -------------
9452 */
9453 ia = 6;
9454 *ncfnew = ia;
9455 /* Init for error calculation. */
9456 i__1 = *ndimen;
9457 for (i__ = 1; i__ <= i__1; ++i__) {
9458 ycvmax[i__] = 0.;
9459 /* L100: */
9460 }
9461 *epstrc = 0.;
9462 error = 0.;
9463
9464 /* Cutting of coefficients. */
9465
9466 ncut = ia + 1;
9467 /* ------ Loop on the series of Jacobi :NCOEFF --> IA+1 (RBD) ----------
9468 */
9469 i__1 = ncut;
9470 for (i__ = *ncoeff; i__ >= i__1; --i__) {
9471 /* Factor of renormalization. */
9472 bidon = xmaxj[i__ - ncut];
9473 i__2 = *ndimen;
9474 for (nd = 1; nd <= i__2; ++nd) {
9475 ycvmax[nd] += (d__1 = crvlgd[i__ + nd * crvlgd_dim1], advapp_abs(d__1)) *
9476 bidon;
9477 /* L310: */
9478 }
9479 /* Stop cutting if the norm becomes too great. */
9480 error = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
9481 if (error > *epsi3d) {
9482 *ncfnew = i__;
9483 goto L400;
9484 }
9485
9486 /* --- Max error cumulated when the I-th coeff is removed. */
9487
9488 *epstrc = error;
9489
9490 /* L300: */
9491 }
9492
9493 /* ------- Cutting of zero coeff. of the pole of interpolation (RBD) -------
9494 */
9495
9496 L400:
9497 if (*ncfnew == ia) {
9498 AdvApp2Var_MathBase::mmeps1_(&eps1);
9499 for (i__ = ia; i__ >= 2; --i__) {
9500 bid = 0.;
9501 i__1 = *ndimen;
9502 for (nd = 1; nd <= i__1; ++nd) {
9503 bid += (d__1 = crvlgd[i__ + nd * crvlgd_dim1], advapp_abs(d__1));
9504 /* L600: */
9505 }
9506 if (bid > eps1) {
9507 *ncfnew = i__;
9508 goto L9999;
9509 }
9510 /* L500: */
9511 }
9512 /* --- If all coeffs can be removed, this is a point. */
9513 *ncfnew = 1;
9514 }
9515
9516 /* --------------------------------- End --------------------------------
9517 */
9518
9519 L9999:
9520 return 0;
9521 } /* mmtrpj6_ */
9522
9523 //=======================================================================
9524 //function : AdvApp2Var_MathBase::mmtrpjj_
9525 //purpose :
9526 //=======================================================================
mmtrpjj_(integer * ncofmx,integer * ndimen,integer * ncoeff,doublereal * epsi3d,integer * iordre,doublereal * crvlgd,doublereal * ycvmax,doublereal * errmax,integer * ncfnew)9527 int AdvApp2Var_MathBase::mmtrpjj_(integer *ncofmx,
9528 integer *ndimen,
9529 integer *ncoeff,
9530 doublereal *epsi3d,
9531 integer *iordre,
9532 doublereal *crvlgd,
9533 doublereal *ycvmax,
9534 doublereal *errmax,
9535 integer *ncfnew)
9536 {
9537 /* System generated locals */
9538 integer crvlgd_dim1, crvlgd_offset;
9539
9540 /* Local variables */
9541 integer ia;
9542
9543
9544 /* ***********************************************************************
9545 */
9546
9547 /* FUNCTION : */
9548 /* ---------- */
9549 /* Lower the degree of a curve defined on (-1,1) in the direction of */
9550 /* Legendre with a given precision. */
9551
9552 /* KEYWORDS : */
9553 /* ----------- */
9554 /* LEGENDRE, POLYGON, TRUNCATION, CURVE, SMOOTHING. */
9555
9556 /* INPUT ARGUMENTS : */
9557 /* ------------------ */
9558 /* NCOFMX : Max Nb coeff. of the curve (dimensioning). */
9559 /* NDIMEN : Dimension of the space. */
9560 /* NCOEFF : Degree +1 of the polynom. */
9561 /* EPSI3D : Precision required for the approximation. */
9562 /* IORDRE : Order of continuity at the extremities. */
9563 /* CRVLGD : The curve the degree which of should be lowered. */
9564
9565 /* OUTPUT ARGUMENTS : */
9566 /* ------------------- */
9567 /* ERRMAX : Precision of the approximation. */
9568 /* NCFNEW : Degree +1 of the resulting polynom. */
9569
9570 /* COMMONS USED : */
9571 /* ---------------- */
9572
9573 /* REFERENCES CALLED : */
9574 /* ----------------------- */
9575
9576 /* DESCRIPTION/NOTES/LIMITATIONS : */
9577 /* ----------------------------------- */
9578 /* > */
9579 /* ***********************************************************************
9580 */
9581
9582
9583 /* Parameter adjustments */
9584 --ycvmax;
9585 crvlgd_dim1 = *ncofmx;
9586 crvlgd_offset = crvlgd_dim1 + 1;
9587 crvlgd -= crvlgd_offset;
9588
9589 /* Function Body */
9590 ia = (*iordre + 1) << 1;
9591
9592 if (ia == 0) {
9593 mmtrpj0_(ncofmx, ndimen, ncoeff, epsi3d, &crvlgd[crvlgd_offset], &
9594 ycvmax[1], errmax, ncfnew);
9595 } else if (ia == 2) {
9596 mmtrpj2_(ncofmx, ndimen, ncoeff, epsi3d, &crvlgd[crvlgd_offset], &
9597 ycvmax[1], errmax, ncfnew);
9598 } else if (ia == 4) {
9599 mmtrpj4_(ncofmx, ndimen, ncoeff, epsi3d, &crvlgd[crvlgd_offset], &
9600 ycvmax[1], errmax, ncfnew);
9601 } else {
9602 mmtrpj6_(ncofmx, ndimen, ncoeff, epsi3d, &crvlgd[crvlgd_offset], &
9603 ycvmax[1], errmax, ncfnew);
9604 }
9605
9606 /* ------------------------ End -----------------------------------------
9607 */
9608
9609 return 0;
9610 } /* mmtrpjj_ */
9611
9612 //=======================================================================
9613 //function : AdvApp2Var_MathBase::mmunivt_
9614 //purpose :
9615 //=======================================================================
mmunivt_(integer * ndimen,doublereal * vector,doublereal * vecnrm,doublereal * epsiln,integer * iercod)9616 int AdvApp2Var_MathBase::mmunivt_(integer *ndimen,
9617 doublereal *vector,
9618 doublereal *vecnrm,
9619 doublereal *epsiln,
9620 integer *iercod)
9621 {
9622
9623 doublereal c_b2 = 10.;
9624
9625 /* System generated locals */
9626 integer i__1;
9627 doublereal d__1;
9628
9629 /* Local variables */
9630 integer nchif, iunit = 1, izero;
9631 doublereal vnorm;
9632 integer ii;
9633 doublereal bid;
9634 doublereal eps0;
9635
9636
9637
9638
9639 /* ***********************************************************************
9640 */
9641
9642 /* FUNCTION : */
9643 /* ---------- */
9644 /* CALCULATE THE NORMAL VECTOR BASING ON ANY VECTOR */
9645 /* WITH PRECISION GIVEN BY THE USER. */
9646
9647 /* KEYWORDS : */
9648 /* ----------- */
9649 /* ALL, MATH_ACCES :: */
9650 /* VECTEUR&, NORMALISATION, &VECTEUR */
9651
9652 /* INPUT ARGUMENTS : */
9653 /* ------------------ */
9654 /* NDIMEN : DIMENSION OF THE SPACE */
9655 /* VECTOR : VECTOR TO BE NORMED */
9656 /* EPSILN : EPSILON BELOW WHICH IT IS CONSIDERED THAT THE */
9657 /* NORM OF THE VECTOR IS NULL. IF EPSILN<=0, A DEFAULT VALUE */
9658 /* IS IMPOSED (10.D-17 ON VAX). */
9659
9660 /* OUTPUT ARGUMENTS : */
9661 /* ------------------- */
9662 /* VECNRM : NORMED VECTOR */
9663 /* IERCOD 101 : THE VECTOR IS NULL UP TO EPSILN. */
9664 /* 0 : OK. */
9665
9666 /* COMMONS USED : */
9667 /* ---------------- */
9668
9669 /* REFERENCES CALLED : */
9670 /* ----------------------- */
9671
9672 /* DESCRIPTION/NOTES/LIMITATIONS : */
9673 /* ----------------------------------- */
9674 /* VECTOR and VECNRM can be identic. */
9675
9676 /* The norm of vector is calculated and each component is divided by */
9677 /* this norm. After this it is checked if all componentes of the */
9678 /* vector except for one cost 0 with machine precision. In */
9679 /* this case the quasi-null components are set to 0.D0. */
9680 /* > */
9681 /* ***********************************************************************
9682 */
9683
9684
9685 /* Parameter adjustments */
9686 --vecnrm;
9687 --vector;
9688
9689 /* Function Body */
9690 *iercod = 0;
9691
9692 /* -------- Precision by default : zero machine 10.D-17 on Vax ------
9693 */
9694
9695 AdvApp2Var_SysBase::maovsr8_(&nchif);
9696 if (*epsiln <= 0.) {
9697 i__1 = -nchif;
9698 eps0 = AdvApp2Var_MathBase::pow__di(&c_b2, &i__1);
9699 } else {
9700 eps0 = *epsiln;
9701 }
9702
9703 /* ------------------------- Calculation of the norm --------------------
9704 */
9705
9706 vnorm = AdvApp2Var_MathBase::mzsnorm_(ndimen, &vector[1]);
9707 if (vnorm <= eps0) {
9708 AdvApp2Var_SysBase::mvriraz_(ndimen, &vecnrm[1]);
9709 *iercod = 101;
9710 goto L9999;
9711 }
9712
9713 /* ---------------------- Calculation of the vector norm ---------------
9714 */
9715
9716 izero = 0;
9717 i__1 = (-nchif - 1) / 2;
9718 eps0 = AdvApp2Var_MathBase::pow__di(&c_b2, &i__1);
9719 i__1 = *ndimen;
9720 for (ii = 1; ii <= i__1; ++ii) {
9721 vecnrm[ii] = vector[ii] / vnorm;
9722 if ((d__1 = vecnrm[ii], advapp_abs(d__1)) <= eps0) {
9723 ++izero;
9724 } else {
9725 iunit = ii;
9726 }
9727 /* L20: */
9728 }
9729
9730 /* ------ Case when all coordinates except for one are almost null ----
9731 */
9732 /* ------------- then one of coordinates costs 1.D0 or -1.D0 --------
9733 */
9734
9735 if (izero == *ndimen - 1) {
9736 bid = vecnrm[iunit];
9737 i__1 = *ndimen;
9738 for (ii = 1; ii <= i__1; ++ii) {
9739 vecnrm[ii] = 0.;
9740 /* L30: */
9741 }
9742 if (bid > 0.) {
9743 vecnrm[iunit] = 1.;
9744 } else {
9745 vecnrm[iunit] = -1.;
9746 }
9747 }
9748
9749 /* -------------------------------- The end -----------------------------
9750 */
9751
9752 L9999:
9753 return 0;
9754 } /* mmunivt_ */
9755
9756 //=======================================================================
9757 //function : AdvApp2Var_MathBase::mmveps3_
9758 //purpose :
9759 //=======================================================================
mmveps3_(doublereal * eps03)9760 int AdvApp2Var_MathBase::mmveps3_(doublereal *eps03)
9761 {
9762 /* Initialized data */
9763
9764 static char nomprg[8+1] = "MMEPS1 ";
9765
9766 integer ibb;
9767
9768
9769
9770 /************************************************************************
9771 *******/
9772
9773 /* FUNCTION : */
9774 /* ---------- */
9775 /* Extraction of EPS1 from COMMON MPRCSN. */
9776
9777 /* KEYWORDS : */
9778 /* ----------- */
9779 /* MPRCSN,PRECISON,EPS3. */
9780
9781 /* INPUT ARGUMENTS : */
9782 /* ------------------ */
9783 /* Humm. */
9784
9785 /* OUTPUT ARGUMENTS : */
9786 /* ------------------- */
9787 /* EPS3 : space zero of the denominator (10**-9) */
9788 /* EPS3 should value 10**-15 */
9789
9790 /* COMMONS USED : */
9791 /* ---------------- */
9792
9793 /* REFERENCES CALLED : */
9794 /* ----------------------- */
9795
9796 /* DESCRIPTION/NOTES/LIMITATIONS : */
9797 /* ----------------------------------- */
9798
9799 /* > */
9800 /* ***********************************************************************
9801 */
9802
9803
9804
9805 /* ***********************************************************************
9806 */
9807
9808 /* FUNCTION : */
9809 /* ---------- */
9810 /* GIVES TOLERANCES OF NULLITY IN STRIM */
9811 /* AND LIMITS OF ITERATIVE PROCESSES */
9812
9813 /* GENERAL CONTEXT, MODIFIABLE BY THE UTILISER */
9814
9815 /* KEYWORDS : */
9816 /* ----------- */
9817 /* PARAMETER , TOLERANCE */
9818
9819 /* DESCRIPTION/NOTES/LIMITATIONS : */
9820 /* ----------------------------------- */
9821 /* INITIALISATION : PROFILE , **VIA MPRFTX** AT INPUT IN STRIM*/
9822 /* LOADING OF DEFAULT VALUES OF THE PROFILE IN MPRFTX AT INPUT*/
9823 /* IN STRIM. THEY ARE PRESERVED IN THE LOCAL VARIABLES OF MPRFTX */
9824
9825 /* RESET DEFAULT VALUES : MDFINT */
9826 /* MODIFICATION INTERACTIVE BY THE USER : MDBINT */
9827
9828 /* ACCESS FUNCTION : MMEPS1 ... EPS1 */
9829 /* MEPSPB ... EPS3,EPS4 */
9830 /* MEPSLN ... EPS2, NITERM , NITERR */
9831 /* MEPSNR ... EPS2 , NITERM */
9832 /* MITERR ... NITERR */
9833
9834 /* > */
9835 /* ***********************************************************************
9836 */
9837
9838 /* NITERM : MAX NB OF ITERATIONS */
9839 /* NITERR : NB OF RAPID ITERATIONS */
9840 /* EPS1 : TOLERANCE OF 3D NULL DISTANCE */
9841 /* EPS2 : TOLERANCE OF ZERO PARAMETRIC DISTANCE */
9842 /* EPS3 : TOLERANCE TO AVOID DIVISION BY 0.. */
9843 /* EPS4 : TOLERANCE ANGULAR */
9844
9845
9846
9847 /* ***********************************************************************
9848 */
9849
9850 ibb = AdvApp2Var_SysBase::mnfndeb_();
9851 if (ibb >= 5) {
9852 AdvApp2Var_SysBase::mgenmsg_(nomprg, 6L);
9853 }
9854
9855 *eps03 = mmprcsn_.eps3;
9856
9857 return 0;
9858 } /* mmveps3_ */
9859
9860 //=======================================================================
9861 //function : AdvApp2Var_MathBase::mmvncol_
9862 //purpose :
9863 //=======================================================================
mmvncol_(integer * ndimen,doublereal * vecin,doublereal * vecout,integer * iercod)9864 int AdvApp2Var_MathBase::mmvncol_(integer *ndimen,
9865 doublereal *vecin,
9866 doublereal *vecout,
9867 integer *iercod)
9868
9869 {
9870 /* System generated locals */
9871 integer i__1;
9872
9873 /* Local variables */
9874 logical ldbg;
9875 integer d__;
9876 doublereal vaux1[3], vaux2[3];
9877 logical colin;
9878 doublereal valaux;
9879 integer aux;
9880
9881 /* ***********************************************************************
9882 */
9883
9884 /* FUNCTION : */
9885 /* ---------- */
9886 /* CALCULATE A VECTOR NON-COLINEAR TO A GIVEN NON-NULL VECTOR */
9887
9888 /* KEYWORDS : */
9889 /* ----------- */
9890 /* PUBLIC, VECTOR, FREE */
9891
9892 /* INPUT ARGUMENTS : */
9893 /* -------------------- */
9894 /* ndimen : dimension of the space */
9895 /* vecin : input vector */
9896
9897 /* OUTPUT ARGUMENTS : */
9898 /* --------------------- */
9899
9900 /* vecout : vector non colinear to vecin */
9901
9902 /* COMMONS USED : */
9903 /* ------------------ */
9904
9905
9906 /* REFERENCES CALLED : */
9907 /* --------------------- */
9908
9909
9910 /* DESCRIPTION/NOTES/LIMITATIONS : */
9911 /* ----------------------------------- */
9912 /* > */
9913 /* ***********************************************************************
9914 */
9915 /* DECLARATIONS */
9916 /* ***********************************************************************
9917 */
9918
9919
9920
9921 /* ***********************************************************************
9922 */
9923 /* INITIALISATIONS */
9924 /* ***********************************************************************
9925 */
9926
9927 /* Parameter adjustments */
9928 --vecout;
9929 --vecin;
9930
9931 /* Function Body */
9932 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 2;
9933 if (ldbg) {
9934 AdvApp2Var_SysBase::mgenmsg_("MMVNCOL", 7L);
9935 }
9936 *iercod = 0;
9937
9938 /* ***********************************************************************
9939 */
9940 /* PROCESSING */
9941 /* ***********************************************************************
9942 */
9943
9944 if (*ndimen <= 1 || *ndimen > 3) {
9945 goto L9101;
9946 }
9947 d__ = 1;
9948 aux = 0;
9949 while(d__ <= *ndimen) {
9950 if (vecin[d__] == 0.) {
9951 ++aux;
9952 }
9953 ++d__;
9954 }
9955 if (aux == *ndimen) {
9956 goto L9101;
9957 }
9958
9959
9960 for (d__ = 1; d__ <= 3; ++d__) {
9961 vaux1[d__ - 1] = 0.;
9962 }
9963 i__1 = *ndimen;
9964 for (d__ = 1; d__ <= i__1; ++d__) {
9965 vaux1[d__ - 1] = vecin[d__];
9966 vaux2[d__ - 1] = vecin[d__];
9967 }
9968 colin = TRUE_;
9969 d__ = 0;
9970 while(colin) {
9971 ++d__;
9972 if (d__ > 3) {
9973 goto L9101;
9974 }
9975 vaux2[d__ - 1] += 1;
9976 valaux = vaux1[1] * vaux2[2] - vaux1[2] * vaux2[1];
9977 if (valaux == 0.) {
9978 valaux = vaux1[2] * vaux2[0] - vaux1[0] * vaux2[2];
9979 if (valaux == 0.) {
9980 valaux = vaux1[0] * vaux2[1] - vaux1[1] * vaux2[0];
9981 if (valaux != 0.) {
9982 colin = FALSE_;
9983 }
9984 } else {
9985 colin = FALSE_;
9986 }
9987 } else {
9988 colin = FALSE_;
9989 }
9990 }
9991 if (colin) {
9992 goto L9101;
9993 }
9994 i__1 = *ndimen;
9995 for (d__ = 1; d__ <= i__1; ++d__) {
9996 vecout[d__] = vaux2[d__ - 1];
9997 }
9998
9999 goto L9999;
10000
10001 /* ***********************************************************************
10002 */
10003 /* ERROR PROCESSING */
10004 /* ***********************************************************************
10005 */
10006
10007
10008 L9101:
10009 *iercod = 1;
10010 goto L9999;
10011
10012
10013 /* ***********************************************************************
10014 */
10015 /* RETURN CALLING PROGRAM */
10016 /* ***********************************************************************
10017 */
10018
10019 L9999:
10020
10021
10022 AdvApp2Var_SysBase::maermsg_("MMVNCOL", iercod, 7L);
10023 if (ldbg) {
10024 AdvApp2Var_SysBase::mgsomsg_("MMVNCOL", 7L);
10025 }
10026 return 0 ;
10027 } /* mmvncol_ */
10028
10029 //=======================================================================
10030 //function : AdvApp2Var_MathBase::mmwprcs_
10031 //purpose :
10032 //=======================================================================
mmwprcs_(doublereal * epsil1,doublereal * epsil2,doublereal * epsil3,doublereal * epsil4,integer * niter1,integer * niter2)10033 void AdvApp2Var_MathBase::mmwprcs_(doublereal *epsil1,
10034 doublereal *epsil2,
10035 doublereal *epsil3,
10036 doublereal *epsil4,
10037 integer *niter1,
10038 integer *niter2)
10039
10040 {
10041
10042
10043 /* ***********************************************************************
10044 */
10045
10046 /* FUNCTION : */
10047 /* ---------- */
10048 /* ACCESS IN WRITING FOR COMMON MPRCSN */
10049
10050 /* KEYWORDS : */
10051 /* ----------- */
10052 /* WRITING */
10053
10054 /* INPUT ARGUMENTS : */
10055 /* -------------------- */
10056 /* EPSIL1 : TOLERANCE OF 3D NULL DISTANCE */
10057 /* EPSIL2 : TOLERANCE OF PARAMETRIC NULL DISTANCE */
10058 /* EPSIL3 : TOLERANCE TO AVOID DIVISION BY 0.. */
10059 /* EPSIL4 : ANGULAR TOLERANCE */
10060 /* NITER1 : MAX NB OF ITERATIONS */
10061 /* NITER2 : NB OF RAPID ITERATIONS */
10062
10063 /* OUTPUT ARGUMENTS : */
10064 /* --------------------- */
10065 /* NONE */
10066
10067 /* COMMONS USED : */
10068 /* ------------------ */
10069
10070
10071 /* REFERENCES CALLED : */
10072 /* --------------------- */
10073
10074
10075 /* DESCRIPTION/NOTES/LIMITATIONS : */
10076 /* ----------------------------------- */
10077
10078 /* > */
10079 /* ***********************************************************************
10080 */
10081 /* DECLARATIONS */
10082 /* ***********************************************************************
10083 */
10084
10085
10086 /* ***********************************************************************
10087 */
10088 /* INITIALIZATIONS */
10089 /* ***********************************************************************
10090 */
10091
10092 /* ***********************************************************************
10093 */
10094 /* PROCESSING */
10095 /* ***********************************************************************
10096 */
10097
10098 /* ***********************************************************************
10099 */
10100
10101 /* FUNCTION : */
10102 /* ---------- */
10103 /* GIVES TOLERANCES OF NULLITY IN STRIM */
10104 /* AND LIMITS OF ITERATIVE PROCESSES */
10105
10106 /* GENERAL CONTEXT, MODIFIABLE BY THE UTILISER */
10107
10108 /* KEYWORDS : */
10109 /* ----------- */
10110 /* PARAMETER , TOLERANCE */
10111
10112 /* DESCRIPTION/NOTES/LIMITATIONS : */
10113 /* ----------------------------------- */
10114 /* INITIALISATION : PROFILE , **VIA MPRFTX** AT INPUT IN STRIM*/
10115 /* LOADING OF DEFAULT VALUES OF THE PROFILE IN MPRFTX AT INPUT*/
10116 /* IN STRIM. THEY ARE PRESERVED IN THE LOCAL VARIABLES OF MPRFTX */
10117
10118 /* RESET DEFAULT VALUES : MDFINT */
10119 /* MODIFICATION INTERACTIVE BY THE USER : MDBINT */
10120
10121 /* ACCESS FUNCTION : MMEPS1 ... EPS1 */
10122 /* MEPSPB ... EPS3,EPS4 */
10123 /* MEPSLN ... EPS2, NITERM , NITERR */
10124 /* MEPSNR ... EPS2 , NITERM */
10125 /* MITERR ... NITERR */
10126
10127 /* > */
10128 /* ***********************************************************************
10129 */
10130
10131 /* NITERM : MAX NB OF ITERATIONS */
10132 /* NITERR : NB OF RAPID ITERATIONS */
10133 /* EPS1 : TOLERANCE OF 3D NULL DISTANCE */
10134 /* EPS2 : TOLERANCE OF ZERO PARAMETRIC DISTANCE */
10135 /* EPS3 : TOLERANCE TO AVOID DIVISION BY 0.. */
10136 /* EPS4 : TOLERANCE ANGULAR */
10137
10138
10139 /* ***********************************************************************
10140 */
10141 mmprcsn_.eps1 = *epsil1;
10142 mmprcsn_.eps2 = *epsil2;
10143 mmprcsn_.eps3 = *epsil3;
10144 mmprcsn_.eps4 = *epsil4;
10145 mmprcsn_.niterm = *niter1;
10146 mmprcsn_.niterr = *niter2;
10147 return ;
10148 } /* mmwprcs_ */
10149
10150
10151 //=======================================================================
10152 //function : AdvApp2Var_MathBase::pow__di
10153 //purpose :
10154 //=======================================================================
pow__di(doublereal * x,integer * n)10155 doublereal AdvApp2Var_MathBase::pow__di (doublereal *x,
10156 integer *n)
10157 {
10158 doublereal result ;
10159 integer absolute ;
10160 result = 1.0e0 ;
10161 if ( *n > 0 ) {absolute = *n;}
10162 else {absolute = -*n;}
10163 /* System generated locals */
10164 for(integer ii = 0 ; ii < absolute ; ii++) {
10165 result *= *x ;
10166 }
10167 if (*n < 0) {
10168 result = 1.0e0 / result ;
10169 }
10170 return result ;
10171 }
10172
10173
10174 /* **********************************************************************
10175 */
10176
10177 /* FUNCTION : */
10178 /* ---------- */
10179 /* Calculate integer function power not obligatory in the most efficient way ;
10180 */
10181
10182 /* KEYWORDS : */
10183 /* ----------- */
10184 /* POWER */
10185
10186 /* INPUT ARGUMENTS : */
10187 /* ------------------ */
10188 /* X : argument of X**N */
10189 /* N : power */
10190
10191 /* OUTPUT ARGUMENTS : */
10192 /* ------------------- */
10193 /* return X**N */
10194
10195 /* COMMONS USED : */
10196 /* ---------------- */
10197
10198 /* REFERENCES CALLED : */
10199 /* ----------------------- */
10200
10201 /* DESCRIPTION/NOTES/LIMITATIONS : */
10202 /* ----------------------------------- */
10203
10204 /* > */
10205 /* ***********************************************************************/
10206
10207 //=======================================================================
10208 //function : pow__ii
10209 //purpose :
10210 //=======================================================================
pow__ii(integer * x,integer * n)10211 integer pow__ii(integer *x,
10212 integer *n)
10213
10214 {
10215 integer result ;
10216 integer absolute ;
10217 result = 1 ;
10218 if ( *n > 0 ) {absolute = *n;}
10219 else {absolute = -*n;}
10220 /* System generated locals */
10221 for(integer ii = 0 ; ii < absolute ; ii++) {
10222 result *= *x ;
10223 }
10224 if (*n < 0) {
10225 result = 1 / result ;
10226 }
10227 return result ;
10228 }
10229
10230
10231 /* **********************************************************************
10232 */
10233 /* **********************************************************************
10234 */
10235
10236 /* FUNCTION : */
10237 /* ---------- */
10238 /* Calculate integer function power not obligatory in the most efficient way ;
10239 */
10240
10241 /* KEYWORDS : */
10242 /* ----------- */
10243 /* POWER */
10244
10245 /* INPUT ARGUMENTS : */
10246 /* ------------------ */
10247 /* X : argument of X**N */
10248 /* N : power */
10249
10250 /* OUTPUT ARGUMENTS : */
10251 /* ------------------- */
10252 /* return X**N */
10253
10254 /* COMMONS USED : */
10255 /* ---------------- */
10256
10257 /* REFERENCES CALLED : */
10258 /* ----------------------- */
10259
10260 /* DESCRIPTION/NOTES/LIMITATIONS : */
10261 /* ----------------------------------- */
10262
10263 /* > */
10264 /* ***********************************************************************/
10265
10266 //=======================================================================
10267 //function : AdvApp2Var_MathBase::msc_
10268 //purpose :
10269 //=======================================================================
msc_(integer * ndimen,doublereal * vecte1,doublereal * vecte2)10270 doublereal AdvApp2Var_MathBase::msc_(integer *ndimen,
10271 doublereal *vecte1,
10272 doublereal *vecte2)
10273
10274 {
10275 /* System generated locals */
10276 integer i__1;
10277 doublereal ret_val;
10278
10279 /* Local variables */
10280 integer i__;
10281 doublereal x;
10282
10283
10284
10285 /************************************************************************
10286 *******/
10287
10288 /* FUNCTION : */
10289 /* ---------- */
10290 /* Calculate the scalar product of 2 vectors in the space */
10291 /* of dimension NDIMEN. */
10292
10293 /* KEYWORDS : */
10294 /* ----------- */
10295 /* PRODUCT MSCALAIRE. */
10296
10297 /* INPUT ARGUMENTS : */
10298 /* ------------------ */
10299 /* NDIMEN : Dimension of the space. */
10300 /* VECTE1,VECTE2: Vectors. */
10301
10302 /* OUTPUT ARGUMENTS : */
10303 /* ------------------- */
10304
10305 /* COMMONS USED : */
10306 /* ---------------- */
10307
10308 /* REFERENCES CALLED : */
10309 /* ----------------------- */
10310
10311 /* DESCRIPTION/NOTES/LIMITATIONS : */
10312 /* ----------------------------------- */
10313
10314 /* > */
10315 /* ***********************************************************************
10316 */
10317
10318
10319 /* PRODUIT MSCALAIRE */
10320 /* Parameter adjustments */
10321 --vecte2;
10322 --vecte1;
10323
10324 /* Function Body */
10325 x = 0.;
10326
10327 i__1 = *ndimen;
10328 for (i__ = 1; i__ <= i__1; ++i__) {
10329 x += vecte1[i__] * vecte2[i__];
10330 /* L100: */
10331 }
10332 ret_val = x;
10333
10334 /* ----------------------------------- THE END --------------------------
10335 */
10336
10337 return ret_val;
10338 } /* msc_ */
10339
10340 //=======================================================================
10341 //function : mvcvin2_
10342 //purpose :
10343 //=======================================================================
mvcvin2_(integer * ncoeff,doublereal * crvold,doublereal * crvnew,integer * iercod)10344 int mvcvin2_(integer *ncoeff,
10345 doublereal *crvold,
10346 doublereal *crvnew,
10347 integer *iercod)
10348
10349 {
10350 /* System generated locals */
10351 integer i__1, i__2;
10352
10353 /* Local variables */
10354 integer m1jm1, ncfm1, j, k;
10355 doublereal bid;
10356 doublereal cij1, cij2;
10357
10358
10359
10360 /************************************************************************
10361 *******/
10362
10363 /* FONCTION : */
10364 /* ---------- */
10365 /* INVERSION OF THE PARAMETERS ON CURVE 2D. */
10366
10367 /* KEYWORDS : */
10368 /* ----------- */
10369 /* CURVE,2D,INVERSION,PARAMETER. */
10370
10371 /* INPUT ARGUMENTS : */
10372 /* ------------------ */
10373 /* NCOEFF : NB OF COEFF OF THE CURVE. */
10374 /* CRVOLD : CURVE OF ORIGIN */
10375
10376 /* OUTPUT ARGUMENTS : */
10377 /* ------------------- */
10378 /* CRVNEW : THE RESULTING CURVE AFTER CHANGE OF T BY 1-T */
10379 /* IERCOD : 0 OK, */
10380 /* 10 NB OF COEFF NULL OR TOO GREAT. */
10381
10382 /* COMMONS USED : */
10383 /* ---------------- */
10384 /* MCCNP */
10385
10386 /* REFERENCES CALLED : */
10387 /* ---------------------- */
10388 /* Neant */
10389 /* DESCRIPTION/NOTES/LIMITATIONS : */
10390 /* ----------------------------------- */
10391 /* THE FOLLOWING CALL IS ABSOLUTELY LEGAL : */
10392 /* CALL MVCVIN2(NCOEFF,CURVE,CURVE,IERCOD), THE TABLE CURVE */
10393 /* BECOMES INPUT AND OUTPUT ARGUMENT (RBD). */
10394 /* BECAUSE OF MCCNP, THE NB OF COEFF OF THE CURVE IS LIMITED TO */
10395 /* NDGCNP+1 = 61. */
10396
10397 /* > */
10398 /* ***********************************************************************
10399 */
10400
10401
10402 /* **********************************************************************
10403 */
10404
10405 /* FUNCTION : */
10406 /* ---------- */
10407 /* Serves to provide coefficients of the binome (triangle of Pascal). */
10408
10409 /* KEYWORDS : */
10410 /* ----------- */
10411 /* Coeff of binome from 0 to 60. read only . init par block data */
10412
10413 /* DEMSCRIPTION/NOTES/LIMITATIONS : */
10414 /* ----------------------------------- */
10415 /* The coefficients of the binome form a triangular matrix. */
10416 /* This matrix is completed in table CNP by transposition. */
10417 /* So: CNP(I,J) = CNP(J,I) for I and J = 0, ..., 60. */
10418
10419 /* Initialization is done by block-data MMLLL09.RES, */
10420 /* created by program MQINICNP.FOR (see the team (AC) ). */
10421
10422
10423 /* > */
10424 /* **********************************************************************
10425 */
10426
10427
10428
10429 /* ***********************************************************************
10430 */
10431
10432 /* Parameter adjustments */
10433 crvnew -= 3;
10434 crvold -= 3;
10435
10436 /* Function Body */
10437 if (*ncoeff < 1 || *ncoeff - 1 > 60) {
10438 *iercod = 10;
10439 goto L9999;
10440 }
10441 *iercod = 0;
10442
10443
10444 /* CONSTANT TERM OF THE NEW CURVE */
10445
10446 cij1 = crvold[3];
10447 cij2 = crvold[4];
10448 i__1 = *ncoeff;
10449 for (k = 2; k <= i__1; ++k) {
10450 cij1 += crvold[(k << 1) + 1];
10451 cij2 += crvold[(k << 1) + 2];
10452 }
10453 crvnew[3] = cij1;
10454 crvnew[4] = cij2;
10455 if (*ncoeff == 1) {
10456 goto L9999;
10457 }
10458
10459 /* INTERMEDIARY POWERS OF THE PARAMETER */
10460
10461 ncfm1 = *ncoeff - 1;
10462 m1jm1 = 1;
10463 i__1 = ncfm1;
10464 for (j = 2; j <= i__1; ++j) {
10465 m1jm1 = -m1jm1;
10466 cij1 = crvold[(j << 1) + 1];
10467 cij2 = crvold[(j << 1) + 2];
10468 i__2 = *ncoeff;
10469 for (k = j + 1; k <= i__2; ++k) {
10470 bid = mmcmcnp_.cnp[k - 1 + (j - 1) * 61];
10471 cij1 += crvold[(k << 1) + 1] * bid;
10472 cij2 += crvold[(k << 1) + 2] * bid;
10473 }
10474 crvnew[(j << 1) + 1] = cij1 * m1jm1;
10475 crvnew[(j << 1) + 2] = cij2 * m1jm1;
10476 }
10477
10478 /* TERM OF THE HIGHEST DEGREE */
10479
10480 crvnew[(*ncoeff << 1) + 1] = -crvold[(*ncoeff << 1) + 1] * m1jm1;
10481 crvnew[(*ncoeff << 1) + 2] = -crvold[(*ncoeff << 1) + 2] * m1jm1;
10482
10483 L9999:
10484 if (*iercod > 0) {
10485 AdvApp2Var_SysBase::maermsg_("MVCVIN2", iercod, 7L);
10486 }
10487 return 0 ;
10488 } /* mvcvin2_ */
10489
10490 //=======================================================================
10491 //function : mvcvinv_
10492 //purpose :
10493 //=======================================================================
mvcvinv_(integer * ncoeff,doublereal * crvold,doublereal * crvnew,integer * iercod)10494 int mvcvinv_(integer *ncoeff,
10495 doublereal *crvold,
10496 doublereal *crvnew,
10497 integer *iercod)
10498
10499 {
10500 /* System generated locals */
10501 integer i__1, i__2;
10502
10503 /* Local variables */
10504 integer m1jm1, ncfm1, j, k;
10505 doublereal bid;
10506 //extern /* Subroutine */ int maermsg_();
10507 doublereal cij1, cij2, cij3;
10508
10509
10510 /* **********************************************************************
10511 */
10512
10513 /* FUNCTION : */
10514 /* ---------- */
10515 /* INVERSION OF THE PARAMETER ON A CURBE 3D (I.E. INVERSION */
10516 /* OF THE DIRECTION OF PARSING). */
10517
10518 /* KEYWORDS : */
10519 /* ----------- */
10520 /* CURVE,INVERSION,PARAMETER. */
10521
10522 /* INPUT ARGUMENTS : */
10523 /* ------------------ */
10524 /* NCOEFF : NB OF COEFF OF THE CURVE. */
10525 /* CRVOLD : CURVE OF ORIGIN */
10526
10527 /* OUTPUT ARGUMENTS : */
10528 /* ------------------- */
10529 /* CRVNEW : RESULTING CURVE AFTER CHANGE OF T INTO 1-T */
10530 /* IERCOD : 0 OK, */
10531 /* 10 NB OF COEFF NULL OR TOO GREAT. */
10532
10533 /* COMMONS USED : */
10534 /* ---------------- */
10535 /* MCCNP */
10536
10537 /* REFERENCES CALLED : */
10538 /* ---------------------- */
10539 /* Neant */
10540 /* DESCRIPTION/NOTES/LIMITATIONS : */
10541 /* ----------------------------------- */
10542 /* THE FOLLOWING CALL IS ABSOLUTELY LEGAL : */
10543 /* CALL MVCVINV(NCOEFF,CURVE,CURVE,IERCOD), TABLE CURVE */
10544 /* BECOMES INPUT AND OUTPUT ARGUMENT (RBD). */
10545 /* THE NUMBER OF COEFF OF THE CURVE IS LIMITED TO NDGCNP+1 = 61 */
10546 /* BECAUSE OF USE OF COMMON MCCNP. */
10547 /* > */
10548 /* ***********************************************************************
10549 */
10550
10551 /* **********************************************************************
10552 */
10553
10554 /* FUNCTION : */
10555 /* ---------- */
10556 /* Serves to provide the binomial coefficients (triangle of Pascal). */
10557
10558 /* KEYWORDS : */
10559 /* ----------- */
10560 /* Binomial Coeff from 0 to 60. read only . init par block data */
10561
10562 /* DEMSCRIPTION/NOTES/LIMITATIONS : */
10563 /* ----------------------------------- */
10564 /* The binomial coefficients form a triangular matrix. */
10565 /* This matrix is completed in table CNP by its transposition. */
10566 /* So: CNP(I,J) = CNP(J,I) for I and J = 0, ..., 60. */
10567
10568 /* Initialisation is done by block-data MMLLL09.RES, */
10569 /* created by program MQINICNP.FOR (see the team (AC) ). */
10570 /* > */
10571 /* **********************************************************************
10572 */
10573
10574
10575
10576 /* ***********************************************************************
10577 */
10578
10579 /* Parameter adjustments */
10580 crvnew -= 4;
10581 crvold -= 4;
10582
10583 /* Function Body */
10584 if (*ncoeff < 1 || *ncoeff - 1 > 60) {
10585 *iercod = 10;
10586 goto L9999;
10587 }
10588 *iercod = 0;
10589
10590 /* CONSTANT TERM OF THE NEW CURVE */
10591
10592 cij1 = crvold[4];
10593 cij2 = crvold[5];
10594 cij3 = crvold[6];
10595 i__1 = *ncoeff;
10596 for (k = 2; k <= i__1; ++k) {
10597 cij1 += crvold[k * 3 + 1];
10598 cij2 += crvold[k * 3 + 2];
10599 cij3 += crvold[k * 3 + 3];
10600 /* L30: */
10601 }
10602 crvnew[4] = cij1;
10603 crvnew[5] = cij2;
10604 crvnew[6] = cij3;
10605 if (*ncoeff == 1) {
10606 goto L9999;
10607 }
10608
10609 /* INTERMEDIARY POWER OF THE PARAMETER */
10610
10611 ncfm1 = *ncoeff - 1;
10612 m1jm1 = 1;
10613 i__1 = ncfm1;
10614 for (j = 2; j <= i__1; ++j) {
10615 m1jm1 = -m1jm1;
10616 cij1 = crvold[j * 3 + 1];
10617 cij2 = crvold[j * 3 + 2];
10618 cij3 = crvold[j * 3 + 3];
10619 i__2 = *ncoeff;
10620 for (k = j + 1; k <= i__2; ++k) {
10621 bid = mmcmcnp_.cnp[k - 1 + (j - 1) * 61];
10622 cij1 += crvold[k * 3 + 1] * bid;
10623 cij2 += crvold[k * 3 + 2] * bid;
10624 cij3 += crvold[k * 3 + 3] * bid;
10625 /* L40: */
10626 }
10627 crvnew[j * 3 + 1] = cij1 * m1jm1;
10628 crvnew[j * 3 + 2] = cij2 * m1jm1;
10629 crvnew[j * 3 + 3] = cij3 * m1jm1;
10630 /* L50: */
10631 }
10632
10633 /* TERM OF THE HIGHEST DEGREE */
10634
10635 crvnew[*ncoeff * 3 + 1] = -crvold[*ncoeff * 3 + 1] * m1jm1;
10636 crvnew[*ncoeff * 3 + 2] = -crvold[*ncoeff * 3 + 2] * m1jm1;
10637 crvnew[*ncoeff * 3 + 3] = -crvold[*ncoeff * 3 + 3] * m1jm1;
10638
10639 L9999:
10640 AdvApp2Var_SysBase::maermsg_("MVCVINV", iercod, 7L);
10641 return 0;
10642 } /* mvcvinv_ */
10643
10644 //=======================================================================
10645 //function : mvgaus0_
10646 //purpose :
10647 //=======================================================================
mvgaus0_(integer * kindic,doublereal * urootl,doublereal * hiltab,integer * nbrval,integer * iercod)10648 int mvgaus0_(integer *kindic,
10649 doublereal *urootl,
10650 doublereal *hiltab,
10651 integer *nbrval,
10652 integer *iercod)
10653
10654 {
10655 /* System generated locals */
10656 integer i__1 = 0;
10657
10658 /* Local variables */
10659 doublereal tampc[40] = {};
10660 NCollection_Array1<doublereal> tamp (tampc[0], 1, 40);
10661 integer ndegl = 0, kg = 0, ii = 0;
10662
10663 /* **********************************************************************
10664 */
10665
10666 /* FUNCTION : */
10667 /* -------- */
10668 /* Loading of a degree gives roots of LEGENDRE polynom */
10669 /* DEFINED on [-1,1] and weights of Gauss quadrature formulas */
10670 /* (based on corresponding LAGRANGIAN interpolators). */
10671 /* The symmetry relative to 0 is used between [-1,0] and [0,1]. */
10672
10673 /* KEYWORDS : */
10674 /* --------- */
10675 /* . VOLUMIC, LEGENDRE, LAGRANGE, GAUSS */
10676
10677 /* INPUT ARGUMENTSE : */
10678 /* ------------------ */
10679
10680 /* KINDIC : Takes values from 1 to 10 depending of the degree */
10681 /* of the used polynom. */
10682 /* The degree of the polynom is equal to 4 k, i.e. 4, 8, */
10683 /* 12, 16, 20, 24, 28, 32, 36 and 40. */
10684
10685 /* OUTPUT ARGUMENTS : */
10686 /* ------------------- */
10687
10688 /* UROOTL : Roots of LEGENDRE polynom in domain [1,0] */
10689 /* given in decreasing order. For domain [-1,0], it is */
10690 /* necessary to take the opposite values. */
10691 /* HILTAB : LAGRANGE interpolators associated to roots. For */
10692 /* opposed roots, interpolatorsare equal. */
10693 /* NBRVAL : Nb of coefficients. Is equal to the half of degree */
10694 /* depending on the symmetry (i.e. 2*KINDIC). */
10695
10696 /* IERCOD : Error code: */
10697 /* < 0 ==> Attention - Warning */
10698 /* =-1 ==> Value of false KINDIC. NBRVAL is forced to 20 */
10699 /* (order 40) */
10700 /* = 0 ==> Everything is OK */
10701
10702 /* COMMON USED : */
10703 /* ---------------- */
10704
10705 /* REFERENCES CALLED : */
10706 /* ------------------- */
10707
10708 /* DESCRIPTION/NOTES/LIMITATIONS : */
10709 /* --------------------------------- */
10710 /* If KINDIC is not correct (i.e < 1 or > 10), the degree is set */
10711 /* to 40 directly (ATTENTION to overload - to avoid it, */
10712 /* preview UROOTL and HILTAB dimensioned at least to 20). */
10713
10714 /* The value of coefficients was calculated with quadruple precision */
10715 /* by JJM with help of GD. */
10716 /* Checking of roots was done by GD. */
10717
10718 /* See detailed explications on the listing */
10719 /* > */
10720 /* **********************************************************************
10721 */
10722
10723
10724 /* ------------------------------------ */
10725 /* ****** Test validity of KINDIC ** */
10726 /* ------------------------------------ */
10727
10728 /* Parameter adjustments */
10729 --hiltab;
10730 --urootl;
10731
10732 /* Function Body */
10733 *iercod = 0;
10734 kg = *kindic;
10735 if (kg < 1 || kg > 10) {
10736 kg = 10;
10737 *iercod = -1;
10738 }
10739 *nbrval = kg << 1;
10740 ndegl = *nbrval << 1;
10741
10742 /* ----------------------------------------------------------------------
10743 */
10744 /* ****** Load NBRVAL positive roots depending on the degree **
10745 */
10746 /* ----------------------------------------------------------------------
10747 */
10748 /* ATTENTION : Sign minus (-) in the loop is intentional. */
10749
10750 mmextrl_(&ndegl, tamp);
10751 i__1 = *nbrval;
10752 for (ii = 1; ii <= i__1; ++ii) {
10753 urootl[ii] = -tamp(ii);
10754 /* L100: */
10755 }
10756
10757 /* ------------------------------------------------------------------- */
10758 /* ****** Loading of NBRVAL Gauss weight depending on the degree ** */
10759 /* ------------------------------------------------------------------- */
10760
10761 mmexthi_(&ndegl, tamp);
10762 i__1 = *nbrval;
10763 for (ii = 1; ii <= i__1; ++ii) {
10764 hiltab[ii] = tamp(ii);
10765 /* L200: */
10766 }
10767
10768 /* ------------------------------- */
10769 /* ****** End of sub-program ** */
10770 /* ------------------------------- */
10771
10772 return 0;
10773 } /* mvgaus0_ */
10774
10775 //=======================================================================
10776 //function : mvpscr2_
10777 //purpose :
10778 //=======================================================================
mvpscr2_(integer * ncoeff,doublereal * curve2,doublereal * tparam,doublereal * pntcrb)10779 int mvpscr2_(integer *ncoeff,
10780 doublereal *curve2,
10781 doublereal *tparam,
10782 doublereal *pntcrb)
10783 {
10784 /* System generated locals */
10785 integer i__1;
10786
10787 /* Local variables */
10788 integer ndeg, kk;
10789 doublereal xxx, yyy;
10790
10791
10792
10793 /* **********************************************************************
10794 */
10795
10796 /* FUNCTION : */
10797 /* ---------- */
10798 /* POSITIONING ON CURVE (NCF,2) IN SPACE OF DIMENSION 2. */
10799
10800 /* KEYWORDS : */
10801 /* ----------- */
10802 /* TOUS,MATH_ACCES:: COURBE&,POSITIONNEMENT,&POINT. */
10803
10804 /* INPUT ARGUMENTS : */
10805 /* ------------------ */
10806 /* NCOEFF : NUMBER OF COEFFICIENTS OF THE CURVE */
10807 /* CURVE2 : EQUATION OF CURVE 2D */
10808 /* TPARAM : VALUE OF PARAMETER AT GIVEN POINT */
10809
10810 /* OUTPUT ARGUMENTS : */
10811 /* ------------------- */
10812 /* PNTCRB : COORDINATES OF POINT CORRESPONDING TO PARAMETER */
10813 /* TPARAM ON CURVE 2D CURVE2. */
10814
10815 /* COMMONS USED : */
10816 /* ---------------- */
10817
10818 /* REFERENCES CALLED : */
10819 /* ---------------------- */
10820
10821 /* DESCRIPTION/NOTES/LIMITATIONS : */
10822 /* ----------------------------------- */
10823 /* MSCHEMA OF HORNER. */
10824
10825 /* > */
10826 /* **********************************************************************
10827 */
10828
10829
10830 /* -------- INITIALIZATIONS AND PROCESSING OF PARTICULAR CASES ----------
10831 */
10832
10833 /* ---> Cas when NCOEFF > 1 (case STANDARD). */
10834 /* Parameter adjustments */
10835 --pntcrb;
10836 curve2 -= 3;
10837
10838 /* Function Body */
10839 if (*ncoeff >= 2) {
10840 goto L1000;
10841 }
10842 /* ---> Case when NCOEFF <= 1. */
10843 if (*ncoeff <= 0) {
10844 pntcrb[1] = 0.;
10845 pntcrb[2] = 0.;
10846 goto L9999;
10847 } else if (*ncoeff == 1) {
10848 pntcrb[1] = curve2[3];
10849 pntcrb[2] = curve2[4];
10850 goto L9999;
10851 }
10852
10853 /* -------------------- MSCHEMA OF HORNER (PARTICULAR CASE) --------------
10854 */
10855
10856 L1000:
10857
10858 if (*tparam == 1.) {
10859 xxx = 0.;
10860 yyy = 0.;
10861 i__1 = *ncoeff;
10862 for (kk = 1; kk <= i__1; ++kk) {
10863 xxx += curve2[(kk << 1) + 1];
10864 yyy += curve2[(kk << 1) + 2];
10865 /* L100: */
10866 }
10867 goto L5000;
10868 } else if (*tparam == 0.) {
10869 pntcrb[1] = curve2[3];
10870 pntcrb[2] = curve2[4];
10871 goto L9999;
10872 }
10873
10874 /* ---------------------------- MSCHEMA OF HORNER ------------------------
10875 */
10876 /* ---> TPARAM is different from 1.D0 and 0.D0. */
10877
10878 ndeg = *ncoeff - 1;
10879 xxx = curve2[(*ncoeff << 1) + 1];
10880 yyy = curve2[(*ncoeff << 1) + 2];
10881 for (kk = ndeg; kk >= 1; --kk) {
10882 xxx = xxx * *tparam + curve2[(kk << 1) + 1];
10883 yyy = yyy * *tparam + curve2[(kk << 1) + 2];
10884 /* L200: */
10885 }
10886 goto L5000;
10887
10888 /* ------------------------ RECOVER THE CALCULATED POINT ---------------
10889 */
10890
10891 L5000:
10892 pntcrb[1] = xxx;
10893 pntcrb[2] = yyy;
10894
10895 /* ------------------------------ THE END -------------------------------
10896 */
10897
10898 L9999:
10899 return 0;
10900 } /* mvpscr2_ */
10901
10902 //=======================================================================
10903 //function : mvpscr3_
10904 //purpose :
10905 //=======================================================================
mvpscr3_(integer * ncoeff,doublereal * curve3,doublereal * tparam,doublereal * pntcrb)10906 int mvpscr3_(integer *ncoeff,
10907 doublereal *curve3,
10908 doublereal *tparam,
10909 doublereal *pntcrb)
10910
10911 {
10912 /* System generated locals */
10913 integer i__1;
10914
10915 /* Local variables */
10916 integer ndeg, kk;
10917 doublereal xxx, yyy, zzz;
10918
10919
10920
10921 /* **********************************************************************
10922 */
10923
10924 /* FUNCTION : */
10925 /* ---------- */
10926 /* POSITIONING ON A CURVE (3,NCF) IN THE SPACE OF DIMENSION 3. */
10927
10928 /* KEYWORDS : */
10929 /* ----------- */
10930 /* TOUS, MATH_ACCES:: COURBE&,POSITIONNEMENT,&POINT. */
10931
10932 /* INPUT ARGUMENTS : */
10933 /* ------------------ */
10934 /* NCOEFF : NB OF COEFFICIENTS OF THE CURVE */
10935 /* CURVE3 : EQUATION OF CURVE 3D */
10936 /* TPARAM : VALUE OF THE PARAMETER AT THE GIVEN POINT */
10937
10938 /* OUTPUT ARGUMENTS : */
10939 /* ------------------- */
10940 /* PNTCRB : COORDINATES OF THE POINT CORRESPONDING TO PARAMETER */
10941 /* TPARAM ON CURVE 3D CURVE3. */
10942
10943 /* COMMONS USED : */
10944 /* ---------------- */
10945
10946 /* REFERENCES CALLED : */
10947 /* ---------------------- */
10948 /* Neant */
10949
10950 /* DESCRIPTION/NOTES/LIMITATIONS : */
10951 /* ----------------------------------- */
10952 /* MSCHEMA OF HORNER. */
10953 /* > */
10954 /* **********************************************************************
10955 */
10956 /* DECLARATIONS */
10957 /* **********************************************************************
10958 */
10959
10960
10961 /* -------- INITIALISATIONS AND PROCESSING OF PARTICULAR CASES ----------
10962 */
10963
10964 /* ---> Case when NCOEFF > 1 (cas STANDARD). */
10965 /* Parameter adjustments */
10966 --pntcrb;
10967 curve3 -= 4;
10968
10969 /* Function Body */
10970 if (*ncoeff >= 2) {
10971 goto L1000;
10972 }
10973 /* ---> Case when NCOEFF <= 1. */
10974 if (*ncoeff <= 0) {
10975 pntcrb[1] = 0.;
10976 pntcrb[2] = 0.;
10977 pntcrb[3] = 0.;
10978 goto L9999;
10979 } else if (*ncoeff == 1) {
10980 pntcrb[1] = curve3[4];
10981 pntcrb[2] = curve3[5];
10982 pntcrb[3] = curve3[6];
10983 goto L9999;
10984 }
10985
10986 /* -------------------- MSCHEMA OF HORNER (PARTICULAR CASE) --------------
10987 */
10988
10989 L1000:
10990
10991 if (*tparam == 1.) {
10992 xxx = 0.;
10993 yyy = 0.;
10994 zzz = 0.;
10995 i__1 = *ncoeff;
10996 for (kk = 1; kk <= i__1; ++kk) {
10997 xxx += curve3[kk * 3 + 1];
10998 yyy += curve3[kk * 3 + 2];
10999 zzz += curve3[kk * 3 + 3];
11000 /* L100: */
11001 }
11002 goto L5000;
11003 } else if (*tparam == 0.) {
11004 pntcrb[1] = curve3[4];
11005 pntcrb[2] = curve3[5];
11006 pntcrb[3] = curve3[6];
11007 goto L9999;
11008 }
11009
11010 /* ---------------------------- MSCHEMA OF HORNER ------------------------
11011 */
11012 /* ---> Here TPARAM is different from 1.D0 and 0.D0. */
11013
11014 ndeg = *ncoeff - 1;
11015 xxx = curve3[*ncoeff * 3 + 1];
11016 yyy = curve3[*ncoeff * 3 + 2];
11017 zzz = curve3[*ncoeff * 3 + 3];
11018 for (kk = ndeg; kk >= 1; --kk) {
11019 xxx = xxx * *tparam + curve3[kk * 3 + 1];
11020 yyy = yyy * *tparam + curve3[kk * 3 + 2];
11021 zzz = zzz * *tparam + curve3[kk * 3 + 3];
11022 /* L200: */
11023 }
11024 goto L5000;
11025
11026 /* ------------------------ RETURN THE CALCULATED POINT ------------------
11027 */
11028
11029 L5000:
11030 pntcrb[1] = xxx;
11031 pntcrb[2] = yyy;
11032 pntcrb[3] = zzz;
11033
11034 /* ------------------------------ THE END -------------------------------
11035 */
11036
11037 L9999:
11038 return 0;
11039 } /* mvpscr3_ */
11040
11041 //=======================================================================
11042 //function : AdvApp2Var_MathBase::mvsheld_
11043 //purpose :
11044 //=======================================================================
mvsheld_(integer * n,integer * is,doublereal * dtab,integer * icle)11045 int AdvApp2Var_MathBase::mvsheld_(integer *n,
11046 integer *is,
11047 doublereal *dtab,
11048 integer *icle)
11049
11050 {
11051 /* System generated locals */
11052 integer dtab_dim1, dtab_offset, i__1, i__2;
11053
11054 /* Local variables */
11055 integer incr;
11056 doublereal dsave;
11057 integer i3, i4, i5, incrp1;
11058
11059
11060 /************************************************************************
11061 *******/
11062
11063 /* FUNCTION : */
11064 /* ---------- */
11065 /* PARSING OF COLUMNS OF TABLE OF REAL*8 BY SHELL METHOD*/
11066 /* (IN INCREASING ORDER) */
11067
11068 /* KEYWORDS : */
11069 /* ----------- */
11070 /* POINT-ENTRY, PARSING, SHELL */
11071
11072 /* INPUT ARGUMENTS : */
11073 /* ------------------ */
11074 /* N : NUMBER OF COLUMNS OF THE TABLE */
11075 /* IS : NUMBER OF LINE OF THE TABLE */
11076 /* DTAB : TABLE OF REAL*8 TO BE PARSED */
11077 /* ICLE : POSITION OF THE KEY ON THE COLUMN */
11078
11079 /* OUTPUT ARGUMENTS : */
11080 /* ------------------- */
11081 /* DTAB : PARSED TABLE */
11082
11083 /* COMMONS USED : */
11084 /* ---------------- */
11085
11086
11087 /* REFERENCES CALLED : */
11088 /* ---------------------- */
11089 /* Neant */
11090
11091 /* DESCRIPTION/NOTES/LIMITATIONS : */
11092 /* ----------------------------------- */
11093 /* CLASSIC SHELL METHOD : PARSING BY SERIES */
11094 /* Declaration DTAB(IS, 1) corresponds to DTAB(IS, *) */
11095 /* > */
11096 /* ***********************************************************************
11097 */
11098
11099
11100 /* Parameter adjustments */
11101 dtab_dim1 = *is;
11102 dtab_offset = dtab_dim1 + 1;
11103 dtab -= dtab_offset;
11104
11105 /* Function Body */
11106 if (*n <= 1) {
11107 goto L9900;
11108 }
11109 /* ------------------------ */
11110
11111 /* INITIALIZATION OF THE SEQUENCE OF INCREMENTS */
11112 /* FIND THE GREATEST INCREMENT SO THAT INCR < N/9 */
11113
11114 incr = 1;
11115 L1001:
11116 if (incr >= *n / 9) {
11117 goto L1002;
11118 }
11119 /* ----------------------------- */
11120 incr = incr * 3 + 1;
11121 goto L1001;
11122
11123 /* LOOP ON INCREMENTS TILL INCR = 1 */
11124 /* PARSING BY SERIES DISTANT FROM INCR */
11125
11126 L1002:
11127 incrp1 = incr + 1;
11128 /* ----------------- */
11129 i__1 = *n;
11130 for (i3 = incrp1; i3 <= i__1; ++i3) {
11131 /* ---------------------- */
11132
11133 /* SET ELEMENT I3 AT ITS PLACE IN THE SERIES */
11134
11135 i4 = i3 - incr;
11136 L1004:
11137 if (i4 < 1) {
11138 goto L1003;
11139 }
11140 /* ------------------------- */
11141 if (dtab[*icle + i4 * dtab_dim1] <= dtab[*icle + (i4 + incr) *
11142 dtab_dim1]) {
11143 goto L1003;
11144 }
11145
11146 i__2 = *is;
11147 for (i5 = 1; i5 <= i__2; ++i5) {
11148 /* ------------------ */
11149 dsave = dtab[i5 + i4 * dtab_dim1];
11150 dtab[i5 + i4 * dtab_dim1] = dtab[i5 + (i4 + incr) * dtab_dim1];
11151 dtab[i5 + (i4 + incr) * dtab_dim1] = dsave;
11152 }
11153 /* -------- */
11154 i4 -= incr;
11155 goto L1004;
11156
11157 L1003:
11158 ;
11159 }
11160 /* -------- */
11161
11162 /* PASSAGE TO THE NEXT INCREMENT */
11163
11164 incr /= 3;
11165 if (incr >= 1) {
11166 goto L1002;
11167 }
11168
11169 L9900:
11170 return 0 ;
11171 } /* mvsheld_ */
11172
11173 //=======================================================================
11174 //function : AdvApp2Var_MathBase::mzsnorm_
11175 //purpose :
11176 //=======================================================================
mzsnorm_(integer * ndimen,doublereal * vecteu)11177 doublereal AdvApp2Var_MathBase::mzsnorm_(integer *ndimen,
11178 doublereal *vecteu)
11179
11180 {
11181 /* System generated locals */
11182 integer i__1;
11183 doublereal ret_val, d__1, d__2;
11184
11185 /* Local variables */
11186 doublereal xsom;
11187 integer i__, irmax;
11188
11189
11190
11191 /* ***********************************************************************
11192 */
11193
11194 /* FUNCTION : */
11195 /* ---------- */
11196 /* SERVES to calculate the euclidian norm of a vector : */
11197 /* ____________________________ */
11198 /* Z = V V(1)**2 + V(2)**2 + ... */
11199
11200 /* KEYWORDS : */
11201 /* ----------- */
11202 /* SURMFACIQUE, */
11203
11204 /* INPUT ARGUMENTS : */
11205 /* ------------------ */
11206 /* NDIMEN : Dimension of the vector */
11207 /* VECTEU : vector of dimension NDIMEN */
11208
11209 /* OUTPUT ARGUMENTS : */
11210 /* ------------------- */
11211 /* MZSNORM : Value of the euclidian norm of vector VECTEU */
11212
11213 /* COMMONS USED : */
11214 /* ---------------- */
11215
11216 /* .Neant. */
11217
11218 /* REFERENCES CALLED : */
11219 /* ---------------------- */
11220 /* Type Name */
11221 /* R*8 ABS R*8 SQRT */
11222
11223 /* DESCRIPTION/NOTESS/LIMITATIONS : */
11224 /* ----------------------------------- */
11225 /* To limit the risks of overflow, */
11226 /* the term of the strongest absolute value is factorized : */
11227 /* _______________________ */
11228 /* Z = !V(1)! * V 1 + (V(2)/V(1))**2 + ... */
11229
11230 /* > */
11231 /* ***********************************************************************
11232 */
11233 /* DECLARATIONS */
11234 /* ***********************************************************************
11235 */
11236
11237
11238 /* ***********************************************************************
11239 */
11240 /* PROCESSING */
11241 /* ***********************************************************************
11242 */
11243
11244 /* ___ Find the strongest absolute value term */
11245
11246 /* Parameter adjustments */
11247 --vecteu;
11248
11249 /* Function Body */
11250 irmax = 1;
11251 i__1 = *ndimen;
11252 for (i__ = 2; i__ <= i__1; ++i__) {
11253 if ((d__1 = vecteu[irmax], advapp_abs(d__1)) < (d__2 = vecteu[i__], advapp_abs(d__2)
11254 )) {
11255 irmax = i__;
11256 }
11257 /* L100: */
11258 }
11259
11260 /* ___ Calculate the norme */
11261
11262 if ((d__1 = vecteu[irmax], advapp_abs(d__1)) < 1.) {
11263 xsom = 0.;
11264 i__1 = *ndimen;
11265 for (i__ = 1; i__ <= i__1; ++i__) {
11266 /* Computing 2nd power */
11267 d__1 = vecteu[i__];
11268 xsom += d__1 * d__1;
11269 /* L200: */
11270 }
11271 ret_val = sqrt(xsom);
11272 } else {
11273 xsom = 0.;
11274 i__1 = *ndimen;
11275 for (i__ = 1; i__ <= i__1; ++i__) {
11276 if (i__ == irmax) {
11277 xsom += 1.;
11278 } else {
11279 /* Computing 2nd power */
11280 d__1 = vecteu[i__] / vecteu[irmax];
11281 xsom += d__1 * d__1;
11282 }
11283 /* L300: */
11284 }
11285 ret_val = (d__1 = vecteu[irmax], advapp_abs(d__1)) * sqrt(xsom);
11286 }
11287
11288 /* ***********************************************************************
11289 */
11290 /* RETURN CALLING PROGRAM */
11291 /* ***********************************************************************
11292 */
11293
11294 return ret_val;
11295 } /* mzsnorm_ */
11296
11297