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 #include <AdvApp2Var_SysBase.hxx>
15 #include <AdvApp2Var_MathBase.hxx>
16 #include <AdvApp2Var_Data_f2c.hxx>
17 #include <AdvApp2Var_Data.hxx>
18 #include <AdvApp2Var_ApproxF2var.hxx>
19
20 #include <cmath>
21
22 static
23 int mmjacpt_(const integer *ndimen,
24 const integer *ncoefu,
25 const integer *ncoefv,
26 const integer *iordru,
27 const integer *iordrv,
28 const doublereal *ptclgd,
29 doublereal *ptcaux,
30 doublereal *ptccan);
31
32
33
34 static
35 int mma2ce2_(integer *numdec,
36 integer *ndimen,
37 integer *nbsesp,
38 integer *ndimse,
39 integer *ndminu,
40 integer *ndminv,
41 integer *ndguli,
42 integer *ndgvli,
43 integer *ndjacu,
44 integer *ndjacv,
45 integer *iordru,
46 integer *iordrv,
47 integer *nbpntu,
48 integer *nbpntv,
49 doublereal *epsapr,
50 doublereal *sosotb,
51 doublereal *disotb,
52 doublereal *soditb,
53 doublereal *diditb,
54 doublereal *gssutb,
55 doublereal *gssvtb,
56 doublereal *xmaxju,
57 doublereal *xmaxjv,
58 doublereal *vecerr,
59 doublereal *chpair,
60 doublereal *chimpr,
61 doublereal *patjac,
62 doublereal *errmax,
63 doublereal *errmoy,
64 integer *ndegpu,
65 integer *ndegpv,
66 integer *itydec,
67 integer *iercod);
68
69 static
70 int mma2cfu_(integer *ndujac,
71 integer *nbpntu,
72 integer *nbpntv,
73 doublereal *sosotb,
74 doublereal *disotb,
75 doublereal *soditb,
76 doublereal *diditb,
77 doublereal *gssutb,
78 doublereal *chpair,
79 doublereal *chimpr);
80
81 static
82 int mma2cfv_(integer *ndvjac,
83 integer *mindgu,
84 integer *maxdgu,
85 integer *nbpntv,
86 doublereal *gssvtb,
87 doublereal *chpair,
88 doublereal *chimpr,
89 doublereal *patjac);
90
91 static
92 int mma2er1_(integer *ndjacu,
93 integer *ndjacv,
94 integer *ndimen,
95 integer *mindgu,
96 integer *maxdgu,
97 integer *mindgv,
98 integer *maxdgv,
99 integer *iordru,
100 integer *iordrv,
101 doublereal *xmaxju,
102 doublereal *xmaxjv,
103 doublereal *patjac,
104 doublereal *vecerr,
105 doublereal *erreur);
106
107 static
108 int mma2er2_(integer *ndjacu,
109 integer *ndjacv,
110 integer *ndimen,
111 integer *mindgu,
112 integer *maxdgu,
113 integer *mindgv,
114 integer *maxdgv,
115 integer *iordru,
116 integer *iordrv,
117 doublereal *xmaxju,
118 doublereal *xmaxjv,
119 doublereal *patjac,
120 doublereal *epmscut,
121 doublereal *vecerr,
122 doublereal *erreur,
123 integer *newdgu,
124 integer *newdgv);
125
126 static
127 int mma2moy_(integer *ndgumx,
128 integer *ndgvmx,
129 integer *ndimen,
130 integer *mindgu,
131 integer *maxdgu,
132 integer *mindgv,
133 integer *maxdgv,
134 integer *iordru,
135 integer *iordrv,
136 doublereal *patjac,
137 doublereal *errmoy);
138
139 static
140 int mma2ds2_(integer *ndimen,
141 doublereal *uintfn,
142 doublereal *vintfn,
143 const AdvApp2Var_EvaluatorFunc2Var& foncnp,
144 integer *nbpntu,
145 integer *nbpntv,
146 doublereal *urootb,
147 doublereal *vrootb,
148 integer *iiuouv,
149 doublereal *sosotb,
150 doublereal *disotb,
151 doublereal *soditb,
152 doublereal *diditb,
153 doublereal *fpntab,
154 doublereal *ttable,
155 integer *iercod);
156
157
158
159
160 static
161 int mma1fdi_(integer *ndimen,
162 doublereal *uvfonc,
163 const AdvApp2Var_EvaluatorFunc2Var& foncnp,
164 integer *isofav,
165 doublereal *tconst,
166 integer *nbroot,
167 doublereal *ttable,
168 integer *iordre,
169 integer *ideriv,
170 doublereal *fpntab,
171 doublereal *somtab,
172 doublereal *diftab,
173 doublereal *contr1,
174 doublereal *contr2,
175 integer *iercod);
176
177 static
178 int mma1cdi_(integer *ndimen,
179 integer *nbroot,
180 doublereal *rootlg,
181 integer *iordre,
182 doublereal *contr1,
183 doublereal *contr2,
184 doublereal *somtab,
185 doublereal *diftab,
186 doublereal *fpntab,
187 doublereal *hermit,
188 integer *iercod);
189 static
190 int mma1jak_(integer *ndimen,
191 integer *nbroot,
192 integer *iordre,
193 integer *ndgjac,
194 doublereal *somtab,
195 doublereal *diftab,
196 doublereal *cgauss,
197 doublereal *crvjac,
198 integer *iercod);
199 static
200 int mma1cnt_(integer *ndimen,
201 integer *iordre,
202 doublereal *contr1,
203 doublereal *contr2,
204 doublereal *hermit,
205 integer *ndgjac,
206 doublereal *crvjac);
207
208 static
209 int mma1fer_(integer *ndimen,
210 integer *nbsesp,
211 integer *ndimse,
212 integer *iordre,
213 integer *ndgjac,
214 doublereal *crvjac,
215 integer *ncflim,
216 doublereal *epsapr,
217 doublereal *ycvmax,
218 doublereal *errmax,
219 doublereal *errmoy,
220 integer *ncoeff,
221 integer *iercod);
222
223 static
224 int mma1noc_(doublereal *dfuvin,
225 integer *ndimen,
226 integer *iordre,
227 doublereal *cntrin,
228 doublereal *duvout,
229 integer *isofav,
230 integer *ideriv,
231 doublereal *cntout);
232
233
234 static
235 int mmmapcoe_(integer *ndim,
236 integer *ndgjac,
237 integer *iordre,
238 integer *nbpnts,
239 doublereal *somtab,
240 doublereal *diftab,
241 doublereal *gsstab,
242 doublereal *crvjac);
243
244 static
245 int mmaperm_(integer *ncofmx,
246 integer *ndim,
247 integer *ncoeff,
248 integer *iordre,
249 doublereal *crvjac,
250 integer *ncfnew,
251 doublereal *errmoy);
252
253
254 #define mmapgss_1 mmapgss_
255 #define mmapgs0_1 mmapgs0_
256 #define mmapgs1_1 mmapgs1_
257 #define mmapgs2_1 mmapgs2_
258
259 //=======================================================================
260 //function : mma1cdi_
261 //purpose :
262 //=======================================================================
mma1cdi_(integer * ndimen,integer * nbroot,doublereal * rootlg,integer * iordre,doublereal * contr1,doublereal * contr2,doublereal * somtab,doublereal * diftab,doublereal * fpntab,doublereal * hermit,integer * iercod)263 int mma1cdi_(integer *ndimen,
264 integer *nbroot,
265 doublereal *rootlg,
266 integer *iordre,
267 doublereal *contr1,
268 doublereal *contr2,
269 doublereal *somtab,
270 doublereal *diftab,
271 doublereal *fpntab,
272 doublereal *hermit,
273 integer *iercod)
274 {
275 integer c__1 = 1;
276
277 /* System generated locals */
278 integer contr1_dim1, contr1_offset, contr2_dim1, contr2_offset,
279 somtab_dim1, somtab_offset, diftab_dim1, diftab_offset,
280 fpntab_dim1, fpntab_offset, hermit_dim1, hermit_offset, i__1,
281 i__2, i__3;
282
283 /* Local variables */
284 integer nroo2, ncfhe, nd, ii, kk;
285 integer ibb, kkm, kkp;
286 doublereal bid1, bid2, bid3 = 0.;
287
288 /* **********************************************************************
289 */
290 /* FUNCTION : */
291 /* ---------- */
292 /* Discretisation on the parameters of interpolation polynomes */
293 /* constraints of order IORDRE. */
294
295 /* KEYWORDS : */
296 /* ----------- */
297 /* ALL, AB_SPECIFI::CONTRAINTE&, DISCRETISATION, &POINT */
298
299 /* INPUT ARGUMENTS : */
300 /* ------------------ */
301 /* NDIMEN: Space dimension. */
302 /* NBROOT: Number of INTERNAL discretisation parameters. */
303 /* It is also the root number Legendre polynome where */
304 /* the discretization is performed. */
305 /* ROOTLG: Table of discretization parameters ON (-1,1). */
306 /* IORDRE: Order of constraint imposed to the extremities of the iso. */
307 /* = 0, the extremities of the iso are calculated */
308 /* = 1, additionally, the 1st derivative in the direction */
309 /* of the iso is calculated. */
310 /* = 2, additionally, the 2nd derivative in the direction */
311 /* of the iso is calculated. */
312 /* CONTR1: Contains, if IORDRE>=0, values IORDRE+1 in TTABLE(0)
313 */
314 /* (1st extremity) of derivatives of F(Uc,Ve) or F(Ue,Vc), */
315 /* see below. */
316 /* CONTR2: Contains, if IORDRE>=0, values IORDRE+1 in */
317 /* TTABLE(NBROOT+1) (2nd extremity) of: */
318 /* If ISOFAV=1, derived of order IDERIV by U, derived */
319 /* ordre 0 to IORDRE by V of F(Uc,Ve) or Uc=TCONST */
320 /* (fixed iso value) and Ve is the fixed extremity. */
321 /* If ISOFAV=2, derivative of order IDERIV by V, derivative */
322 /* of order 0 to IORDRE by U of F(Ue,Vc) or Vc=TCONST */
323 /* (fixed iso value) and Ue is the fixed extremity. */
324
325 /* SOMTAB: Table of NBROOT/2 sums of 2 index points */
326 /* NBROOT-II+1 and II, for II = 1, NBROOT/2. */
327 /* DIFTAB: Table of NBROOT/2 differences of 2 index points */
328 /* NBROOT-II+1 and II, for II = 1, NBROOT/2. */
329
330 /* OUTPUT ARGUMENTS : */
331 /* ------------------- */
332 /* SOMTAB: Table of NBROOT/2 sums of 2 index points */
333 /* NBROOT-II+1 and II, for II = 1, NBROOT/2 */
334 /* DIFTAB: Table of NBROOT/2 differences of 2 index points */
335 /* NBROOT-II+1 and II, for II = 1, NBROOT/2 */
336 /* FPNTAB: Auxiliary table. */
337 /* HERMIT: Table of coeff. 2*(IORDRE+1) Hermite polynoms */
338 /* of degree 2*IORDRE+1. */
339 /* IERCOD: Error code, */
340 /* = 0, Everythig is OK */
341 /* = 1, The value of IORDRE is out of (0,2) */
342 /* COMMON USED : */
343 /* ---------------- */
344
345 /* REFERENCES CALLED : */
346 /* ----------------------- */
347
348 /* DESCRIPTION/NOTES/LIMITATIONS : */
349 /* ----------------------------------- */
350 /* The results of discretization are arranged in 2 tables */
351 /* SOMTAB and DIFTAB to earn time during the */
352 /* calculation of coefficients of the approximation curve. */
353
354 /* If NBROOT is uneven in SOMTAB(0,*) and DIFTAB(0,*) one stores */
355 /* the values of the median root of Legendre (0.D0 in (-1,1)). */
356
357 /* **********************************************************************
358 */
359
360 /* Name of the routine */
361
362
363 /* Parameter adjustments */
364 diftab_dim1 = *nbroot / 2 + 1;
365 diftab_offset = diftab_dim1;
366 diftab -= diftab_offset;
367 somtab_dim1 = *nbroot / 2 + 1;
368 somtab_offset = somtab_dim1;
369 somtab -= somtab_offset;
370 --rootlg;
371 hermit_dim1 = (*iordre << 1) + 2;
372 hermit_offset = hermit_dim1;
373 hermit -= hermit_offset;
374 fpntab_dim1 = *nbroot;
375 fpntab_offset = fpntab_dim1 + 1;
376 fpntab -= fpntab_offset;
377 contr2_dim1 = *ndimen;
378 contr2_offset = contr2_dim1 + 1;
379 contr2 -= contr2_offset;
380 contr1_dim1 = *ndimen;
381 contr1_offset = contr1_dim1 + 1;
382 contr1 -= contr1_offset;
383
384 /* Function Body */
385 ibb = AdvApp2Var_SysBase::mnfndeb_();
386 if (ibb >= 3) {
387 AdvApp2Var_SysBase::mgenmsg_("MMA1CDI", 7L);
388 }
389 *iercod = 0;
390
391 /* --- Recuperate 2*(IORDRE+1) coeff of 2*(IORDRE+1) of Hermite polynom ---
392 */
393
394 AdvApp2Var_ApproxF2var::mma1her_(iordre, &hermit[hermit_offset], iercod);
395 if (*iercod > 0) {
396 goto L9100;
397 }
398
399 /* ------------------- Discretization of Hermite polynoms -----------
400 */
401
402 ncfhe = (*iordre + 1) << 1;
403 i__1 = ncfhe;
404 for (ii = 1; ii <= i__1; ++ii) {
405 i__2 = *nbroot;
406 for (kk = 1; kk <= i__2; ++kk) {
407 AdvApp2Var_MathBase::mmmpocur_(&ncfhe, &c__1, &ncfhe, &hermit[ii * hermit_dim1], &
408 rootlg[kk], &fpntab[kk + ii * fpntab_dim1]);
409 /* L200: */
410 }
411 /* L100: */
412 }
413
414 /* ---- Discretizations of boundary polynoms are taken ----
415 */
416
417 nroo2 = *nbroot / 2;
418 i__1 = *ndimen;
419 for (nd = 1; nd <= i__1; ++nd) {
420 i__2 = *iordre + 1;
421 for (ii = 1; ii <= i__2; ++ii) {
422 bid1 = contr1[nd + ii * contr1_dim1];
423 bid2 = contr2[nd + ii * contr2_dim1];
424 i__3 = nroo2;
425 for (kk = 1; kk <= i__3; ++kk) {
426 kkm = nroo2 - kk + 1;
427 bid3 = bid1 * fpntab[kkm + ((ii << 1) - 1) * fpntab_dim1] +
428 bid2 * fpntab[kkm + (ii << 1) * fpntab_dim1];
429 somtab[kk + nd * somtab_dim1] -= bid3;
430 diftab[kk + nd * diftab_dim1] += bid3;
431 /* L500: */
432 }
433 i__3 = nroo2;
434 for (kk = 1; kk <= i__3; ++kk) {
435 kkp = (*nbroot + 1) / 2 + kk;
436 bid3 = bid1 * fpntab[kkp + ((ii << 1) - 1) * fpntab_dim1] +
437 bid2 * fpntab[kkp + (ii << 1) * fpntab_dim1];
438 somtab[kk + nd * somtab_dim1] -= bid3;
439 diftab[kk + nd * diftab_dim1] -= bid3;
440 /* L600: */
441 }
442 /* L400: */
443 }
444 /* L300: */
445 }
446
447 /* ------------ Cas when discretization is done on the roots of a -----------
448 */
449 /* ---------- Legendre polynom of uneven degree, 0 is root --------
450 */
451
452 if (*nbroot % 2 == 1) {
453 i__1 = *ndimen;
454 for (nd = 1; nd <= i__1; ++nd) {
455 i__2 = *iordre + 1;
456 for (ii = 1; ii <= i__2; ++ii) {
457 bid3 = fpntab[nroo2 + 1 + ((ii << 1) - 1) * fpntab_dim1] *
458 contr1[nd + ii * contr1_dim1] + fpntab[nroo2 + 1 + (
459 ii << 1) * fpntab_dim1] * contr2[nd + ii *
460 contr2_dim1];
461 /* L800: */
462 }
463 somtab[nd * somtab_dim1] -= bid3;
464 diftab[nd * diftab_dim1] -= bid3;
465 /* L700: */
466 }
467 }
468
469 goto L9999;
470
471 /* ------------------------------ The End -------------------------------
472 */
473 /* --> IORDRE is not in the authorized zone. */
474 L9100:
475 *iercod = 1;
476 goto L9999;
477
478 L9999:
479 if (ibb >= 3) {
480 AdvApp2Var_SysBase::mgsomsg_("MMA1CDI", 7L);
481 }
482 return 0;
483 } /* mma1cdi_ */
484
485 //=======================================================================
486 //function : mma1cnt_
487 //purpose :
488 //=======================================================================
mma1cnt_(integer * ndimen,integer * iordre,doublereal * contr1,doublereal * contr2,doublereal * hermit,integer * ndgjac,doublereal * crvjac)489 int mma1cnt_(integer *ndimen,
490 integer *iordre,
491 doublereal *contr1,
492 doublereal *contr2,
493 doublereal *hermit,
494 integer *ndgjac,
495 doublereal *crvjac)
496 {
497 /* System generated locals */
498 integer contr1_dim1, contr1_offset, contr2_dim1, contr2_offset,
499 hermit_dim1, hermit_offset, crvjac_dim1, crvjac_offset, i__1,
500 i__2, i__3;
501
502 /* Local variables */
503 integer nd, ii, jj, ibb;
504 doublereal bid;
505
506
507 /* ***********************************************************************
508 */
509
510 /* FUNCTION : */
511 /* ---------- */
512 /* Add constraint to polynom. */
513
514 /* MOTS CLES : */
515 /* ----------- */
516 /* ALL,AB_SPECIFI::COURE&,APPROXIMATION,ADDITION,&CONSTRAINT */
517
518 /* INPUT ARGUMENTS : */
519 /* -------------------- */
520 /* NDIMEN: Dimension of the space */
521 /* IORDRE: Order of constraint. */
522 /* CONTR1: pt of constraint in -1, from order 0 to IORDRE. */
523 /* CONTR2: Pt of constraint in +1, from order 0 to IORDRE. */
524 /* HERMIT: Table of Hermit polynoms of order IORDRE. */
525 /* CRVJAV: Curve of approximation in Jacobi base. */
526
527 /* OUTPUT ARGUMENTS : */
528 /* --------------------- */
529 /* CRVJAV: Curve of approximation in Jacobi base */
530 /* to which the polynom of interpolation of constraints is added. */
531
532 /* COMMON USED : */
533 /* ------------------ */
534
535
536 /* REFERENCES CALLED : */
537 /* --------------------- */
538
539
540 /* DESCRIPTION/NOTES/LIMITATIONS : */
541 /* ----------------------------------- */
542
543 /* > */
544 /* ***********************************************************************
545 */
546 /* DECLARATIONS */
547 /* ***********************************************************************
548 */
549 /* Name of the routine */
550
551 /* ***********************************************************************
552 */
553 /* INITIALISATIONS */
554 /* ***********************************************************************
555 */
556
557 /* Parameter adjustments */
558 hermit_dim1 = (*iordre << 1) + 2;
559 hermit_offset = hermit_dim1;
560 hermit -= hermit_offset;
561 contr2_dim1 = *ndimen;
562 contr2_offset = contr2_dim1 + 1;
563 contr2 -= contr2_offset;
564 contr1_dim1 = *ndimen;
565 contr1_offset = contr1_dim1 + 1;
566 contr1 -= contr1_offset;
567 crvjac_dim1 = *ndgjac + 1;
568 crvjac_offset = crvjac_dim1;
569 crvjac -= crvjac_offset;
570
571 /* Function Body */
572 ibb = AdvApp2Var_SysBase::mnfndeb_();
573 if (ibb >= 3) {
574 AdvApp2Var_SysBase::mgenmsg_("MMA1CNT", 7L);
575 }
576
577 /* ***********************************************************************
578 */
579 /* Processing */
580 /* ***********************************************************************
581 */
582
583 i__1 = *ndimen;
584 for (nd = 1; nd <= i__1; ++nd) {
585 i__2 = (*iordre << 1) + 1;
586 for (ii = 0; ii <= i__2; ++ii) {
587 bid = 0.;
588 i__3 = *iordre + 1;
589 for (jj = 1; jj <= i__3; ++jj) {
590 bid = bid + contr1[nd + jj * contr1_dim1] *
591 hermit[ii + ((jj << 1) - 1) * hermit_dim1] +
592 contr2[nd + jj * contr2_dim1] * hermit[ii + (jj << 1) * hermit_dim1];
593 /* L300: */
594 }
595 crvjac[ii + nd * crvjac_dim1] = bid;
596 /* L200: */
597 }
598 /* L100: */
599 }
600
601 /* ***********************************************************************
602 */
603 /* RETURN CALLING PROGRAM */
604 /* ***********************************************************************
605 */
606
607 if (ibb >= 3) {
608 AdvApp2Var_SysBase::mgsomsg_("MMA1CNT", 7L);
609 }
610
611 return 0 ;
612 } /* mma1cnt_ */
613
614 //=======================================================================
615 //function : mma1fdi_
616 //purpose :
617 //=======================================================================
mma1fdi_(integer * ndimen,doublereal * uvfonc,const AdvApp2Var_EvaluatorFunc2Var & foncnp,integer * isofav,doublereal * tconst,integer * nbroot,doublereal * ttable,integer * iordre,integer * ideriv,doublereal * fpntab,doublereal * somtab,doublereal * diftab,doublereal * contr1,doublereal * contr2,integer * iercod)618 int mma1fdi_(integer *ndimen,
619 doublereal *uvfonc,
620 const AdvApp2Var_EvaluatorFunc2Var& foncnp,
621 integer *isofav,
622 doublereal *tconst,
623 integer *nbroot,
624 doublereal *ttable,
625 integer *iordre,
626 integer *ideriv,
627 doublereal *fpntab,
628 doublereal *somtab,
629 doublereal *diftab,
630 doublereal *contr1,
631 doublereal *contr2,
632 integer *iercod)
633 {
634 /* System generated locals */
635 integer fpntab_dim1, somtab_dim1, somtab_offset, diftab_dim1,
636 diftab_offset, contr1_dim1, contr1_offset, contr2_dim1,
637 contr2_offset, i__1, i__2;
638 doublereal d__1;
639
640 /* Local variables */
641 integer ideb, ifin, nroo2, ideru, iderv;
642 doublereal renor;
643 integer ii, nd, ibb, iim, nbp, iip;
644 doublereal bid1, bid2;
645
646 /* **********************************************************************
647 */
648
649 /* FUNCTION : */
650 /* ---------- */
651 /* DiscretiZation of a non-polynomial function F(U,V) or of */
652 /* its derivative with fixed isoparameter. */
653
654 /* KEYWORDS : */
655 /* ----------- */
656 /* ALL, AB_SPECIFI::FONCTION&, DISCRETISATION, &POINT */
657
658 /* INPUT ARGUMENTS : */
659 /* ------------------ */
660 /* NDIMEN: Space dimension. */
661 /* UVFONC: Limits of the path of definition by U and by V of the approximated function */
662 /* FONCNP: The NAME of the non-polynomial function to be approximated */
663 /* (external program). */
664 /* ISOFAV: Fixed isoparameter for the discretization; */
665 /* = 1, discretization with fixed U and variable V. */
666 /* = 2, discretization with fixed V and variable U. */
667 /* TCONST: Iso value is also fixed. */
668 /* NBROOT: Number of INTERNAL discretization parameters. */
669 /* (if there are constraints, 2 extremities should be added).
670 */
671 /* This is also the root number of the Legendre polynom where */
672 /* the discretization is done. */
673 /* TTABLE: Table of discretization parameters and of 2 extremities */
674 /* (Respectively (-1, NBROOT Legendre roots,1) */
675 /* reframed within the adequate interval. */
676 /* IORDRE: Order of constraint imposed on the extremities of the iso. */
677 /* (If Iso-U, it is necessary to calculate the derivatives by V and vice */
678 /* versa). */
679 /* = 0, the extremities of the iso are calculated. */
680 /* = 1, additionally the 1st derivative in the direction of the iso is calculated */
681 /* = 2, additionally the 2nd derivative in the direction of the iso is calculated */
682 /* IDERIV: Order of derivative transversal to fixed iso (If Iso-U=Uc */
683 /* is fixed, the derivative of order IDERIV is discretized by U of */
684 /* F(Uc,v). Same if iso-V is fixed). */
685 /* Varies from 0 (positioning) to 2 (2nd derivative). */
686
687 /* OUTPUT ARGUMENTS : */
688 /* ------------------- */
689 /* FPNTAB: Auxiliary table.
690 SOMTAB: Table of NBROOT/2 sums of 2 index points */
691 /* NBROOT-II+1 and II, for II = 1, NBROOT/2 */
692 /* DIFTAB: Table of NBROOT/2 differences of 2 index points */
693 /* NBROOT-II+1 and II, for II = 1, NBROOT/2 */
694 /* CONTR1: Contains, if IORDRE>=0, values IORDRE+1 in TTABLE(0)
695 */
696 /* (1st extremity) of derivatives of F(Uc,Ve) or F(Ue,Vc), */
697 /* see below. */
698 /* CONTR2: Contains, if IORDRE>=0, values IORDRE+1 in */
699 /* TTABLE(NBROOT+1) (2nd extremity) of: */
700 /* If ISOFAV=1, derived of order IDERIV by U, derived */
701 /* ordre 0 to IORDRE by V of F(Uc,Ve) or Uc=TCONST */
702 /* (fixed iso value) and Ve is the fixed extremity. */
703 /* If ISOFAV=2, derivative of order IDERIV by V, derivative */
704 /* of order 0 to IORDRE by U of F(Ue,Vc) or Vc=TCONST */
705 /* (fixed iso value) and Ue is the fixed extremity. */
706 /* IERCOD: Error code > 100; Pb in evaluation of FONCNP, */
707 /* the returned error code is equal to error code of FONCNP + 100. */
708
709 /* COMMONS USED : */
710 /* ---------------- */
711
712 /* REFERENCES CALLED : */
713 /* ----------------------- */
714
715 /* DESCRIPTION/NOTES/LIMITATIONS : */
716 /* ----------------------------------- */
717 /* The results of discretization are arranged in 2 tables */
718 /* SOMTAB and DIFTAB to earn time during the */
719 /* calculation of coefficients of the approximation curve. */
720
721 /* If NBROOT is uneven in SOMTAB(0,*) and DIFTAB(0,*) one stores */
722 /* the values of the median root of Legendre (0.D0 in (-1,1)). */
723
724 /* Function F(u,v) defined in UVFONC is reparameterized in */
725 /* (-1,1)x(-1,1). Then 1st and 2nd derivatives are renormalized. */
726
727 /* > */
728 /* **********************************************************************
729 */
730
731 /* Name of the routine */
732
733
734 /* Parameter adjustments */
735 uvfonc -= 3;
736 diftab_dim1 = *nbroot / 2 + 1;
737 diftab_offset = diftab_dim1;
738 diftab -= diftab_offset;
739 somtab_dim1 = *nbroot / 2 + 1;
740 somtab_offset = somtab_dim1;
741 somtab -= somtab_offset;
742 fpntab_dim1 = *ndimen;
743 --fpntab;
744 contr2_dim1 = *ndimen;
745 contr2_offset = contr2_dim1 + 1;
746 contr2 -= contr2_offset;
747 contr1_dim1 = *ndimen;
748 contr1_offset = contr1_dim1 + 1;
749 contr1 -= contr1_offset;
750
751 /* Function Body */
752 ibb = AdvApp2Var_SysBase::mnfndeb_();
753 if (ibb >= 3) {
754 AdvApp2Var_SysBase::mgenmsg_("MMA1FDI", 7L);
755 }
756 *iercod = 0;
757
758 /* --------------- Definition of the nb of points to calculate --------------
759 */
760 /* --> If constraints, the limits are also taken */
761 if (*iordre >= 0) {
762 ideb = 0;
763 ifin = *nbroot + 1;
764 /* --> Otherwise, only Legendre roots (reframed) are used
765 . */
766 } else {
767 ideb = 1;
768 ifin = *nbroot;
769 }
770 /* --> Nb of point to calculate. */
771 nbp = ifin - ideb + 1;
772 nroo2 = *nbroot / 2;
773
774 /* --------------- Determination of the order of global derivation --------
775 */
776 /* --> ISOFAV takes only values 1 or 2. */
777 /* if Iso-U, derive by U of order IDERIV */
778 if (*isofav == 1) {
779 ideru = *ideriv;
780 iderv = 0;
781 d__1 = (uvfonc[4] - uvfonc[3]) / 2.;
782 renor = AdvApp2Var_MathBase::pow__di(&d__1, ideriv);
783 /* if Iso-V, derive by V of order IDERIV */
784 } else {
785 ideru = 0;
786 iderv = *ideriv;
787 d__1 = (uvfonc[6] - uvfonc[5]) / 2.;
788 renor = AdvApp2Var_MathBase::pow__di(&d__1, ideriv);
789 }
790
791 /* ----------- Discretization on roots of the ---------------
792 */
793 /* ---------------------- Legendre polynom of degree NBROOT -------------------
794 */
795
796 (*const_cast <AdvApp2Var_EvaluatorFunc2Var*> (&foncnp)).Evaluate (ndimen,
797 &uvfonc[3],
798 &uvfonc[5],
799 isofav,
800 tconst,
801 &nbp,
802 &ttable[ideb],
803 &ideru,
804 &iderv,
805 &fpntab[ideb * fpntab_dim1 + 1],
806 iercod);
807 if (*iercod > 0) {
808 goto L9999;
809 }
810 i__1 = *ndimen;
811 for (nd = 1; nd <= i__1; ++nd) {
812 i__2 = nroo2;
813 for (ii = 1; ii <= i__2; ++ii) {
814 iip = (*nbroot + 1) / 2 + ii;
815 iim = nroo2 - ii + 1;
816 bid1 = fpntab[nd + iim * fpntab_dim1];
817 bid2 = fpntab[nd + iip * fpntab_dim1];
818 somtab[ii + nd * somtab_dim1] = renor * (bid2 + bid1);
819 diftab[ii + nd * diftab_dim1] = renor * (bid2 - bid1);
820 /* L200: */
821 }
822 /* L100: */
823 }
824
825 /* ------------ Case when discretisation is done on roots of a ----
826 */
827 /* ---------- Legendre polynom of uneven degree, 0 is root --------
828 */
829
830 if (*nbroot % 2 == 1) {
831 i__1 = *ndimen;
832 for (nd = 1; nd <= i__1; ++nd) {
833 somtab[nd * somtab_dim1] = renor * fpntab[nd + (nroo2 + 1) *
834 fpntab_dim1];
835 diftab[nd * diftab_dim1] = renor * fpntab[nd + (nroo2 + 1) *
836 fpntab_dim1];
837 /* L300: */
838 }
839 } else {
840 i__1 = *ndimen;
841 for (nd = 1; nd <= i__1; ++nd) {
842 somtab[nd * somtab_dim1] = 0.;
843 diftab[nd * diftab_dim1] = 0.;
844 }
845 }
846
847
848 /* --------------------- Take into account constraints ----------------
849 */
850
851 if (*iordre >= 0) {
852 /* --> Recover already calculated extremities. */
853 i__1 = *ndimen;
854 for (nd = 1; nd <= i__1; ++nd) {
855 contr1[nd + contr1_dim1] = renor * fpntab[nd];
856 contr2[nd + contr2_dim1] = renor * fpntab[nd + (*nbroot + 1) *
857 fpntab_dim1];
858 /* L400: */
859 }
860 /* --> Nb of points to calculate/call to FONCNP */
861 nbp = 1;
862 /* If Iso-U, derive by V till order IORDRE */
863 if (*isofav == 1) {
864 /* --> Factor of normalisation 1st derivative. */
865 bid1 = (uvfonc[6] - uvfonc[5]) / 2.;
866 i__1 = *iordre;
867 for (iderv = 1; iderv <= i__1; ++iderv) {
868 (*const_cast <AdvApp2Var_EvaluatorFunc2Var*> (&foncnp)).Evaluate (
869 ndimen, &uvfonc[3], &uvfonc[5], isofav, tconst, &
870 nbp, ttable, &ideru, &iderv, &contr1[(iderv + 1) *
871 contr1_dim1 + 1], iercod);
872 if (*iercod > 0) {
873 goto L9999;
874 }
875 /* L500: */
876 }
877 i__1 = *iordre;
878 for (iderv = 1; iderv <= i__1; ++iderv) {
879 (*const_cast <AdvApp2Var_EvaluatorFunc2Var*> (&foncnp)).Evaluate (
880 ndimen, &uvfonc[3], &uvfonc[5], isofav, tconst, &
881 nbp, &ttable[*nbroot + 1], &ideru, &iderv, &contr2[(
882 iderv + 1) * contr2_dim1 + 1], iercod);
883 if (*iercod > 0) {
884 goto L9999;
885 }
886 /* L510: */
887 }
888 /* If Iso-V, derive by U till order IORDRE */
889 } else {
890 /* --> Factor of normalization 1st derivative. */
891 bid1 = (uvfonc[4] - uvfonc[3]) / 2.;
892 i__1 = *iordre;
893 for (ideru = 1; ideru <= i__1; ++ideru) {
894 (*const_cast <AdvApp2Var_EvaluatorFunc2Var*> (&foncnp)).Evaluate (
895 ndimen, &uvfonc[3], &uvfonc[5], isofav, tconst, &
896 nbp, ttable, &ideru, &iderv, &contr1[(ideru + 1) *
897 contr1_dim1 + 1], iercod);
898 if (*iercod > 0) {
899 goto L9999;
900 }
901 /* L600: */
902 }
903 i__1 = *iordre;
904 for (ideru = 1; ideru <= i__1; ++ideru) {
905 (*const_cast <AdvApp2Var_EvaluatorFunc2Var*> (&foncnp)).Evaluate (
906 ndimen, &uvfonc[3], &uvfonc[5], isofav, tconst, &
907 nbp, &ttable[*nbroot + 1], &ideru, &iderv, &contr2[(
908 ideru + 1) * contr2_dim1 + 1], iercod);
909 if (*iercod > 0) {
910 goto L9999;
911 }
912 /* L610: */
913 }
914 }
915
916 /* ------------------------- Normalization of derivatives -------------
917 ---- */
918 /* (The function is redefined on (-1,1)*(-1,1)) */
919 bid2 = renor;
920 i__1 = *iordre;
921 for (ii = 1; ii <= i__1; ++ii) {
922 bid2 = bid1 * bid2;
923 i__2 = *ndimen;
924 for (nd = 1; nd <= i__2; ++nd) {
925 contr1[nd + (ii + 1) * contr1_dim1] *= bid2;
926 contr2[nd + (ii + 1) * contr2_dim1] *= bid2;
927 /* L710: */
928 }
929 /* L700: */
930 }
931 }
932
933 /* ------------------------------ The end -------------------------------
934 */
935
936 L9999:
937 if (*iercod > 0) {
938 *iercod += 100;
939 AdvApp2Var_SysBase::maermsg_("MMA1FDI", iercod, 7L);
940 }
941 if (ibb >= 3) {
942 AdvApp2Var_SysBase::mgsomsg_("MMA1FDI", 7L);
943 }
944 return 0;
945 } /* mma1fdi_ */
946
947 //=======================================================================
948 //function : mma1fer_
949 //purpose :
950 //=======================================================================
mma1fer_(integer *,integer * nbsesp,integer * ndimse,integer * iordre,integer * ndgjac,doublereal * crvjac,integer * ncflim,doublereal * epsapr,doublereal * ycvmax,doublereal * errmax,doublereal * errmoy,integer * ncoeff,integer * iercod)951 int mma1fer_(integer *,//ndimen,
952 integer *nbsesp,
953 integer *ndimse,
954 integer *iordre,
955 integer *ndgjac,
956 doublereal *crvjac,
957 integer *ncflim,
958 doublereal *epsapr,
959 doublereal *ycvmax,
960 doublereal *errmax,
961 doublereal *errmoy,
962 integer *ncoeff,
963 integer *iercod)
964 {
965 /* System generated locals */
966 integer crvjac_dim1, crvjac_offset, i__1, i__2;
967
968 /* Local variables */
969 integer idim, ncfja, ncfnw, ndses, ii, kk, ibb, ier;
970 integer nbr0;
971
972
973 /* ***********************************************************************
974 */
975
976 /* FUNCTION : */
977 /* ---------- */
978 /* Calculate the degree and the errors of approximation of a border. */
979
980 /* KEYWORDS : */
981 /* ----------- */
982 /* TOUS,AB_SPECIFI :: COURBE&,TRONCATURE, &PRECISION */
983
984 /* INPUT ARGUMENTS : */
985 /* -------------------- */
986
987 /* NDIMEN: Total Dimension of the space (sum of dimensions of sub-spaces) */
988 /* NBSESP: Number of "independent" sub-spaces. */
989 /* NDIMSE: Table of dimensions of sub-spaces. */
990 /* IORDRE: Order of constraint at the extremities of the border */
991 /* -1 = no constraints, */
992 /* 0 = constraints of passage to limits (i.e. C0), */
993 /* 1 = C0 + constraintes of 1st derivatives (i.e. C1), */
994 /* 2 = C1 + constraintes of 2nd derivatives (i.e. C2). */
995 /* NDGJAC: Degree of development in series to use for the calculation */
996 /* in the base of Jacobi. */
997 /* CRVJAC: Table of coeff. of the curve of approximation in the */
998 /* base of Jacobi. */
999 /* NCFLIM: Max number of coeff of the polynomial curve */
1000 /* of approximation (should be above or equal to */
1001 /* 2*IORDRE+2 and below or equal to 50). */
1002 /* EPSAPR: Table of errors of approximations that cannot be passed, */
1003 /* sub-space by sub-space. */
1004
1005 /* OUTPUT ARGUMENTS : */
1006 /* --------------------- */
1007 /* YCVMAX: Auxiliary Table. */
1008 /* ERRMAX: Table of errors (sub-space by sub-space) */
1009 /* MAXIMUM made in the approximation of FONCNP by */
1010 /* COURBE. */
1011 /* ERRMOY: Table of errors (sub-space by sub-space) */
1012 /* AVERAGE made in the approximation of FONCNP by */
1013 /* COURBE. */
1014 /* NCOEFF: Number of significative coeffs. of the calculated "curve". */
1015 /* IERCOD: Error code */
1016 /* = 0, ok, */
1017 /* =-1, warning, required tolerance can't be */
1018 /* met with coefficients NFCLIM. */
1019 /* = 1, order of constraints (IORDRE) is not within authorised values */
1020
1021
1022 /* COMMONS USED : */
1023 /* ------------------ */
1024
1025 /* REFERENCES CALLED : */
1026 /* --------------------- */
1027
1028 /* DESCRIPTION/NOTES/LIMITATIONS : */
1029 /* ----------------------------------- */
1030 /* > */
1031 /* **********************************************************************
1032 */
1033
1034 /* Name of the routine */
1035
1036
1037 /* Parameter adjustments */
1038 --ycvmax;
1039 --errmoy;
1040 --errmax;
1041 --epsapr;
1042 --ndimse;
1043 crvjac_dim1 = *ndgjac + 1;
1044 crvjac_offset = crvjac_dim1;
1045 crvjac -= crvjac_offset;
1046
1047 /* Function Body */
1048 ibb = AdvApp2Var_SysBase::mnfndeb_();
1049 if (ibb >= 3) {
1050 AdvApp2Var_SysBase::mgenmsg_("MMA1FER", 7L);
1051 }
1052 *iercod = 0;
1053 idim = 1;
1054 *ncoeff = 0;
1055 ncfja = *ndgjac + 1;
1056
1057 /* ------------ Calculate the degree of the curve and of the Max error --------
1058 */
1059 /* -------------- of approximation for all sub-spaces --------
1060 */
1061
1062 i__1 = *nbsesp;
1063 for (ii = 1; ii <= i__1; ++ii) {
1064 ndses = ndimse[ii];
1065
1066 /* ------------ cutting of coeff. and calculation of Max error -------
1067 ---- */
1068
1069 AdvApp2Var_MathBase::mmtrpjj_(&ncfja, &ndses, &ncfja, &epsapr[ii], iordre, &crvjac[idim *
1070 crvjac_dim1], &ycvmax[1], &errmax[ii], &ncfnw);
1071
1072 /* ******************************************************************
1073 **** */
1074 /* ------------- If precision OK, calculate the average error -------
1075 ---- */
1076 /* ******************************************************************
1077 **** */
1078
1079 if (ncfnw <= *ncflim) {
1080 mmaperm_(&ncfja, &ndses, &ncfja, iordre, &crvjac[idim *
1081 crvjac_dim1], &ncfnw, &errmoy[ii]);
1082 *ncoeff = advapp_max(ncfnw,*ncoeff);
1083
1084 /* ------------- Set the declined coefficients to 0.D0 -----------
1085 -------- */
1086
1087 nbr0 = *ncflim - ncfnw;
1088 if (nbr0 > 0) {
1089 i__2 = ndses;
1090 for (kk = 1; kk <= i__2; ++kk) {
1091 AdvApp2Var_SysBase::mvriraz_(&nbr0,
1092 &crvjac[ncfnw + (idim + kk - 1) * crvjac_dim1]);
1093 /* L200: */
1094 }
1095 }
1096 } else {
1097
1098 /* **************************************************************
1099 ******** */
1100 /* ------------------- If required precision can't be reached----
1101 -------- */
1102 /* **************************************************************
1103 ******** */
1104
1105 *iercod = -1;
1106
1107 /* ------------------------- calculate the Max error ------------
1108 -------- */
1109
1110 AdvApp2Var_MathBase::mmaperx_(&ncfja, &ndses, &ncfja, iordre, &crvjac[idim *
1111 crvjac_dim1], ncflim, &ycvmax[1], &errmax[ii], &ier);
1112 if (ier > 0) {
1113 goto L9100;
1114 }
1115
1116 /* -------------------- nb of coeff to be returned -------------
1117 -------- */
1118
1119 *ncoeff = *ncflim;
1120
1121 /* ------------------- and calculation of the average error ----
1122 -------- */
1123
1124 mmaperm_(&ncfja, &ndses, &ncfja, iordre, &crvjac[idim *
1125 crvjac_dim1], ncflim, &errmoy[ii]);
1126 }
1127 idim += ndses;
1128 /* L100: */
1129 }
1130
1131 goto L9999;
1132
1133 /* ------------------------------ The end -------------------------------
1134 */
1135 /* --> The order of constraints is not within autorized values. */
1136 L9100:
1137 *iercod = 1;
1138 goto L9999;
1139
1140 L9999:
1141 if (*iercod != 0) {
1142 AdvApp2Var_SysBase::maermsg_("MMA1FER", iercod, 7L);
1143 }
1144 if (ibb >= 3) {
1145 AdvApp2Var_SysBase::mgsomsg_("MMA1FER", 7L);
1146 }
1147 return 0;
1148 } /* mma1fer_ */
1149
1150
1151 //=======================================================================
1152 //function : mma1her_
1153 //purpose :
1154 //=======================================================================
mma1her_(const integer * iordre,doublereal * hermit,integer * iercod)1155 int AdvApp2Var_ApproxF2var::mma1her_(const integer *iordre,
1156 doublereal *hermit,
1157 integer *iercod)
1158 {
1159 /* System generated locals */
1160 integer hermit_dim1, hermit_offset;
1161
1162 /* Local variables */
1163 integer ibb;
1164
1165
1166
1167 /* **********************************************************************
1168 */
1169
1170 /* FUNCTION : */
1171 /* ---------- */
1172 /* Calculate 2*(IORDRE+1) Hermit polynoms of degree 2*IORDRE+1 */
1173 /* on (-1,1) */
1174
1175 /* KEYWORDS : */
1176 /* ----------- */
1177 /* ALL, AB_SPECIFI::CONTRAINTE&, INTERPOLATION, &POLYNOME */
1178
1179 /* INPUT ARGUMENTS : */
1180 /* ------------------ */
1181 /* IORDRE: Order of constraint. */
1182 /* = 0, Polynom of interpolation of order C0 on (-1,1). */
1183 /* = 1, Polynom of interpolation of order C0 and C1 on (-1,1). */
1184 /* = 2, Polynom of interpolation of order C0, C1 and C2 on (-1,1).
1185 */
1186
1187 /* OUTPUT ARGUMENTS : */
1188 /* ------------------- */
1189 /* HERMIT: Table of 2*IORDRE+2 coeff. of each of 2*(IORDRE+1) */
1190 /* HERMIT polynom. */
1191 /* IERCOD: Error code, */
1192 /* = 0, Ok */
1193 /* = 1, required order of constraint is not managed here. */
1194 /* COMMONS USED : */
1195 /* ---------------- */
1196
1197 /* REFERENCES CALLED : */
1198 /* ----------------------- */
1199
1200 /* DESCRIPTION/NOTES/LIMITATIONS : */
1201 /* ----------------------------------- */
1202 /* The part of HERMIT(*,2*i+j) table where j=1 or 2 and i=0 to IORDRE, */
1203 /* contains the coefficients of the polynom of degree 2*IORDRE+1 */
1204 /* such as ALL values in -1 and in +1 of this polynom and its */
1205 /* derivatives till order of derivation IORDRE are NULL, */
1206 /* EXCEPT for the derivative of order i: */
1207 /* - valued 1 in -1 if j=1 */
1208 /* - valued 1 in +1 if j=2. */
1209 /* > */
1210 /* **********************************************************************
1211 */
1212
1213 /* Name of the routine */
1214
1215
1216 /* Parameter adjustments */
1217 hermit_dim1 = (*iordre + 1) << 1;
1218 hermit_offset = hermit_dim1 + 1;
1219 hermit -= hermit_offset;
1220
1221 /* Function Body */
1222 ibb = AdvApp2Var_SysBase::mnfndeb_();
1223 if (ibb >= 3) {
1224 AdvApp2Var_SysBase::mgenmsg_("MMA1HER", 7L);
1225 }
1226 *iercod = 0;
1227
1228 /* --- Recover (IORDRE+2) coeff of 2*(IORDRE+1) Hermit polynoms --
1229 */
1230
1231 if (*iordre == 0) {
1232 hermit[hermit_dim1 + 1] = .5;
1233 hermit[hermit_dim1 + 2] = -.5;
1234
1235 hermit[(hermit_dim1 << 1) + 1] = .5;
1236 hermit[(hermit_dim1 << 1) + 2] = .5;
1237 } else if (*iordre == 1) {
1238 hermit[hermit_dim1 + 1] = .5;
1239 hermit[hermit_dim1 + 2] = -.75;
1240 hermit[hermit_dim1 + 3] = 0.;
1241 hermit[hermit_dim1 + 4] = .25;
1242
1243 hermit[(hermit_dim1 << 1) + 1] = .5;
1244 hermit[(hermit_dim1 << 1) + 2] = .75;
1245 hermit[(hermit_dim1 << 1) + 3] = 0.;
1246 hermit[(hermit_dim1 << 1) + 4] = -.25;
1247
1248 hermit[hermit_dim1 * 3 + 1] = .25;
1249 hermit[hermit_dim1 * 3 + 2] = -.25;
1250 hermit[hermit_dim1 * 3 + 3] = -.25;
1251 hermit[hermit_dim1 * 3 + 4] = .25;
1252
1253 hermit[(hermit_dim1 << 2) + 1] = -.25;
1254 hermit[(hermit_dim1 << 2) + 2] = -.25;
1255 hermit[(hermit_dim1 << 2) + 3] = .25;
1256 hermit[(hermit_dim1 << 2) + 4] = .25;
1257 } else if (*iordre == 2) {
1258 hermit[hermit_dim1 + 1] = .5;
1259 hermit[hermit_dim1 + 2] = -.9375;
1260 hermit[hermit_dim1 + 3] = 0.;
1261 hermit[hermit_dim1 + 4] = .625;
1262 hermit[hermit_dim1 + 5] = 0.;
1263 hermit[hermit_dim1 + 6] = -.1875;
1264
1265 hermit[(hermit_dim1 << 1) + 1] = .5;
1266 hermit[(hermit_dim1 << 1) + 2] = .9375;
1267 hermit[(hermit_dim1 << 1) + 3] = 0.;
1268 hermit[(hermit_dim1 << 1) + 4] = -.625;
1269 hermit[(hermit_dim1 << 1) + 5] = 0.;
1270 hermit[(hermit_dim1 << 1) + 6] = .1875;
1271
1272 hermit[hermit_dim1 * 3 + 1] = .3125;
1273 hermit[hermit_dim1 * 3 + 2] = -.4375;
1274 hermit[hermit_dim1 * 3 + 3] = -.375;
1275 hermit[hermit_dim1 * 3 + 4] = .625;
1276 hermit[hermit_dim1 * 3 + 5] = .0625;
1277 hermit[hermit_dim1 * 3 + 6] = -.1875;
1278
1279 hermit[(hermit_dim1 << 2) + 1] = -.3125;
1280 hermit[(hermit_dim1 << 2) + 2] = -.4375;
1281 hermit[(hermit_dim1 << 2) + 3] = .375;
1282 hermit[(hermit_dim1 << 2) + 4] = .625;
1283 hermit[(hermit_dim1 << 2) + 5] = -.0625;
1284 hermit[(hermit_dim1 << 2) + 6] = -.1875;
1285
1286 hermit[hermit_dim1 * 5 + 1] = .0625;
1287 hermit[hermit_dim1 * 5 + 2] = -.0625;
1288 hermit[hermit_dim1 * 5 + 3] = -.125;
1289 hermit[hermit_dim1 * 5 + 4] = .125;
1290 hermit[hermit_dim1 * 5 + 5] = .0625;
1291 hermit[hermit_dim1 * 5 + 6] = -.0625;
1292
1293 hermit[hermit_dim1 * 6 + 1] = .0625;
1294 hermit[hermit_dim1 * 6 + 2] = .0625;
1295 hermit[hermit_dim1 * 6 + 3] = -.125;
1296 hermit[hermit_dim1 * 6 + 4] = -.125;
1297 hermit[hermit_dim1 * 6 + 5] = .0625;
1298 hermit[hermit_dim1 * 6 + 6] = .0625;
1299 } else {
1300 *iercod = 1;
1301 }
1302
1303 /* ------------------------------ The End -------------------------------
1304 */
1305
1306 AdvApp2Var_SysBase::maermsg_("MMA1HER", iercod, 7L);
1307 if (ibb >= 3) {
1308 AdvApp2Var_SysBase::mgsomsg_("MMA1HER", 7L);
1309 }
1310 return 0;
1311 } /* mma1her_ */
1312 //=======================================================================
1313 //function : mma1jak_
1314 //purpose :
1315 //=======================================================================
mma1jak_(integer * ndimen,integer * nbroot,integer * iordre,integer * ndgjac,doublereal * somtab,doublereal * diftab,doublereal * cgauss,doublereal * crvjac,integer * iercod)1316 int mma1jak_(integer *ndimen,
1317 integer *nbroot,
1318 integer *iordre,
1319 integer *ndgjac,
1320 doublereal *somtab,
1321 doublereal *diftab,
1322 doublereal *cgauss,
1323 doublereal *crvjac,
1324 integer *iercod)
1325 {
1326 /* System generated locals */
1327 integer somtab_dim1, somtab_offset, diftab_dim1, diftab_offset,
1328 crvjac_dim1, crvjac_offset;
1329
1330 /* Local variables */
1331 integer ibb;
1332
1333 /* **********************************************************************
1334 */
1335
1336 /* FUNCTION : */
1337 /* ---------- */
1338 /* Calculate the curve of approximation of a non-polynomial function */
1339 /* in the base of Jacobi. */
1340
1341 /* KEYWORDS : */
1342 /* ----------- */
1343 /* FUNCTION,DISCRETISATION,APPROXIMATION,CONSTRAINT,CURVE,JACOBI */
1344
1345 /* INPUT ARGUMENTS : */
1346 /* ------------------ */
1347 /* NDIMEN: Total dimension of the space (sum of dimensions */
1348 /* of sub-spaces) */
1349 /* NBROOT: Nb of points of discretization of the iso, extremities not */
1350 /* included. */
1351 /* IORDRE: Order of constraint at the extremities of the boundary */
1352 /* -1 = no constraints, */
1353 /* 0 = constraints of passage of limits (i.e. C0), */
1354 /* 1 = C0 + constraints of 1st derivatives (i.e. C1), */
1355 /* 2 = C1 + constraints of 2nd derivatives (i.e. C2). */
1356 /* NDGJAC: Degree of development in series to be used for calculation in the */
1357 /* base of Jacobi. */
1358
1359 /* OUTPUT ARGUMENTS : */
1360 /* ------------------- */
1361 /* CRVJAC : Curve of approximation of FONCNP with (eventually) */
1362 /* taking into account of constraints at the extremities. */
1363 /* This curve is of degree NDGJAC. */
1364 /* IERCOD : Error code : */
1365 /* 0 = All is ok. */
1366 /* 33 = Pb to return data of du block data */
1367 /* of coeff. of integration by GAUSS method. */
1368 /* by program MMAPPTT. */
1369
1370 /* COMMONS USED : */
1371 /* ---------------- */
1372
1373 /* REFERENCES CALLED : */
1374 /* ----------------------- */
1375 /* > */
1376 /* **********************************************************************
1377 */
1378
1379 /* Name of the routine */
1380
1381 /* Parameter adjustments */
1382 diftab_dim1 = *nbroot / 2 + 1;
1383 diftab_offset = diftab_dim1;
1384 diftab -= diftab_offset;
1385 somtab_dim1 = *nbroot / 2 + 1;
1386 somtab_offset = somtab_dim1;
1387 somtab -= somtab_offset;
1388 crvjac_dim1 = *ndgjac + 1;
1389 crvjac_offset = crvjac_dim1;
1390 crvjac -= crvjac_offset;
1391
1392 /* Function Body */
1393 ibb = AdvApp2Var_SysBase::mnfndeb_();
1394 if (ibb >= 2) {
1395 AdvApp2Var_SysBase::mgenmsg_("MMA1JAK", 7L);
1396 }
1397 *iercod = 0;
1398
1399 /* ----------------- Recover coeffs of integration by Gauss -----------
1400 */
1401
1402 AdvApp2Var_ApproxF2var::mmapptt_(ndgjac, nbroot, iordre, cgauss, iercod);
1403 if (*iercod > 0) {
1404 *iercod = 33;
1405 goto L9999;
1406 }
1407
1408 /* --------------- Calculate the curve in the base of Jacobi -----------
1409 */
1410
1411 mmmapcoe_(ndimen, ndgjac, iordre, nbroot, &somtab[somtab_offset], &diftab[
1412 diftab_offset], cgauss, &crvjac[crvjac_offset]);
1413
1414 /* ------------------------------ The End -------------------------------
1415 */
1416
1417 L9999:
1418 if (*iercod != 0) {
1419 AdvApp2Var_SysBase::maermsg_("MMA1JAK", iercod, 7L);
1420 }
1421 if (ibb >= 2) {
1422 AdvApp2Var_SysBase::mgsomsg_("MMA1JAK", 7L);
1423 }
1424 return 0;
1425 } /* mma1jak_ */
1426
1427 //=======================================================================
1428 //function : mma1noc_
1429 //purpose :
1430 //=======================================================================
mma1noc_(doublereal * dfuvin,integer * ndimen,integer * iordre,doublereal * cntrin,doublereal * duvout,integer * isofav,integer * ideriv,doublereal * cntout)1431 int mma1noc_(doublereal *dfuvin,
1432 integer *ndimen,
1433 integer *iordre,
1434 doublereal *cntrin,
1435 doublereal *duvout,
1436 integer *isofav,
1437 integer *ideriv,
1438 doublereal *cntout)
1439 {
1440 /* System generated locals */
1441 integer i__1;
1442 doublereal d__1;
1443
1444 /* Local variables */
1445 doublereal rider, riord;
1446 integer nd, ibb;
1447 doublereal bid;
1448 /* **********************************************************************
1449 */
1450
1451 /* FUNCTION : */
1452 /* ---------- */
1453 /* Normalization of constraints of derivatives, defined on DFUVIN */
1454 /* on block DUVOUT. */
1455
1456 /* KEYWORDS : */
1457 /* ----------- */
1458 /* ALL, AB_SPECIFI::VECTEUR&,DERIVEE&,NORMALISATION,&VECTEUR */
1459
1460 /* INPUT ARGUMENTS : */
1461 /* ------------------ */
1462 /* DFUVIN: Limits of the block of definition by U and by V where
1463 */
1464 /* constraints CNTRIN are defined. */
1465 /* NDIMEN: Dimension of the space. */
1466 /* IORDRE: Order of constraint imposed at the extremities of the iso. */
1467 /* (if Iso-U, it is necessary to calculate derivatives by V and vice */
1468 /* versa). */
1469 /* = 0, the extremities of the iso are calculated */
1470 /* = 1, additionally the 1st derivative in the direction */
1471 /* of the iso is calculated */
1472 /* = 2, additionally the 2nd derivative in the direction */
1473 /* of the iso is calculated */
1474 /* CNTRIN: Contains, if IORDRE>=0, IORDRE+1 derivatives */
1475 /* of order IORDRE of F(Uc,v) or of F(u,Vc), following the */
1476 /* value of ISOFAV, RENORMALIZED by u and v in (-1,1). */
1477 /* DUVOUT: Limits of the block of definition by U and by V where the */
1478 /* constraints CNTOUT will be defined. */
1479 /* ISOFAV: Isoparameter fixed for the discretization; */
1480 /* = 1, discretization with fixed U=Uc and variable V. */
1481 /* = 2, discretization with fixed V=Vc and variable U. */
1482 /* IDERIV: Ordre de derivee transverse a l'iso fixee (Si Iso-U=Uc */
1483 /* is fixed, the derivative of order IDERIV is discretized by U */
1484 /* of F(Uc,v). The same if iso-V is fixed). */
1485 /* Varies from (positioning) to 2 (2nd derivative). */
1486
1487 /* OUTPUT ARGUMENTS : */
1488 /* ------------------- */
1489 /* CNTOUT: Contains, if IORDRE>=0, IORDRE+1 derivatives */
1490 /* of order IORDRE of F(Uc,v) or of F(u,Vc), depending on the */
1491 /* value of ISOFAV, RENORMALIZED for u and v in DUVOUT. */
1492
1493 /* COMMONS USED : */
1494 /* ---------------- */
1495
1496 /* REFERENCES CALLED : */
1497 /* --------------------- */
1498
1499 /* DESCRIPTION/NOTES/LIMITATIONS : */
1500 /* ------------------------------- */
1501 /* CNTRIN can be an output/input argument, */
1502 /* so the call: */
1503
1504 /* CALL MMA1NOC(DFUVIN,NDIMEN,IORDRE,CNTRIN,DUVOUT */
1505 /* 1 ,ISOFAV,IDERIV,CNTRIN) */
1506
1507 /* is correct. */
1508 /* > */
1509 /* **********************************************************************
1510 */
1511
1512 /* Name of the routine */
1513
1514
1515 /* Parameter adjustments */
1516 dfuvin -= 3;
1517 --cntout;
1518 --cntrin;
1519 duvout -= 3;
1520
1521 /* Function Body */
1522 ibb = AdvApp2Var_SysBase::mnfndeb_();
1523 if (ibb >= 3) {
1524 AdvApp2Var_SysBase::mgenmsg_("MMA1NOC", 7L);
1525 }
1526
1527 /* --------------- Determination of coefficients of normalization -------
1528 */
1529
1530 if (*isofav == 1) {
1531 d__1 = (dfuvin[4] - dfuvin[3]) / (duvout[4] - duvout[3]);
1532 rider = AdvApp2Var_MathBase::pow__di(&d__1, ideriv);
1533 d__1 = (dfuvin[6] - dfuvin[5]) / (duvout[6] - duvout[5]);
1534 riord = AdvApp2Var_MathBase::pow__di(&d__1, iordre);
1535
1536 } else {
1537 d__1 = (dfuvin[6] - dfuvin[5]) / (duvout[6] - duvout[5]);
1538 rider = AdvApp2Var_MathBase::pow__di(&d__1, ideriv);
1539 d__1 = (dfuvin[4] - dfuvin[3]) / (duvout[4] - duvout[3]);
1540 riord = AdvApp2Var_MathBase::pow__di(&d__1, iordre);
1541 }
1542
1543 /* ------------- Renormalization of the vector of constraint ---------------
1544 */
1545
1546 bid = rider * riord;
1547 i__1 = *ndimen;
1548 for (nd = 1; nd <= i__1; ++nd) {
1549 cntout[nd] = bid * cntrin[nd];
1550 /* L100: */
1551 }
1552
1553 /* ------------------------------ The end -------------------------------
1554 */
1555
1556 if (ibb >= 3) {
1557 AdvApp2Var_SysBase::mgsomsg_("MMA1NOC", 7L);
1558 }
1559 return 0;
1560 } /* mma1noc_ */
1561
1562 //=======================================================================
1563 //function : mma1nop_
1564 //purpose :
1565 //=======================================================================
mma1nop_(integer * nbroot,doublereal * rootlg,doublereal * uvfonc,integer * isofav,doublereal * ttable,integer * iercod)1566 int mma1nop_(integer *nbroot,
1567 doublereal *rootlg,
1568 doublereal *uvfonc,
1569 integer *isofav,
1570 doublereal *ttable,
1571 integer *iercod)
1572
1573 {
1574 /* System generated locals */
1575 integer i__1;
1576
1577 /* Local variables */
1578 doublereal alinu, blinu, alinv, blinv;
1579 integer ii, ibb;
1580
1581 /* ***********************************************************************
1582 */
1583
1584 /* FUNCTION : */
1585 /* ---------- */
1586 /* Normalization of parameters of an iso, starting from */
1587 /* parametric block and parameters on (-1,1). */
1588
1589 /* KEYWORDS : */
1590 /* ----------- */
1591 /* TOUS,AB_SPECIFI :: ISO&,POINT&,NORMALISATION,&POINT,&ISO */
1592
1593 /* INPUT ARGUMENTS : */
1594 /* -------------------- */
1595 /* NBROOT: Nb of points of discretisation INSIDE the iso */
1596 /* defined on (-1,1). */
1597 /* ROOTLG: Table of discretization parameters on )-1,1( */
1598 /* of the iso. */
1599 /* UVFONC: Block of definition of the iso */
1600 /* ISOFAV: = 1, this is iso-u; =2, this is iso-v. */
1601
1602 /* OUTPUT ARGUMENTS : */
1603 /* --------------------- */
1604 /* TTABLE: Table of parameters renormalized on UVFONC of the iso.
1605 */
1606 /* IERCOD: = 0, OK */
1607 /* = 1, ISOFAV is out of allowed values. */
1608
1609 /* > */
1610 /* **********************************************************************
1611 */
1612 /* Name of the routine */
1613
1614
1615 /* Parameter adjustments */
1616 --rootlg;
1617 uvfonc -= 3;
1618
1619 /* Function Body */
1620 ibb = AdvApp2Var_SysBase::mnfndeb_();
1621 if (ibb >= 3) {
1622 AdvApp2Var_SysBase::mgenmsg_("MMA1NOP", 7L);
1623 }
1624
1625 alinu = (uvfonc[4] - uvfonc[3]) / 2.;
1626 blinu = (uvfonc[4] + uvfonc[3]) / 2.;
1627 alinv = (uvfonc[6] - uvfonc[5]) / 2.;
1628 blinv = (uvfonc[6] + uvfonc[5]) / 2.;
1629
1630 if (*isofav == 1) {
1631 ttable[0] = uvfonc[5];
1632 i__1 = *nbroot;
1633 for (ii = 1; ii <= i__1; ++ii) {
1634 ttable[ii] = alinv * rootlg[ii] + blinv;
1635 /* L100: */
1636 }
1637 ttable[*nbroot + 1] = uvfonc[6];
1638 } else if (*isofav == 2) {
1639 ttable[0] = uvfonc[3];
1640 i__1 = *nbroot;
1641 for (ii = 1; ii <= i__1; ++ii) {
1642 ttable[ii] = alinu * rootlg[ii] + blinu;
1643 /* L200: */
1644 }
1645 ttable[*nbroot + 1] = uvfonc[4];
1646 } else {
1647 goto L9100;
1648 }
1649
1650 goto L9999;
1651
1652 /* ------------------------------ THE END -------------------------------
1653 */
1654
1655 L9100:
1656 *iercod = 1;
1657 goto L9999;
1658
1659 L9999:
1660 if (*iercod != 0) {
1661 AdvApp2Var_SysBase::maermsg_("MMA1NOP", iercod, 7L);
1662 }
1663 if (ibb >= 3) {
1664 AdvApp2Var_SysBase::mgsomsg_("MMA1NOP", 7L);
1665 }
1666
1667 return 0 ;
1668
1669 } /* mma1nop_ */
1670
1671 //=======================================================================
1672 //function : mma2ac1_
1673 //purpose :
1674 //=======================================================================
mma2ac1_(integer const * ndimen,integer const * mxujac,integer const * mxvjac,integer const * iordru,integer const * iordrv,doublereal const * contr1,doublereal const * contr2,doublereal const * contr3,doublereal const * contr4,doublereal const * uhermt,doublereal const * vhermt,doublereal * patjac)1675 int AdvApp2Var_ApproxF2var::mma2ac1_(integer const *ndimen,
1676 integer const *mxujac,
1677 integer const *mxvjac,
1678 integer const *iordru,
1679 integer const *iordrv,
1680 doublereal const *contr1,
1681 doublereal const * contr2,
1682 doublereal const *contr3,
1683 doublereal const *contr4,
1684 doublereal const *uhermt,
1685 doublereal const *vhermt,
1686 doublereal *patjac)
1687
1688 {
1689 /* System generated locals */
1690 integer contr1_dim1, contr1_dim2, contr1_offset, contr2_dim1, contr2_dim2,
1691 contr2_offset, contr3_dim1, contr3_dim2, contr3_offset,
1692 contr4_dim1, contr4_dim2, contr4_offset, uhermt_dim1,
1693 uhermt_offset, vhermt_dim1, vhermt_offset, patjac_dim1,
1694 patjac_dim2, patjac_offset, i__1, i__2, i__3, i__4, i__5;
1695
1696 /* Local variables */
1697 logical ldbg;
1698 integer ndgu, ndgv;
1699 doublereal bidu1, bidu2, bidv1, bidv2;
1700 integer ioru1, iorv1, ii, nd, jj, ku, kv;
1701 doublereal cnt1, cnt2, cnt3, cnt4;
1702
1703 /* **********************************************************************
1704 */
1705
1706 /* FUNCTION : */
1707 /* ---------- */
1708 /* Add polynoms of edge constraints. */
1709
1710 /* KEYWORDS : */
1711 /* ----------- */
1712 /* TOUS,AB_SPECIFI::POINT&,CONTRAINTE&,ADDITION,&POLYNOME */
1713
1714 /* INPUT ARGUMENTS : */
1715 /* ------------------ */
1716 /* NDIMEN: Dimension of the space. */
1717 /* MXUJAC: Max degree of the polynom of approximation by U. The */
1718 /* representation in the orthogonal base starts from degree */
1719 /* 0 to degree MXUJAC-2*(IORDRU+1). The polynomial base is the */
1720 /* base of Jacobi of order -1 (Legendre), 0, 1 or 2 */
1721 /* MXVJAC: Max degree of the polynom of approximation by V. The */
1722 /* representation in the orthogonal base starts from degree */
1723 /* 0 to degree MXUJAC-2*(IORDRU+1). The polynomial base is the */
1724 /* base of Jacobi of order -1 (Legendre), 0, 1 or 2 */
1725 /* IORDRU: Order of the base of Jacobi (-1,0,1 or 2) by U. Corresponds */
1726 /* to the step of constraints: C0, C1 or C2. */
1727 /* IORDRV: Order of the base of Jacobi (-1,0,1 or 2) by V. Corresponds */
1728 /* to the step of constraints: C0, C1 or C2. */
1729 /* CONTR1: Contains, if IORDRU and IORDRV>=0, the values at the */
1730 /* extremities of F(U0,V0) and its derivatives. */
1731 /* CONTR2: Contains, if IORDRU and IORDRV>=0, the values at the */
1732 /* extremities of F(U1,V0) and its derivatives. */
1733 /* CONTR3: Contains, if IORDRU and IORDRV>=0, the values at the */
1734 /* extremities of F(U0,V1) and its derivatives. */
1735 /* CONTR4: Contains, if IORDRU and IORDRV>=0, the values at the */
1736 /* extremities of F(U1,V1) and its derivatives. */
1737 /* UHERMT: Coeff. of Hermit polynoms of order IORDRU. */
1738 /* VHERMT: Coeff. of Hermit polynoms of order IORDRV. */
1739 /* PATJAC: Table of coefficients of the polynom P(u,v) of approximation */
1740 /* of F(u,v) WITHOUT taking into account the constraints. */
1741
1742 /* OUTPUT ARGUMENTS : */
1743 /* ------------------- */
1744 /* PATJAC: Table of coefficients of the polynom P(u,v) by approximation */
1745 /* of F(u,v) WITH taking into account of constraints. */
1746 /* > */
1747 /* **********************************************************************
1748 */
1749 /* Name of the routine */
1750
1751 /* --------------------------- Initialization --------------------------
1752 */
1753
1754 /* Parameter adjustments */
1755 patjac_dim1 = *mxujac + 1;
1756 patjac_dim2 = *mxvjac + 1;
1757 patjac_offset = patjac_dim1 * patjac_dim2;
1758 patjac -= patjac_offset;
1759 uhermt_dim1 = (*iordru << 1) + 2;
1760 uhermt_offset = uhermt_dim1;
1761 uhermt -= uhermt_offset;
1762 vhermt_dim1 = (*iordrv << 1) + 2;
1763 vhermt_offset = vhermt_dim1;
1764 vhermt -= vhermt_offset;
1765 contr4_dim1 = *ndimen;
1766 contr4_dim2 = *iordru + 2;
1767 contr4_offset = contr4_dim1 * (contr4_dim2 + 1) + 1;
1768 contr4 -= contr4_offset;
1769 contr3_dim1 = *ndimen;
1770 contr3_dim2 = *iordru + 2;
1771 contr3_offset = contr3_dim1 * (contr3_dim2 + 1) + 1;
1772 contr3 -= contr3_offset;
1773 contr2_dim1 = *ndimen;
1774 contr2_dim2 = *iordru + 2;
1775 contr2_offset = contr2_dim1 * (contr2_dim2 + 1) + 1;
1776 contr2 -= contr2_offset;
1777 contr1_dim1 = *ndimen;
1778 contr1_dim2 = *iordru + 2;
1779 contr1_offset = contr1_dim1 * (contr1_dim2 + 1) + 1;
1780 contr1 -= contr1_offset;
1781
1782 /* Function Body */
1783 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
1784 if (ldbg) {
1785 AdvApp2Var_SysBase::mgenmsg_("MMA2AC1", 7L);
1786 }
1787
1788 /* ------------ SUBTRACTION OF ANGULAR CONSTRAINTS -------------------
1789 */
1790
1791 ioru1 = *iordru + 1;
1792 iorv1 = *iordrv + 1;
1793 ndgu = (*iordru << 1) + 1;
1794 ndgv = (*iordrv << 1) + 1;
1795
1796 i__1 = iorv1;
1797 for (jj = 1; jj <= i__1; ++jj) {
1798 i__2 = ioru1;
1799 for (ii = 1; ii <= i__2; ++ii) {
1800 i__3 = *ndimen;
1801 for (nd = 1; nd <= i__3; ++nd) {
1802 cnt1 = contr1[nd + (ii + jj * contr1_dim2) * contr1_dim1];
1803 cnt2 = contr2[nd + (ii + jj * contr2_dim2) * contr2_dim1];
1804 cnt3 = contr3[nd + (ii + jj * contr3_dim2) * contr3_dim1];
1805 cnt4 = contr4[nd + (ii + jj * contr4_dim2) * contr4_dim1];
1806 i__4 = ndgv;
1807 for (kv = 0; kv <= i__4; ++kv) {
1808 bidv1 = vhermt[kv + ((jj << 1) - 1) * vhermt_dim1];
1809 bidv2 = vhermt[kv + (jj << 1) * vhermt_dim1];
1810 i__5 = ndgu;
1811 for (ku = 0; ku <= i__5; ++ku) {
1812 bidu1 = uhermt[ku + ((ii << 1) - 1) * uhermt_dim1];
1813 bidu2 = uhermt[ku + (ii << 1) * uhermt_dim1];
1814 patjac[ku + (kv + nd * patjac_dim2) * patjac_dim1] =
1815 patjac[ku + (kv + nd * patjac_dim2) *
1816 patjac_dim1] - bidu1 * bidv1 * cnt1 - bidu2 *
1817 bidv1 * cnt2 - bidu1 * bidv2 * cnt3 - bidu2 *
1818 bidv2 * cnt4;
1819 /* L500: */
1820 }
1821 /* L400: */
1822 }
1823 /* L300: */
1824 }
1825 /* L200: */
1826 }
1827 /* L100: */
1828 }
1829
1830 /* ------------------------------ The end -------------------------------
1831 */
1832
1833 if (ldbg) {
1834 AdvApp2Var_SysBase::mgsomsg_("MMA2AC1", 7L);
1835 }
1836 return 0;
1837 } /* mma2ac1_ */
1838
1839 //=======================================================================
1840 //function : mma2ac2_
1841 //purpose :
1842 //=======================================================================
mma2ac2_(const integer * ndimen,const integer * mxujac,const integer * mxvjac,const integer * iordrv,const integer * nclimu,const integer * ncfiv1,const doublereal * crbiv1,const integer * ncfiv2,const doublereal * crbiv2,const doublereal * vhermt,doublereal * patjac)1843 int AdvApp2Var_ApproxF2var::mma2ac2_(const integer *ndimen,
1844 const integer *mxujac,
1845 const integer *mxvjac,
1846 const integer *iordrv,
1847 const integer *nclimu,
1848 const integer *ncfiv1,
1849 const doublereal *crbiv1,
1850 const integer *ncfiv2,
1851 const doublereal *crbiv2,
1852 const doublereal *vhermt,
1853 doublereal *patjac)
1854
1855 {
1856 /* System generated locals */
1857 integer crbiv1_dim1, crbiv1_dim2, crbiv1_offset, crbiv2_dim1, crbiv2_dim2,
1858 crbiv2_offset, patjac_dim1, patjac_dim2, patjac_offset,
1859 vhermt_dim1, vhermt_offset, i__1, i__2, i__3, i__4;
1860
1861 /* Local variables */
1862 logical ldbg;
1863 integer ndgv1, ndgv2, ii, jj, nd, kk;
1864 doublereal bid1, bid2;
1865
1866 /* **********************************************************************
1867 */
1868
1869 /* FUNCTION : */
1870 /* ---------- */
1871 /* Add polynoms of constraints */
1872
1873 /* KEYWORDS : */
1874 /* ----------- */
1875 /* FUNCTION,APPROXIMATION,COEFFICIENT,POLYNOM */
1876
1877 /* INPUT ARGUMENTS : */
1878 /* ------------------ */
1879 /* NDIMEN: Dimension of the space. */
1880 /* MXUJAC: Max degree of the polynom of approximation by U. The */
1881 /* representation in the orthogonal base starts from degree */
1882 /* 0 to degree MXUJAC-2*(IORDRU+1). The polynomial base is the */
1883 /* base of Jacobi of order -1 (Legendre), 0, 1 or 2 */
1884 /* MXVJAC: Max degree of the polynom of approximation by V. The */
1885 /* representation in the orthogonal base starts from degree */
1886 /* 0 to degree MXUJAC-2*(IORDRU+1). The polynomial base is the */
1887 /* base of Jacobi of order -1 (Legendre), 0, 1 or 2 */
1888 /* IORDRV: Order of the base of Jacobi (-1,0,1 or 2) by V. Corresponds */
1889 /* to the step of constraints: C0, C1 or C2. */
1890 /* NCLIMU LIMIT nb of coeff by u of the solution P(u,v)
1891 * NCFIV1: Nb of Coeff. of curves stored in CRBIV1. */
1892 /* CRBIV1: Table of coeffs of the approximation of iso-V0 and its */
1893 /* derivatives till order IORDRV. */
1894 /* NCFIV2: Nb of Coeff. of curves stored in CRBIV2. */
1895 /* CRBIV2: Table of coeffs of approximation of iso-V1 and its */
1896 /* derivatives till order IORDRV. */
1897 /* VHERMT: Coeff. of Hermit polynoms of order IORDRV. */
1898 /* PATJAC: Table of coefficients of the polynom P(u,v) of approximation */
1899 /* of F(u,v) WITHOUT taking into account the constraints. */
1900
1901 /* OUTPUT ARGUMENTS : */
1902 /* ------------------- */
1903 /* PATJAC: Table of coefficients of the polynom P(u,v) by approximation */
1904 /* of F(u,v) WITH taking into account of constraints. */
1905 /* > */
1906
1907
1908 /* > */
1909 /* **********************************************************************
1910 */
1911 /* Name of the routine */
1912
1913 /* --------------------------- Initialisations --------------------------
1914 */
1915
1916 /* Parameter adjustments */
1917 patjac_dim1 = *mxujac + 1;
1918 patjac_dim2 = *mxvjac + 1;
1919 patjac_offset = patjac_dim1 * patjac_dim2;
1920 patjac -= patjac_offset;
1921 vhermt_dim1 = (*iordrv << 1) + 2;
1922 vhermt_offset = vhermt_dim1;
1923 vhermt -= vhermt_offset;
1924 --ncfiv2;
1925 --ncfiv1;
1926 crbiv2_dim1 = *nclimu;
1927 crbiv2_dim2 = *ndimen;
1928 crbiv2_offset = crbiv2_dim1 * (crbiv2_dim2 + 1);
1929 crbiv2 -= crbiv2_offset;
1930 crbiv1_dim1 = *nclimu;
1931 crbiv1_dim2 = *ndimen;
1932 crbiv1_offset = crbiv1_dim1 * (crbiv1_dim2 + 1);
1933 crbiv1 -= crbiv1_offset;
1934
1935 /* Function Body */
1936 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
1937 if (ldbg) {
1938 AdvApp2Var_SysBase::mgenmsg_("MMA2AC2", 7L);
1939 }
1940
1941 /* ------------ ADDING of coeff by u of curves, by v of Hermit --------
1942 */
1943
1944 i__1 = *iordrv + 1;
1945 for (ii = 1; ii <= i__1; ++ii) {
1946 ndgv1 = ncfiv1[ii] - 1;
1947 ndgv2 = ncfiv2[ii] - 1;
1948 i__2 = *ndimen;
1949 for (nd = 1; nd <= i__2; ++nd) {
1950 i__3 = (*iordrv << 1) + 1;
1951 for (jj = 0; jj <= i__3; ++jj) {
1952 bid1 = vhermt[jj + ((ii << 1) - 1) * vhermt_dim1];
1953 i__4 = ndgv1;
1954 for (kk = 0; kk <= i__4; ++kk) {
1955 patjac[kk + (jj + nd * patjac_dim2) * patjac_dim1] +=
1956 bid1 * crbiv1[kk + (nd + ii * crbiv1_dim2) *
1957 crbiv1_dim1];
1958 /* L400: */
1959 }
1960 bid2 = vhermt[jj + (ii << 1) * vhermt_dim1];
1961 i__4 = ndgv2;
1962 for (kk = 0; kk <= i__4; ++kk) {
1963 patjac[kk + (jj + nd * patjac_dim2) * patjac_dim1] +=
1964 bid2 * crbiv2[kk + (nd + ii * crbiv2_dim2) *
1965 crbiv2_dim1];
1966 /* L500: */
1967 }
1968 /* L300: */
1969 }
1970 /* L200: */
1971 }
1972 /* L100: */
1973 }
1974
1975 /* ------------------------------ The end -------------------------------
1976 */
1977
1978 if (ldbg) {
1979 AdvApp2Var_SysBase::mgsomsg_("MMA2AC2", 7L);
1980 }
1981 return 0;
1982 } /* mma2ac2_ */
1983
1984
1985 //=======================================================================
1986 //function : mma2ac3_
1987 //purpose :
1988 //=======================================================================
mma2ac3_(const integer * ndimen,const integer * mxujac,const integer * mxvjac,const integer * iordru,const integer * nclimv,const integer * ncfiu1,const doublereal * crbiu1,const integer * ncfiu2,const doublereal * crbiu2,const doublereal * uhermt,doublereal * patjac)1989 int AdvApp2Var_ApproxF2var::mma2ac3_(const integer *ndimen,
1990 const integer *mxujac,
1991 const integer *mxvjac,
1992 const integer *iordru,
1993 const integer *nclimv,
1994 const integer *ncfiu1,
1995 const doublereal * crbiu1,
1996 const integer *ncfiu2,
1997 const doublereal *crbiu2,
1998 const doublereal *uhermt,
1999 doublereal *patjac)
2000
2001 {
2002 /* System generated locals */
2003 integer crbiu1_dim1, crbiu1_dim2, crbiu1_offset, crbiu2_dim1, crbiu2_dim2,
2004 crbiu2_offset, patjac_dim1, patjac_dim2, patjac_offset,
2005 uhermt_dim1, uhermt_offset, i__1, i__2, i__3, i__4;
2006
2007 /* Local variables */
2008 logical ldbg;
2009 integer ndgu1, ndgu2, ii, jj, nd, kk;
2010 doublereal bid1, bid2;
2011
2012 /* **********************************************************************
2013 */
2014
2015 /* FUNCTION : */
2016 /* ---------- */
2017 /* Ajout des polynomes de contraintes */
2018
2019 /* KEYWORDS : */
2020 /* ----------- */
2021 /* FONCTION,APPROXIMATION,COEFFICIENT,POLYNOME */
2022
2023 /* INPUT ARGUMENTS : */
2024 /* ------------------ */
2025 /* NDIMEN: Dimension of the space. */
2026 /* MXUJAC: Max degree of the polynom of approximation by U. The */
2027 /* representation in the orthogonal base starts from degree */
2028 /* 0 to degree MXUJAC-2*(IORDRU+1). The polynomial base is the */
2029 /* base of Jacobi of order -1 (Legendre), 0, 1 or 2 */
2030 /* MXVJAC: Max degree of the polynom of approximation by V. The */
2031 /* representation in the orthogonal base starts from degree */
2032 /* 0 to degree MXUJAC-2*(IORDRU+1). The polynomial base is the */
2033 /* base of Jacobi of order -1 (Legendre), 0, 1 or 2 */
2034 /* IORDRU: Order of the base of Jacobi (-1,0,1 or 2) by U. Corresponds */
2035 /* to the step of constraints: C0, C1 or C2. */
2036 /* NCLIMV LIMIT nb of coeff by v of the solution P(u,v)
2037 * NCFIU1: Nb of Coeff. of curves stored in CRBIU1. */
2038 /* CRBIU1: Table of coeffs of the approximation of iso-U0 and its */
2039 /* derivatives till order IORDRU. */
2040 /* NCFIU2: Nb of Coeff. of curves stored in CRBIU2. */
2041 /* CRBIU2: Table of coeffs of approximation of iso-U1 and its */
2042 /* derivatives till order IORDRU */
2043 /* UHERMT: Coeff. of Hermit polynoms of order IORDRU. */
2044 /* PATJAC: Table of coefficients of the polynom P(u,v) of approximation */
2045 /* of F(u,v) WITHOUT taking into account the constraints. */
2046
2047 /* OUTPUT ARGUMENTS : */
2048 /* ------------------- */
2049 /* PATJAC: Table of coefficients of the polynom P(u,v) by approximation */
2050 /* of F(u,v) WITH taking into account of constraints. */
2051
2052
2053 /* > */
2054 /* **********************************************************************
2055 */
2056 /* The name of the routine */
2057
2058 /* --------------------------- Initializations --------------------------
2059 */
2060
2061 /* Parameter adjustments */
2062 patjac_dim1 = *mxujac + 1;
2063 patjac_dim2 = *mxvjac + 1;
2064 patjac_offset = patjac_dim1 * patjac_dim2;
2065 patjac -= patjac_offset;
2066 uhermt_dim1 = (*iordru << 1) + 2;
2067 uhermt_offset = uhermt_dim1;
2068 uhermt -= uhermt_offset;
2069 --ncfiu2;
2070 --ncfiu1;
2071 crbiu2_dim1 = *nclimv;
2072 crbiu2_dim2 = *ndimen;
2073 crbiu2_offset = crbiu2_dim1 * (crbiu2_dim2 + 1);
2074 crbiu2 -= crbiu2_offset;
2075 crbiu1_dim1 = *nclimv;
2076 crbiu1_dim2 = *ndimen;
2077 crbiu1_offset = crbiu1_dim1 * (crbiu1_dim2 + 1);
2078 crbiu1 -= crbiu1_offset;
2079
2080 /* Function Body */
2081 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
2082 if (ldbg) {
2083 AdvApp2Var_SysBase::mgenmsg_("MMA2AC3", 7L);
2084 }
2085
2086 /* ------------ ADDING of coeff by u of curves, by v of Hermit --------
2087 */
2088
2089 i__1 = *iordru + 1;
2090 for (ii = 1; ii <= i__1; ++ii) {
2091 ndgu1 = ncfiu1[ii] - 1;
2092 ndgu2 = ncfiu2[ii] - 1;
2093 i__2 = *ndimen;
2094 for (nd = 1; nd <= i__2; ++nd) {
2095 i__3 = ndgu1;
2096 for (jj = 0; jj <= i__3; ++jj) {
2097 bid1 = crbiu1[jj + (nd + ii * crbiu1_dim2) * crbiu1_dim1];
2098 i__4 = (*iordru << 1) + 1;
2099 for (kk = 0; kk <= i__4; ++kk) {
2100 patjac[kk + (jj + nd * patjac_dim2) * patjac_dim1] +=
2101 bid1 * uhermt[kk + ((ii << 1) - 1) * uhermt_dim1];
2102 /* L400: */
2103 }
2104 /* L300: */
2105 }
2106 i__3 = ndgu2;
2107 for (jj = 0; jj <= i__3; ++jj) {
2108 bid2 = crbiu2[jj + (nd + ii * crbiu2_dim2) * crbiu2_dim1];
2109 i__4 = (*iordru << 1) + 1;
2110 for (kk = 0; kk <= i__4; ++kk) {
2111 patjac[kk + (jj + nd * patjac_dim2) * patjac_dim1] +=
2112 bid2 * uhermt[kk + (ii << 1) * uhermt_dim1];
2113 /* L600: */
2114 }
2115 /* L500: */
2116 }
2117
2118 /* L200: */
2119 }
2120 /* L100: */
2121 }
2122
2123 /* ------------------------------ The end -------------------------------
2124 */
2125
2126 if (ldbg) {
2127 AdvApp2Var_SysBase::mgsomsg_("MMA2AC3", 7L);
2128 }
2129 return 0;
2130 } /* mma2ac3_ */
2131
2132 //=======================================================================
2133 //function : mma2can_
2134 //purpose :
2135 //=======================================================================
mma2can_(const integer * ncfmxu,const integer * ncfmxv,const integer * ndimen,const integer * iordru,const integer * iordrv,const integer * ncoefu,const integer * ncoefv,const doublereal * patjac,doublereal * pataux,doublereal * patcan,integer * iercod)2136 int AdvApp2Var_ApproxF2var::mma2can_(const integer *ncfmxu,
2137 const integer *ncfmxv,
2138 const integer *ndimen,
2139 const integer *iordru,
2140 const integer *iordrv,
2141 const integer *ncoefu,
2142 const integer *ncoefv,
2143 const doublereal *patjac,
2144 doublereal *pataux,
2145 doublereal *patcan,
2146 integer *iercod)
2147
2148 {
2149 /* System generated locals */
2150 integer patjac_dim1, patjac_dim2, patjac_offset, patcan_dim1, patcan_dim2,
2151 patcan_offset, i__1, i__2;
2152
2153 /* Local variables */
2154 logical ldbg;
2155 integer ilon1, ilon2, ii, nd;
2156
2157 /* **********************************************************************
2158 */
2159
2160 /* FUNCTION : */
2161 /* ---------- */
2162 /* Change of Jacobi base to canonical (-1,1) and writing in a greater */
2163 /* table. */
2164
2165 /* KEYWORDS : */
2166 /* ----------- */
2167 /* ALL,AB_SPECIFI,CARREAU&,CONVERSION,JACOBI,CANNONIQUE,&CARREAU */
2168
2169 /* INPUT ARGUMENTS : */
2170 /* -------------------- */
2171 /* NCFMXU: Dimension by U of resulting table PATCAN */
2172 /* NCFMXV: Dimension by V of resulting table PATCAN */
2173 /* NDIMEN: Dimension of the workspace. */
2174 /* IORDRU: Order of constraint by U */
2175 /* IORDRV: Order of constraint by V. */
2176 /* NCOEFU: Nb of coeff by U of square PATJAC */
2177 /* NCOEFV: Nb of coeff by V of square PATJAC */
2178 /* PATJAC: Square in the base of Jacobi of order IORDRU by U and */
2179 /* IORDRV by V. */
2180
2181 /* OUTPUT ARGUMENTS : */
2182 /* --------------------- */
2183 /* PATAUX: Auxiliary Table. */
2184 /* PATCAN: Table of coefficients in the canonic base. */
2185 /* IERCOD: Error code. */
2186 /* = 0, everything goes well, and all things are equal. */
2187 /* = 1, the program refuses to process with incorrect input arguments */
2188
2189
2190 /* COMMONS USED : */
2191 /* ------------------ */
2192
2193 /* REFERENCES CALLED : */
2194 /* --------------------- */
2195
2196 /* DESCRIPTION/NOTES/LIMITATIONS : */
2197 /* ----------------------------------- */
2198 /* > */
2199 /* **********************************************************************
2200 */
2201
2202
2203 /* Parameter adjustments */
2204 patcan_dim1 = *ncfmxu;
2205 patcan_dim2 = *ncfmxv;
2206 patcan_offset = patcan_dim1 * (patcan_dim2 + 1) + 1;
2207 patcan -= patcan_offset;
2208 --pataux;
2209 patjac_dim1 = *ncoefu;
2210 patjac_dim2 = *ncoefv;
2211 patjac_offset = patjac_dim1 * (patjac_dim2 + 1) + 1;
2212 patjac -= patjac_offset;
2213
2214 /* Function Body */
2215 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 2;
2216 if (ldbg) {
2217 AdvApp2Var_SysBase::mgenmsg_("MMA2CAN", 7L);
2218 }
2219 *iercod = 0;
2220
2221 if (*iordru < -1 || *iordru > 2) {
2222 goto L9100;
2223 }
2224 if (*iordrv < -1 || *iordrv > 2) {
2225 goto L9100;
2226 }
2227 if (*ncoefu > *ncfmxu || *ncoefv > *ncfmxv) {
2228 goto L9100;
2229 }
2230
2231 /* --> Pass to canonic base (-1,1) */
2232 mmjacpt_(ndimen, ncoefu, ncoefv, iordru, iordrv, &patjac[patjac_offset], &
2233 pataux[1], &patcan[patcan_offset]);
2234
2235 /* --> Write all in a greater table */
2236 AdvApp2Var_MathBase::mmfmca8_(ncoefu,
2237 ncoefv,
2238 ndimen,
2239 ncfmxu,
2240 ncfmxv,
2241 ndimen,
2242 &patcan[patcan_offset],
2243 &patcan[patcan_offset]);
2244
2245 /* --> Complete with zeros the resulting table. */
2246 ilon1 = *ncfmxu - *ncoefu;
2247 ilon2 = *ncfmxu * (*ncfmxv - *ncoefv);
2248 i__1 = *ndimen;
2249 for (nd = 1; nd <= i__1; ++nd) {
2250 if (ilon1 > 0) {
2251 i__2 = *ncoefv;
2252 for (ii = 1; ii <= i__2; ++ii) {
2253 AdvApp2Var_SysBase::mvriraz_(&ilon1,
2254 &patcan[*ncoefu + 1 + (ii + nd * patcan_dim2) * patcan_dim1]);
2255 /* L110: */
2256 }
2257 }
2258 if (ilon2 > 0) {
2259 AdvApp2Var_SysBase::mvriraz_(&ilon2,
2260 &patcan[(*ncoefv + 1 + nd * patcan_dim2) * patcan_dim1 + 1]);
2261 }
2262 /* L100: */
2263 }
2264
2265 goto L9999;
2266
2267 /* ----------------------
2268 */
2269
2270 L9100:
2271 *iercod = 1;
2272 goto L9999;
2273
2274 L9999:
2275 AdvApp2Var_SysBase::maermsg_("MMA2CAN", iercod, 7L);
2276 if (ldbg) {
2277 AdvApp2Var_SysBase::mgsomsg_("MMA2CAN", 7L);
2278 }
2279 return 0 ;
2280 } /* mma2can_ */
2281
2282 //=======================================================================
2283 //function : mma2cd1_
2284 //purpose :
2285 //=======================================================================
mma2cd1_(integer * ndimen,integer * nbpntu,doublereal * urootl,integer * nbpntv,doublereal * vrootl,integer * iordru,integer * iordrv,doublereal * contr1,doublereal * contr2,doublereal * contr3,doublereal * contr4,doublereal * fpntbu,doublereal * fpntbv,doublereal * uhermt,doublereal * vhermt,doublereal * sosotb,doublereal * soditb,doublereal * disotb,doublereal * diditb)2286 int mma2cd1_(integer *ndimen,
2287 integer *nbpntu,
2288 doublereal *urootl,
2289 integer *nbpntv,
2290 doublereal *vrootl,
2291 integer *iordru,
2292 integer *iordrv,
2293 doublereal *contr1,
2294 doublereal *contr2,
2295 doublereal *contr3,
2296 doublereal *contr4,
2297 doublereal *fpntbu,
2298 doublereal *fpntbv,
2299 doublereal *uhermt,
2300 doublereal *vhermt,
2301 doublereal *sosotb,
2302 doublereal *soditb,
2303 doublereal *disotb,
2304 doublereal *diditb)
2305
2306 {
2307 integer c__1 = 1;
2308
2309 /* System generated locals */
2310 integer contr1_dim1, contr1_dim2, contr1_offset, contr2_dim1, contr2_dim2,
2311 contr2_offset, contr3_dim1, contr3_dim2, contr3_offset,
2312 contr4_dim1, contr4_dim2, contr4_offset, uhermt_dim1,
2313 uhermt_offset, vhermt_dim1, vhermt_offset, fpntbu_dim1,
2314 fpntbu_offset, fpntbv_dim1, fpntbv_offset, sosotb_dim1,
2315 sosotb_dim2, sosotb_offset, diditb_dim1, diditb_dim2,
2316 diditb_offset, soditb_dim1, soditb_dim2, soditb_offset,
2317 disotb_dim1, disotb_dim2, disotb_offset, i__1, i__2, i__3, i__4,
2318 i__5;
2319
2320 /* Local variables */
2321 integer ncfhu, ncfhv, nuroo, nvroo, nd, ii, jj, kk, ll, ibb, kkm,
2322 llm, kkp, llp;
2323 doublereal bid1, bid2, bid3, bid4;
2324 doublereal diu1, diu2, div1, div2, sou1, sou2, sov1, sov2;
2325
2326 /* **********************************************************************
2327 */
2328
2329 /* FUNCTION : */
2330 /* ---------- */
2331 /* Discretisation on the parameters of polynoms of interpolation */
2332 /* of constraints at the corners of order IORDRE. */
2333
2334 /* KEYWORDS : */
2335 /* ----------- */
2336 /* TOUS, AB_SPECIFI::CONTRAINTE&, DISCRETISATION, &POINT */
2337
2338 /* INPUT ARGUMENTS : */
2339 /* ------------------ */
2340 /* NDIMEN: Dimension of the space. */
2341 /* NBPNTU: Nb of INTERNAL parameters of discretisation by U. */
2342 /* This is also the nb of root of Legendre polynom where discretization is done. */
2343 /* UROOTL: Table of parameters of discretisation ON (-1,1) by U.
2344 */
2345 /* NBPNTV: Nb of INTERNAL parameters of discretisation by V. */
2346 /* This is also the nb of root of Legendre polynom where discretization is done. */
2347 /* VROOTL: Table of discretization parameters on (-1,1) by V. */
2348 /* IORDRU: Order of constraint imposed at the extremities of iso-V */
2349 /* = 0, calculate the extremities of iso-V */
2350 /* = 1, calculate, additionally, the 1st derivative in the direction of iso-V */
2351 /* = 2, calculate, additionally, the 2nd derivative in the direction of iso-V */
2352 /* IORDRV: Order of constraint imposed at the extremities of iso-U */
2353 /* = 0, calculate the extremities of iso-U */
2354 /* = 1, calculate, additionally, the 1st derivative in the direction of iso-U */
2355 /* = 2, calculate, additionally, the 2nd derivative in the direction of iso-U */
2356 /* CONTR1: Contains, if IORDRU and IORDRV>=0, the values at the */
2357 /* extremities of F(U0,V0) and its derivatives. */
2358 /* CONTR2: Contains, if IORDRU and IORDRV>=0, the values at the */
2359 /* extremities of F(U1,V0) and its derivatives. */
2360 /* CONTR3: Contains, if IORDRU and IORDRV>=0, the values at the */
2361 /* extremities of F(U0,V1) and its derivatives. */
2362 /* CONTR4: Contains, if IORDRU and IORDRV>=0, the values at the */
2363 /* extremities of F(U1,V1) and its derivatives. */
2364 /* SOSOTB: Preinitialized table (input/output argument). */
2365 /* DISOTB: Preinitialized table (input/output argument). */
2366 /* SODITB: Preinitialized table (input/output argument). */
2367 /* DIDITB: Preinitialized table (input/output argument) */
2368
2369 /* OUTPUT ARGUMENTS : */
2370 /* ------------------- */
2371 /* FPNTBU: Auxiliary table. */
2372 /* FPNTBV: Auxiliary table. */
2373 /* UHERMT: Table of 2*(IORDRU+1) coeff. of 2*(IORDRU+1) polynoms of Hermite. */
2374 /* VHERMT: Table of 2*(IORDRV+1) coeff. of 2*(IORDRV+1) polynoms of Hermite. */
2375 /* SOSOTB: Table where the terms of constraints are added */
2376 /* C(ui,vj) + C(ui,-vj) + C(-ui,vj) + C(-ui,-vj) */
2377 /* with ui and vj positive roots of the Legendre polynom */
2378 /* of degree NBPNTU and NBPNTV respectively. */
2379 /* DISOTB: Table where the terms of constraints are added */
2380 /* C(ui,vj) + C(ui,-vj) - C(-ui,vj) - C(-ui,-vj) */
2381 /* with ui and vj positive roots of the polynom of Legendre */
2382 /* of degree NBPNTU and NBPNTV respectively. */
2383 /* SODITB: Table where the terms of constraints are added */
2384 /* C(ui,vj) - C(ui,-vj) + C(-ui,vj) - C(-ui,-vj) */
2385 /* with ui and vj positive roots of the polynom of Legendre */
2386 /* of degree NBPNTU and NBPNTV respectively. */
2387 /* DIDITB: Table where the terms of constraints are added */
2388 /* C(ui,vj) - C(ui,-vj) - C(-ui,vj) + C(-ui,-vj) */
2389 /* with ui and vj positive roots of the polynom of Legendre */
2390 /* of degree NBPNTU and NBPNTV respectively. */
2391
2392 /* COMMONS USED : */
2393 /* ---------------- */
2394
2395 /* REFERENCES CALLED : */
2396 /* ----------------------- */
2397
2398 /* DESCRIPTION/NOTES/LIMITATIONS : */
2399 /* ----------------------------------- */
2400
2401 /* > */
2402 /* **********************************************************************
2403 */
2404
2405 /* Name of the routine */
2406
2407
2408 /* Parameter adjustments */
2409 --urootl;
2410 diditb_dim1 = *nbpntu / 2 + 1;
2411 diditb_dim2 = *nbpntv / 2 + 1;
2412 diditb_offset = diditb_dim1 * diditb_dim2;
2413 diditb -= diditb_offset;
2414 disotb_dim1 = *nbpntu / 2;
2415 disotb_dim2 = *nbpntv / 2;
2416 disotb_offset = disotb_dim1 * (disotb_dim2 + 1) + 1;
2417 disotb -= disotb_offset;
2418 soditb_dim1 = *nbpntu / 2;
2419 soditb_dim2 = *nbpntv / 2;
2420 soditb_offset = soditb_dim1 * (soditb_dim2 + 1) + 1;
2421 soditb -= soditb_offset;
2422 sosotb_dim1 = *nbpntu / 2 + 1;
2423 sosotb_dim2 = *nbpntv / 2 + 1;
2424 sosotb_offset = sosotb_dim1 * sosotb_dim2;
2425 sosotb -= sosotb_offset;
2426 --vrootl;
2427 uhermt_dim1 = (*iordru << 1) + 2;
2428 uhermt_offset = uhermt_dim1;
2429 uhermt -= uhermt_offset;
2430 fpntbu_dim1 = *nbpntu;
2431 fpntbu_offset = fpntbu_dim1 + 1;
2432 fpntbu -= fpntbu_offset;
2433 vhermt_dim1 = (*iordrv << 1) + 2;
2434 vhermt_offset = vhermt_dim1;
2435 vhermt -= vhermt_offset;
2436 fpntbv_dim1 = *nbpntv;
2437 fpntbv_offset = fpntbv_dim1 + 1;
2438 fpntbv -= fpntbv_offset;
2439 contr4_dim1 = *ndimen;
2440 contr4_dim2 = *iordru + 2;
2441 contr4_offset = contr4_dim1 * (contr4_dim2 + 1) + 1;
2442 contr4 -= contr4_offset;
2443 contr3_dim1 = *ndimen;
2444 contr3_dim2 = *iordru + 2;
2445 contr3_offset = contr3_dim1 * (contr3_dim2 + 1) + 1;
2446 contr3 -= contr3_offset;
2447 contr2_dim1 = *ndimen;
2448 contr2_dim2 = *iordru + 2;
2449 contr2_offset = contr2_dim1 * (contr2_dim2 + 1) + 1;
2450 contr2 -= contr2_offset;
2451 contr1_dim1 = *ndimen;
2452 contr1_dim2 = *iordru + 2;
2453 contr1_offset = contr1_dim1 * (contr1_dim2 + 1) + 1;
2454 contr1 -= contr1_offset;
2455
2456 /* Function Body */
2457 ibb = AdvApp2Var_SysBase::mnfndeb_();
2458 if (ibb >= 3) {
2459 AdvApp2Var_SysBase::mgenmsg_("MMA2CD1", 7L);
2460 }
2461
2462 /* ------------------- Discretisation of Hermite polynoms -----------
2463 */
2464
2465 ncfhu = (*iordru + 1) << 1;
2466 i__1 = ncfhu;
2467 for (ii = 1; ii <= i__1; ++ii) {
2468 i__2 = *nbpntu;
2469 for (ll = 1; ll <= i__2; ++ll) {
2470 AdvApp2Var_MathBase::mmmpocur_(&ncfhu, &c__1, &ncfhu, &uhermt[ii * uhermt_dim1], &
2471 urootl[ll], &fpntbu[ll + ii * fpntbu_dim1]);
2472 /* L20: */
2473 }
2474 /* L10: */
2475 }
2476 ncfhv = (*iordrv + 1) << 1;
2477 i__1 = ncfhv;
2478 for (jj = 1; jj <= i__1; ++jj) {
2479 i__2 = *nbpntv;
2480 for (kk = 1; kk <= i__2; ++kk) {
2481 AdvApp2Var_MathBase::mmmpocur_(&ncfhv, &c__1, &ncfhv, &vhermt[jj * vhermt_dim1], &
2482 vrootl[kk], &fpntbv[kk + jj * fpntbv_dim1]);
2483 /* L40: */
2484 }
2485 /* L30: */
2486 }
2487
2488 /* ---- The discretizations of polynoms of constraints are subtracted ----
2489 */
2490
2491 nuroo = *nbpntu / 2;
2492 nvroo = *nbpntv / 2;
2493 i__1 = *ndimen;
2494 for (nd = 1; nd <= i__1; ++nd) {
2495
2496 i__2 = *iordrv + 1;
2497 for (jj = 1; jj <= i__2; ++jj) {
2498 i__3 = *iordru + 1;
2499 for (ii = 1; ii <= i__3; ++ii) {
2500 bid1 = contr1[nd + (ii + jj * contr1_dim2) * contr1_dim1];
2501 bid2 = contr2[nd + (ii + jj * contr2_dim2) * contr2_dim1];
2502 bid3 = contr3[nd + (ii + jj * contr3_dim2) * contr3_dim1];
2503 bid4 = contr4[nd + (ii + jj * contr4_dim2) * contr4_dim1];
2504
2505 i__4 = nvroo;
2506 for (kk = 1; kk <= i__4; ++kk) {
2507 kkp = (*nbpntv + 1) / 2 + kk;
2508 kkm = nvroo - kk + 1;
2509 sov1 = fpntbv[kkp + ((jj << 1) - 1) * fpntbv_dim1] +
2510 fpntbv[kkm + ((jj << 1) - 1) * fpntbv_dim1];
2511 div1 = fpntbv[kkp + ((jj << 1) - 1) * fpntbv_dim1] -
2512 fpntbv[kkm + ((jj << 1) - 1) * fpntbv_dim1];
2513 sov2 = fpntbv[kkp + (jj << 1) * fpntbv_dim1] + fpntbv[kkm
2514 + (jj << 1) * fpntbv_dim1];
2515 div2 = fpntbv[kkp + (jj << 1) * fpntbv_dim1] - fpntbv[kkm
2516 + (jj << 1) * fpntbv_dim1];
2517 i__5 = nuroo;
2518 for (ll = 1; ll <= i__5; ++ll) {
2519 llp = (*nbpntu + 1) / 2 + ll;
2520 llm = nuroo - ll + 1;
2521 sou1 = fpntbu[llp + ((ii << 1) - 1) * fpntbu_dim1] +
2522 fpntbu[llm + ((ii << 1) - 1) * fpntbu_dim1];
2523 diu1 = fpntbu[llp + ((ii << 1) - 1) * fpntbu_dim1] -
2524 fpntbu[llm + ((ii << 1) - 1) * fpntbu_dim1];
2525 sou2 = fpntbu[llp + (ii << 1) * fpntbu_dim1] + fpntbu[
2526 llm + (ii << 1) * fpntbu_dim1];
2527 diu2 = fpntbu[llp + (ii << 1) * fpntbu_dim1] - fpntbu[
2528 llm + (ii << 1) * fpntbu_dim1];
2529 sosotb[ll + (kk + nd * sosotb_dim2) * sosotb_dim1] =
2530 sosotb[ll + (kk + nd * sosotb_dim2) *
2531 sosotb_dim1] - bid1 * sou1 * sov1 - bid2 *
2532 sou2 * sov1 - bid3 * sou1 * sov2 - bid4 *
2533 sou2 * sov2;
2534 soditb[ll + (kk + nd * soditb_dim2) * soditb_dim1] =
2535 soditb[ll + (kk + nd * soditb_dim2) *
2536 soditb_dim1] - bid1 * sou1 * div1 - bid2 *
2537 sou2 * div1 - bid3 * sou1 * div2 - bid4 *
2538 sou2 * div2;
2539 disotb[ll + (kk + nd * disotb_dim2) * disotb_dim1] =
2540 disotb[ll + (kk + nd * disotb_dim2) *
2541 disotb_dim1] - bid1 * diu1 * sov1 - bid2 *
2542 diu2 * sov1 - bid3 * diu1 * sov2 - bid4 *
2543 diu2 * sov2;
2544 diditb[ll + (kk + nd * diditb_dim2) * diditb_dim1] =
2545 diditb[ll + (kk + nd * diditb_dim2) *
2546 diditb_dim1] - bid1 * diu1 * div1 - bid2 *
2547 diu2 * div1 - bid3 * diu1 * div2 - bid4 *
2548 diu2 * div2;
2549 /* L450: */
2550 }
2551 /* L400: */
2552 }
2553
2554 /* ------------ Case when the discretization is done only on the roots
2555 ----------- */
2556 /* ---------- of Legendre polynom of uneven degree, 0 is root
2557 ----------- */
2558
2559 if (*nbpntu % 2 == 1) {
2560 sou1 = fpntbu[nuroo + 1 + ((ii << 1) - 1) * fpntbu_dim1];
2561 sou2 = fpntbu[nuroo + 1 + (ii << 1) * fpntbu_dim1];
2562 i__4 = nvroo;
2563 for (kk = 1; kk <= i__4; ++kk) {
2564 kkp = (*nbpntv + 1) / 2 + kk;
2565 kkm = nvroo - kk + 1;
2566 sov1 = fpntbv[kkp + ((jj << 1) - 1) * fpntbv_dim1] +
2567 fpntbv[kkm + ((jj << 1) - 1) * fpntbv_dim1];
2568 div1 = fpntbv[kkp + ((jj << 1) - 1) * fpntbv_dim1] -
2569 fpntbv[kkm + ((jj << 1) - 1) * fpntbv_dim1];
2570 sov2 = fpntbv[kkp + (jj << 1) * fpntbv_dim1] + fpntbv[
2571 kkm + (jj << 1) * fpntbv_dim1];
2572 div2 = fpntbv[kkp + (jj << 1) * fpntbv_dim1] - fpntbv[
2573 kkm + (jj << 1) * fpntbv_dim1];
2574 sosotb[(kk + nd * sosotb_dim2) * sosotb_dim1] =
2575 sosotb[(kk + nd * sosotb_dim2) * sosotb_dim1]
2576 - bid1 * sou1 * sov1 - bid2 * sou2 * sov1 -
2577 bid3 * sou1 * sov2 - bid4 * sou2 * sov2;
2578 diditb[(kk + nd * diditb_dim2) * diditb_dim1] =
2579 diditb[(kk + nd * diditb_dim2) * diditb_dim1]
2580 - bid1 * sou1 * div1 - bid2 * sou2 * div1 -
2581 bid3 * sou1 * div2 - bid4 * sou2 * div2;
2582 /* L500: */
2583 }
2584 }
2585
2586 if (*nbpntv % 2 == 1) {
2587 sov1 = fpntbv[nvroo + 1 + ((jj << 1) - 1) * fpntbv_dim1];
2588 sov2 = fpntbv[nvroo + 1 + (jj << 1) * fpntbv_dim1];
2589 i__4 = nuroo;
2590 for (ll = 1; ll <= i__4; ++ll) {
2591 llp = (*nbpntu + 1) / 2 + ll;
2592 llm = nuroo - ll + 1;
2593 sou1 = fpntbu[llp + ((ii << 1) - 1) * fpntbu_dim1] +
2594 fpntbu[llm + ((ii << 1) - 1) * fpntbu_dim1];
2595 diu1 = fpntbu[llp + ((ii << 1) - 1) * fpntbu_dim1] -
2596 fpntbu[llm + ((ii << 1) - 1) * fpntbu_dim1];
2597 sou2 = fpntbu[llp + (ii << 1) * fpntbu_dim1] + fpntbu[
2598 llm + (ii << 1) * fpntbu_dim1];
2599 diu2 = fpntbu[llp + (ii << 1) * fpntbu_dim1] - fpntbu[
2600 llm + (ii << 1) * fpntbu_dim1];
2601 sosotb[ll + nd * sosotb_dim2 * sosotb_dim1] = sosotb[
2602 ll + nd * sosotb_dim2 * sosotb_dim1] - bid1 *
2603 sou1 * sov1 - bid2 * sou2 * sov1 - bid3 *
2604 sou1 * sov2 - bid4 * sou2 * sov2;
2605 diditb[ll + nd * diditb_dim2 * diditb_dim1] = diditb[
2606 ll + nd * diditb_dim2 * diditb_dim1] - bid1 *
2607 diu1 * sov1 - bid2 * diu2 * sov1 - bid3 *
2608 diu1 * sov2 - bid4 * diu2 * sov2;
2609 /* L600: */
2610 }
2611 }
2612
2613 if (*nbpntu % 2 == 1 && *nbpntv % 2 == 1) {
2614 sou1 = fpntbu[nuroo + 1 + ((ii << 1) - 1) * fpntbu_dim1];
2615 sou2 = fpntbu[nuroo + 1 + (ii << 1) * fpntbu_dim1];
2616 sov1 = fpntbv[nvroo + 1 + ((jj << 1) - 1) * fpntbv_dim1];
2617 sov2 = fpntbv[nvroo + 1 + (jj << 1) * fpntbv_dim1];
2618 sosotb[nd * sosotb_dim2 * sosotb_dim1] = sosotb[nd *
2619 sosotb_dim2 * sosotb_dim1] - bid1 * sou1 * sov1 -
2620 bid2 * sou2 * sov1 - bid3 * sou1 * sov2 - bid4 *
2621 sou2 * sov2;
2622 diditb[nd * diditb_dim2 * diditb_dim1] = diditb[nd *
2623 diditb_dim2 * diditb_dim1] - bid1 * sou1 * sov1 -
2624 bid2 * sou2 * sov1 - bid3 * sou1 * sov2 - bid4 *
2625 sou2 * sov2;
2626 }
2627
2628 /* L300: */
2629 }
2630 /* L200: */
2631 }
2632 /* L100: */
2633 }
2634 goto L9999;
2635
2636 /* ------------------------------ The End -------------------------------
2637 */
2638
2639 L9999:
2640 if (ibb >= 3) {
2641 AdvApp2Var_SysBase::mgsomsg_("MMA2CD1", 7L);
2642 }
2643 return 0;
2644 } /* mma2cd1_ */
2645
2646 //=======================================================================
2647 //function : mma2cd2_
2648 //purpose :
2649 //=======================================================================
mma2cd2_(integer * ndimen,integer * nbpntu,integer * nbpntv,doublereal * vrootl,integer * iordrv,doublereal * sotbv1,doublereal * sotbv2,doublereal * ditbv1,doublereal * ditbv2,doublereal * fpntab,doublereal * vhermt,doublereal * sosotb,doublereal * soditb,doublereal * disotb,doublereal * diditb)2650 int mma2cd2_(integer *ndimen,
2651 integer *nbpntu,
2652 integer *nbpntv,
2653 doublereal *vrootl,
2654 integer *iordrv,
2655 doublereal *sotbv1,
2656 doublereal *sotbv2,
2657 doublereal *ditbv1,
2658 doublereal *ditbv2,
2659 doublereal *fpntab,
2660 doublereal *vhermt,
2661 doublereal *sosotb,
2662 doublereal *soditb,
2663 doublereal *disotb,
2664 doublereal *diditb)
2665
2666 {
2667 integer c__1 = 1;
2668 /* System generated locals */
2669 integer sotbv1_dim1, sotbv1_dim2, sotbv1_offset, sotbv2_dim1, sotbv2_dim2,
2670 sotbv2_offset, ditbv1_dim1, ditbv1_dim2, ditbv1_offset,
2671 ditbv2_dim1, ditbv2_dim2, ditbv2_offset, fpntab_dim1,
2672 fpntab_offset, vhermt_dim1, vhermt_offset, sosotb_dim1,
2673 sosotb_dim2, sosotb_offset, diditb_dim1, diditb_dim2,
2674 diditb_offset, soditb_dim1, soditb_dim2, soditb_offset,
2675 disotb_dim1, disotb_dim2, disotb_offset, i__1, i__2, i__3, i__4;
2676
2677 /* Local variables */
2678 integer ncfhv, nuroo, nvroo, ii, nd, jj, kk, ibb, jjm, jjp;
2679 doublereal bid1, bid2, bid3, bid4;
2680
2681 /* **********************************************************************
2682 */
2683 /* FUNCTION : */
2684 /* ---------- */
2685 /* Discretisation on the parameters of polynoms of interpolation */
2686 /* of constraints on 2 borders iso-V of order IORDRV. */
2687
2688
2689 /* KEYWORDS : */
2690 /* ----------- */
2691 /* TOUS, AB_SPECIFI::CONTRAINTE&, DISCRETISATION, &POINT */
2692
2693
2694
2695 /* INPUT ARGUMENTS : */
2696 /* ------------------ */
2697 /* NDIMEN: Dimension of the space. */
2698 /* NBPNTU: Nb of INTERNAL parameters of discretisation by U. */
2699 /* This is also the nb of root of Legendre polynom where discretization is done. */
2700 /* UROOTL: Table of parameters of discretisation ON (-1,1) by U.
2701 */
2702 /* NBPNTV: Nb of INTERNAL parameters of discretisation by V. */
2703 /* This is also the nb of root of Legendre polynom where discretization is done. */
2704 /* VROOTL: Table of discretization parameters on (-1,1) by V. */
2705 /* IORDRV: Order of constraint imposed at the extremities of iso-V */
2706 /* = 0, calculate the extremities of iso-V */
2707 /* = 1, calculate, additionally, the 1st derivative in the direction of iso-V */
2708 /* = 2, calculate, additionally, the 2nd derivative in the direction of iso-V */
2709 /* SOTBV1: Table of NBPNTV/2 sums of 2 index points */
2710 /* NBPNTV-II+1 and II, for II = 1, NBPNTV/2 on iso-V0. */
2711 /* SOTBV2: Table of NBPNTV/2 sums of 2 index points */
2712 /* NBPNTV-II+1 and II, for II = 1, NBPNTV/2 on iso-V1. */
2713 /* DITBV1: Table of NBPNTV/2 differences of 2 index points */
2714 /* NBPNTV-II+1 and II, for II = 1, NBPNTV/2 on iso-V0. */
2715 /* DITBV2: Table of NBPNTV/2 differences of 2 index points */
2716 /* NBPNTV-II+1 and II, for II = 1, NBPNTV/2 on iso-V1. */
2717 /* SOSOTB: Preinitialized table (input/output argument). */
2718 /* DISOTB: Preinitialized table (input/output argument). */
2719 /* SODITB: Preinitialized table (input/output argument). */
2720 /* DIDITB: Preinitialized table (input/output argument) */
2721
2722 /* OUTPUT ARGUMENTS : */
2723 /* ------------------- */
2724 /* FPNTAB: Auxiliary table. */
2725 /* VHERMT: Table of 2*(IORDRV+1) coeff. of 2*(IORDRV+1) polynoms of Hermite. */
2726 /* SOSOTB: Table where the terms of constraints are added */
2727 /* C(ui,vj) + C(ui,-vj) + C(-ui,vj) + C(-ui,-vj) */
2728 /* with ui and vj positive roots of the Legendre polynom */
2729 /* of degree NBPNTU and NBPNTV respectively. */
2730 /* DISOTB: Table where the terms of constraints are added */
2731 /* C(ui,vj) + C(ui,-vj) - C(-ui,vj) - C(-ui,-vj) */
2732 /* with ui and vj positive roots of the polynom of Legendre */
2733 /* of degree NBPNTU and NBPNTV respectively. */
2734 /* SODITB: Table where the terms of constraints are added */
2735 /* C(ui,vj) - C(ui,-vj) + C(-ui,vj) - C(-ui,-vj) */
2736 /* with ui and vj positive roots of the polynom of Legendre */
2737 /* of degree NBPNTU and NBPNTV respectively. */
2738 /* DIDITB: Table where the terms of constraints are added */
2739 /* C(ui,vj) - C(ui,-vj) - C(-ui,vj) + C(-ui,-vj) */
2740 /* with ui and vj positive roots of the polynom of Legendre */
2741 /* of degree NBPNTU and NBPNTV respectively. */
2742
2743 /* COMMONS USED : */
2744 /* ---------------- */
2745
2746 /* REFERENCES CALLED : */
2747 /* ----------------------- */
2748
2749 /* DESCRIPTION/NOTES/LIMITATIONS : */
2750 /* ----------------------------------- */
2751
2752
2753 /* > */
2754 /* **********************************************************************
2755 */
2756
2757 /* Name of the routine */
2758
2759
2760 /* Parameter adjustments */
2761 diditb_dim1 = *nbpntu / 2 + 1;
2762 diditb_dim2 = *nbpntv / 2 + 1;
2763 diditb_offset = diditb_dim1 * diditb_dim2;
2764 diditb -= diditb_offset;
2765 disotb_dim1 = *nbpntu / 2;
2766 disotb_dim2 = *nbpntv / 2;
2767 disotb_offset = disotb_dim1 * (disotb_dim2 + 1) + 1;
2768 disotb -= disotb_offset;
2769 soditb_dim1 = *nbpntu / 2;
2770 soditb_dim2 = *nbpntv / 2;
2771 soditb_offset = soditb_dim1 * (soditb_dim2 + 1) + 1;
2772 soditb -= soditb_offset;
2773 sosotb_dim1 = *nbpntu / 2 + 1;
2774 sosotb_dim2 = *nbpntv / 2 + 1;
2775 sosotb_offset = sosotb_dim1 * sosotb_dim2;
2776 sosotb -= sosotb_offset;
2777 --vrootl;
2778 vhermt_dim1 = (*iordrv << 1) + 2;
2779 vhermt_offset = vhermt_dim1;
2780 vhermt -= vhermt_offset;
2781 fpntab_dim1 = *nbpntv;
2782 fpntab_offset = fpntab_dim1 + 1;
2783 fpntab -= fpntab_offset;
2784 ditbv2_dim1 = *nbpntu / 2 + 1;
2785 ditbv2_dim2 = *ndimen;
2786 ditbv2_offset = ditbv2_dim1 * (ditbv2_dim2 + 1);
2787 ditbv2 -= ditbv2_offset;
2788 ditbv1_dim1 = *nbpntu / 2 + 1;
2789 ditbv1_dim2 = *ndimen;
2790 ditbv1_offset = ditbv1_dim1 * (ditbv1_dim2 + 1);
2791 ditbv1 -= ditbv1_offset;
2792 sotbv2_dim1 = *nbpntu / 2 + 1;
2793 sotbv2_dim2 = *ndimen;
2794 sotbv2_offset = sotbv2_dim1 * (sotbv2_dim2 + 1);
2795 sotbv2 -= sotbv2_offset;
2796 sotbv1_dim1 = *nbpntu / 2 + 1;
2797 sotbv1_dim2 = *ndimen;
2798 sotbv1_offset = sotbv1_dim1 * (sotbv1_dim2 + 1);
2799 sotbv1 -= sotbv1_offset;
2800
2801 /* Function Body */
2802 ibb = AdvApp2Var_SysBase::mnfndeb_();
2803 if (ibb >= 3) {
2804 AdvApp2Var_SysBase::mgenmsg_("MMA2CD2", 7L);
2805 }
2806
2807 /* ------------------- Discretization of Hermit polynoms -----------
2808 */
2809
2810 ncfhv = (*iordrv + 1) << 1;
2811 i__1 = ncfhv;
2812 for (ii = 1; ii <= i__1; ++ii) {
2813 i__2 = *nbpntv;
2814 for (jj = 1; jj <= i__2; ++jj) {
2815 AdvApp2Var_MathBase::mmmpocur_(&ncfhv, &c__1, &ncfhv, &vhermt[ii * vhermt_dim1], &
2816 vrootl[jj], &fpntab[jj + ii * fpntab_dim1]);
2817 /* L60: */
2818 }
2819 /* L50: */
2820 }
2821
2822 /* ---- The discretizations of polynoms of constraints are subtracted ----
2823 */
2824
2825 nuroo = *nbpntu / 2;
2826 nvroo = *nbpntv / 2;
2827
2828 i__1 = *ndimen;
2829 for (nd = 1; nd <= i__1; ++nd) {
2830 i__2 = *iordrv + 1;
2831 for (ii = 1; ii <= i__2; ++ii) {
2832
2833 i__3 = nuroo;
2834 for (kk = 1; kk <= i__3; ++kk) {
2835 bid1 = sotbv1[kk + (nd + ii * sotbv1_dim2) * sotbv1_dim1];
2836 bid2 = sotbv2[kk + (nd + ii * sotbv2_dim2) * sotbv2_dim1];
2837 bid3 = ditbv1[kk + (nd + ii * ditbv1_dim2) * ditbv1_dim1];
2838 bid4 = ditbv2[kk + (nd + ii * ditbv2_dim2) * ditbv2_dim1];
2839 i__4 = nvroo;
2840 for (jj = 1; jj <= i__4; ++jj) {
2841 jjp = (*nbpntv + 1) / 2 + jj;
2842 jjm = nvroo - jj + 1;
2843 sosotb[kk + (jj + nd * sosotb_dim2) * sosotb_dim1] =
2844 sosotb[kk + (jj + nd * sosotb_dim2) * sosotb_dim1]
2845 - bid1 * (fpntab[jjp + ((ii << 1) - 1) *
2846 fpntab_dim1] + fpntab[jjm + ((ii << 1) - 1) *
2847 fpntab_dim1]) - bid2 * (fpntab[jjp + (ii << 1) *
2848 fpntab_dim1] + fpntab[jjm + (ii << 1) *
2849 fpntab_dim1]);
2850 disotb[kk + (jj + nd * disotb_dim2) * disotb_dim1] =
2851 disotb[kk + (jj + nd * disotb_dim2) * disotb_dim1]
2852 - bid3 * (fpntab[jjp + ((ii << 1) - 1) *
2853 fpntab_dim1] + fpntab[jjm + ((ii << 1) - 1) *
2854 fpntab_dim1]) - bid4 * (fpntab[jjp + (ii << 1) *
2855 fpntab_dim1] + fpntab[jjm + (ii << 1) *
2856 fpntab_dim1]);
2857 soditb[kk + (jj + nd * soditb_dim2) * soditb_dim1] =
2858 soditb[kk + (jj + nd * soditb_dim2) * soditb_dim1]
2859 - bid1 * (fpntab[jjp + ((ii << 1) - 1) *
2860 fpntab_dim1] - fpntab[jjm + ((ii << 1) - 1) *
2861 fpntab_dim1]) - bid2 * (fpntab[jjp + (ii << 1) *
2862 fpntab_dim1] - fpntab[jjm + (ii << 1) *
2863 fpntab_dim1]);
2864 diditb[kk + (jj + nd * diditb_dim2) * diditb_dim1] =
2865 diditb[kk + (jj + nd * diditb_dim2) * diditb_dim1]
2866 - bid3 * (fpntab[jjp + ((ii << 1) - 1) *
2867 fpntab_dim1] - fpntab[jjm + ((ii << 1) - 1) *
2868 fpntab_dim1]) - bid4 * (fpntab[jjp + (ii << 1) *
2869 fpntab_dim1] - fpntab[jjm + (ii << 1) *
2870 fpntab_dim1]);
2871 /* L400: */
2872 }
2873 /* L300: */
2874 }
2875 /* L200: */
2876 }
2877
2878 /* ------------ Case when the discretization is done only on the roots */
2879 /* ---------- of Legendre polynom of uneven degree, 0 is root */
2880
2881
2882 if (*nbpntv % 2 == 1) {
2883 i__2 = *iordrv + 1;
2884 for (ii = 1; ii <= i__2; ++ii) {
2885 i__3 = nuroo;
2886 for (kk = 1; kk <= i__3; ++kk) {
2887 bid1 = sotbv1[kk + (nd + ii * sotbv1_dim2) * sotbv1_dim1]
2888 * fpntab[nvroo + 1 + ((ii << 1) - 1) *
2889 fpntab_dim1] + sotbv2[kk + (nd + ii * sotbv2_dim2)
2890 * sotbv2_dim1] * fpntab[nvroo + 1 + (ii << 1) *
2891 fpntab_dim1];
2892 sosotb[kk + nd * sosotb_dim2 * sosotb_dim1] -= bid1;
2893 bid2 = ditbv1[kk + (nd + ii * ditbv1_dim2) * ditbv1_dim1]
2894 * fpntab[nvroo + 1 + ((ii << 1) - 1) *
2895 fpntab_dim1] + ditbv2[kk + (nd + ii * ditbv2_dim2)
2896 * ditbv2_dim1] * fpntab[nvroo + 1 + (ii << 1) *
2897 fpntab_dim1];
2898 diditb[kk + nd * diditb_dim2 * diditb_dim1] -= bid2;
2899 /* L550: */
2900 }
2901 /* L500: */
2902 }
2903 }
2904
2905 if (*nbpntu % 2 == 1) {
2906 i__2 = *iordrv + 1;
2907 for (ii = 1; ii <= i__2; ++ii) {
2908 i__3 = nvroo;
2909 for (jj = 1; jj <= i__3; ++jj) {
2910 jjp = (*nbpntv + 1) / 2 + jj;
2911 jjm = nvroo - jj + 1;
2912 bid1 = sotbv1[(nd + ii * sotbv1_dim2) * sotbv1_dim1] * (
2913 fpntab[jjp + ((ii << 1) - 1) * fpntab_dim1] +
2914 fpntab[jjm + ((ii << 1) - 1) * fpntab_dim1]) +
2915 sotbv2[(nd + ii * sotbv2_dim2) * sotbv2_dim1] * (
2916 fpntab[jjp + (ii << 1) * fpntab_dim1] + fpntab[
2917 jjm + (ii << 1) * fpntab_dim1]);
2918 sosotb[(jj + nd * sosotb_dim2) * sosotb_dim1] -= bid1;
2919 bid2 = sotbv1[(nd + ii * sotbv1_dim2) * sotbv1_dim1] * (
2920 fpntab[jjp + ((ii << 1) - 1) * fpntab_dim1] -
2921 fpntab[jjm + ((ii << 1) - 1) * fpntab_dim1]) +
2922 sotbv2[(nd + ii * sotbv2_dim2) * sotbv2_dim1] * (
2923 fpntab[jjp + (ii << 1) * fpntab_dim1] - fpntab[
2924 jjm + (ii << 1) * fpntab_dim1]);
2925 diditb[jj + nd * diditb_dim2 * diditb_dim1] -= bid2;
2926 /* L650: */
2927 }
2928 /* L600: */
2929 }
2930 }
2931
2932 if (*nbpntu % 2 == 1 && *nbpntv % 2 == 1) {
2933 i__2 = *iordrv + 1;
2934 for (ii = 1; ii <= i__2; ++ii) {
2935 bid1 = sotbv1[(nd + ii * sotbv1_dim2) * sotbv1_dim1] * fpntab[
2936 nvroo + 1 + ((ii << 1) - 1) * fpntab_dim1] + sotbv2[(
2937 nd + ii * sotbv2_dim2) * sotbv2_dim1] * fpntab[nvroo
2938 + 1 + (ii << 1) * fpntab_dim1];
2939 sosotb[nd * sosotb_dim2 * sosotb_dim1] -= bid1;
2940 /* L700: */
2941 }
2942 }
2943
2944 /* L100: */
2945 }
2946 goto L9999;
2947
2948 /* ------------------------------ The End -------------------------------
2949 */
2950
2951 L9999:
2952 if (ibb >= 3) {
2953 AdvApp2Var_SysBase::mgsomsg_("MMA2CD2", 7L);
2954 }
2955 return 0;
2956 } /* mma2cd2_ */
2957
2958 //=======================================================================
2959 //function : mma2cd3_
2960 //purpose :
2961 //=======================================================================
mma2cd3_(integer * ndimen,integer * nbpntu,doublereal * urootl,integer * nbpntv,integer * iordru,doublereal * sotbu1,doublereal * sotbu2,doublereal * ditbu1,doublereal * ditbu2,doublereal * fpntab,doublereal * uhermt,doublereal * sosotb,doublereal * soditb,doublereal * disotb,doublereal * diditb)2962 int mma2cd3_(integer *ndimen,
2963 integer *nbpntu,
2964 doublereal *urootl,
2965 integer *nbpntv,
2966 integer *iordru,
2967 doublereal *sotbu1,
2968 doublereal *sotbu2,
2969 doublereal *ditbu1,
2970 doublereal *ditbu2,
2971 doublereal *fpntab,
2972 doublereal *uhermt,
2973 doublereal *sosotb,
2974 doublereal *soditb,
2975 doublereal *disotb,
2976 doublereal *diditb)
2977
2978 {
2979 integer c__1 = 1;
2980
2981 /* System generated locals */
2982 integer sotbu1_dim1, sotbu1_dim2, sotbu1_offset, sotbu2_dim1, sotbu2_dim2,
2983 sotbu2_offset, ditbu1_dim1, ditbu1_dim2, ditbu1_offset,
2984 ditbu2_dim1, ditbu2_dim2, ditbu2_offset, fpntab_dim1,
2985 fpntab_offset, uhermt_dim1, uhermt_offset, sosotb_dim1,
2986 sosotb_dim2, sosotb_offset, diditb_dim1, diditb_dim2,
2987 diditb_offset, soditb_dim1, soditb_dim2, soditb_offset,
2988 disotb_dim1, disotb_dim2, disotb_offset, i__1, i__2, i__3, i__4;
2989
2990 /* Local variables */
2991 integer ncfhu, nuroo, nvroo, ii, nd, jj, kk, ibb, kkm, kkp;
2992 doublereal bid1, bid2, bid3, bid4;
2993
2994 /* **********************************************************************
2995 */
2996 /* FUNCTION : */
2997 /* ---------- */
2998 /* Discretisation on the parameters of polynoms of interpolation */
2999 /* of constraints on 2 borders iso-U of order IORDRU. */
3000
3001
3002 /* KEYWORDS : */
3003 /* ----------- */
3004 /* TOUS, AB_SPECIFI::CONTRAINTE&, DISCRETISATION, &POINT */
3005
3006 /* INPUT ARGUMENTS : */
3007 /* ------------------ */
3008 /* NDIMEN: Dimension of the space. */
3009 /* NBPNTU: Nb of INTERNAL parameters of discretisation by U. */
3010 /* This is also the nb of root of Legendre polynom where discretization is done. */
3011 /* UROOTL: Table of parameters of discretisation ON (-1,1) by U.
3012 */
3013 /* NBPNTV: Nb of INTERNAL parameters of discretisation by V. */
3014 /* This is also the nb of root of Legendre polynom where discretization is done. */
3015 /* IORDRV: Order of constraint imposed at the extremities of iso-V */
3016 /* = 0, calculate the extremities of iso-V */
3017 /* = 1, calculate, additionally, the 1st derivative in the direction of iso-V */
3018 /* = 2, calculate, additionally, the 2nd derivative in the direction of iso-V */
3019 /* SOTBU1: Table of NBPNTU/2 sums of 2 index points */
3020 /* NBPNTU-II+1 and II, for II = 1, NBPNTU/2 on iso-V0. */
3021 /* SOTBU2: Table of NBPNTV/2 sums of 2 index points */
3022 /* NBPNTU-II+1 and II, for II = 1, NBPNTU/2 on iso-V1. */
3023 /* DITBU1: Table of NBPNTU/2 differences of 2 index points */
3024 /* NBPNTU-II+1 and II, for II = 1, NBPNTU/2 on iso-V0. */
3025 /* DITBU2: Table of NBPNTU/2 differences of 2 index points */
3026 /* NBPNTU-II+1 and II, for II = 1, NBPNTU/2 on iso-V1. */
3027 /* SOSOTB: Preinitialized table (input/output argument). */
3028 /* DISOTB: Preinitialized table (input/output argument). */
3029 /* SODITB: Preinitialized table (input/output argument). */
3030 /* DIDITB: Preinitialized table (input/output argument) */
3031
3032 /* OUTPUT ARGUMENTS : */
3033 /* ------------------- */
3034 /* FPNTAB: Auxiliary table. */
3035 /* UHERMT: Table of 2*(IORDRU+1) coeff. of 2*(IORDRU+1) polynoms of Hermite. */
3036 /* SOSOTB: Table where the terms of constraints are added */
3037 /* C(ui,vj) + C(ui,-vj) + C(-ui,vj) + C(-ui,-vj) */
3038 /* with ui and vj positive roots of the Legendre polynom */
3039 /* of degree NBPNTU and NBPNTV respectively. */
3040 /* DISOTB: Table where the terms of constraints are added */
3041 /* C(ui,vj) + C(ui,-vj) - C(-ui,vj) - C(-ui,-vj) */
3042 /* with ui and vj positive roots of the polynom of Legendre */
3043 /* of degree NBPNTU and NBPNTV respectively. */
3044 /* SODITB: Table where the terms of constraints are added */
3045 /* C(ui,vj) - C(ui,-vj) + C(-ui,vj) - C(-ui,-vj) */
3046 /* with ui and vj positive roots of the polynom of Legendre */
3047 /* of degree NBPNTU and NBPNTV respectively. */
3048 /* DIDITB: Table where the terms of constraints are added */
3049 /* C(ui,vj) - C(ui,-vj) - C(-ui,vj) + C(-ui,-vj) */
3050 /* with ui and vj positive roots of the polynom of Legendre */
3051 /* of degree NBPNTU and NBPNTV respectively. */
3052
3053 /* COMMONS USED : */
3054 /* ---------------- */
3055
3056 /* REFERENCES CALLED : */
3057 /* ----------------------- */
3058
3059 /* DESCRIPTION/NOTES/LIMITATIONS : */
3060 /* ----------------------------------- */
3061
3062 /* $ HISTORIQUE DES MODIFICATIONS : */
3063 /* -------------------------------- */
3064 /* 08-08-1991: RBD; Creation. */
3065 /* > */
3066 /* **********************************************************************
3067 */
3068
3069 /* Name of the routine */
3070
3071
3072 /* Parameter adjustments */
3073 --urootl;
3074 diditb_dim1 = *nbpntu / 2 + 1;
3075 diditb_dim2 = *nbpntv / 2 + 1;
3076 diditb_offset = diditb_dim1 * diditb_dim2;
3077 diditb -= diditb_offset;
3078 disotb_dim1 = *nbpntu / 2;
3079 disotb_dim2 = *nbpntv / 2;
3080 disotb_offset = disotb_dim1 * (disotb_dim2 + 1) + 1;
3081 disotb -= disotb_offset;
3082 soditb_dim1 = *nbpntu / 2;
3083 soditb_dim2 = *nbpntv / 2;
3084 soditb_offset = soditb_dim1 * (soditb_dim2 + 1) + 1;
3085 soditb -= soditb_offset;
3086 sosotb_dim1 = *nbpntu / 2 + 1;
3087 sosotb_dim2 = *nbpntv / 2 + 1;
3088 sosotb_offset = sosotb_dim1 * sosotb_dim2;
3089 sosotb -= sosotb_offset;
3090 uhermt_dim1 = (*iordru << 1) + 2;
3091 uhermt_offset = uhermt_dim1;
3092 uhermt -= uhermt_offset;
3093 fpntab_dim1 = *nbpntu;
3094 fpntab_offset = fpntab_dim1 + 1;
3095 fpntab -= fpntab_offset;
3096 ditbu2_dim1 = *nbpntv / 2 + 1;
3097 ditbu2_dim2 = *ndimen;
3098 ditbu2_offset = ditbu2_dim1 * (ditbu2_dim2 + 1);
3099 ditbu2 -= ditbu2_offset;
3100 ditbu1_dim1 = *nbpntv / 2 + 1;
3101 ditbu1_dim2 = *ndimen;
3102 ditbu1_offset = ditbu1_dim1 * (ditbu1_dim2 + 1);
3103 ditbu1 -= ditbu1_offset;
3104 sotbu2_dim1 = *nbpntv / 2 + 1;
3105 sotbu2_dim2 = *ndimen;
3106 sotbu2_offset = sotbu2_dim1 * (sotbu2_dim2 + 1);
3107 sotbu2 -= sotbu2_offset;
3108 sotbu1_dim1 = *nbpntv / 2 + 1;
3109 sotbu1_dim2 = *ndimen;
3110 sotbu1_offset = sotbu1_dim1 * (sotbu1_dim2 + 1);
3111 sotbu1 -= sotbu1_offset;
3112
3113 /* Function Body */
3114 ibb = AdvApp2Var_SysBase::mnfndeb_();
3115 if (ibb >= 3) {
3116 AdvApp2Var_SysBase::mgenmsg_("MMA2CD3", 7L);
3117 }
3118
3119 /* ------------------- Discretization of polynoms of Hermit -----------
3120 */
3121
3122 ncfhu = (*iordru + 1) << 1;
3123 i__1 = ncfhu;
3124 for (ii = 1; ii <= i__1; ++ii) {
3125 i__2 = *nbpntu;
3126 for (kk = 1; kk <= i__2; ++kk) {
3127 AdvApp2Var_MathBase::mmmpocur_(&ncfhu,
3128 &c__1,
3129 &ncfhu,
3130 &uhermt[ii * uhermt_dim1],
3131 &urootl[kk],
3132 &fpntab[kk + ii * fpntab_dim1]);
3133 /* L60: */
3134 }
3135 /* L50: */
3136 }
3137
3138 /* ---- The discretizations of polynoms of constraints are subtracted ----
3139 */
3140
3141 nvroo = *nbpntv / 2;
3142 nuroo = *nbpntu / 2;
3143
3144 i__1 = *ndimen;
3145 for (nd = 1; nd <= i__1; ++nd) {
3146 i__2 = *iordru + 1;
3147 for (ii = 1; ii <= i__2; ++ii) {
3148
3149 i__3 = nvroo;
3150 for (jj = 1; jj <= i__3; ++jj) {
3151 bid1 = sotbu1[jj + (nd + ii * sotbu1_dim2) * sotbu1_dim1];
3152 bid2 = sotbu2[jj + (nd + ii * sotbu2_dim2) * sotbu2_dim1];
3153 bid3 = ditbu1[jj + (nd + ii * ditbu1_dim2) * ditbu1_dim1];
3154 bid4 = ditbu2[jj + (nd + ii * ditbu2_dim2) * ditbu2_dim1];
3155 i__4 = nuroo;
3156 for (kk = 1; kk <= i__4; ++kk) {
3157 kkp = (*nbpntu + 1) / 2 + kk;
3158 kkm = nuroo - kk + 1;
3159 sosotb[kk + (jj + nd * sosotb_dim2) * sosotb_dim1] =
3160 sosotb[kk + (jj + nd * sosotb_dim2) * sosotb_dim1]
3161 - bid1 * (fpntab[kkp + ((ii << 1) - 1) *
3162 fpntab_dim1] + fpntab[kkm + ((ii << 1) - 1) *
3163 fpntab_dim1]) - bid2 * (fpntab[kkp + (ii << 1) *
3164 fpntab_dim1] + fpntab[kkm + (ii << 1) *
3165 fpntab_dim1]);
3166 disotb[kk + (jj + nd * disotb_dim2) * disotb_dim1] =
3167 disotb[kk + (jj + nd * disotb_dim2) * disotb_dim1]
3168 - bid1 * (fpntab[kkp + ((ii << 1) - 1) *
3169 fpntab_dim1] - fpntab[kkm + ((ii << 1) - 1) *
3170 fpntab_dim1]) - bid2 * (fpntab[kkp + (ii << 1) *
3171 fpntab_dim1] - fpntab[kkm + (ii << 1) *
3172 fpntab_dim1]);
3173 soditb[kk + (jj + nd * soditb_dim2) * soditb_dim1] =
3174 soditb[kk + (jj + nd * soditb_dim2) * soditb_dim1]
3175 - bid3 * (fpntab[kkp + ((ii << 1) - 1) *
3176 fpntab_dim1] + fpntab[kkm + ((ii << 1) - 1) *
3177 fpntab_dim1]) - bid4 * (fpntab[kkp + (ii << 1) *
3178 fpntab_dim1] + fpntab[kkm + (ii << 1) *
3179 fpntab_dim1]);
3180 diditb[kk + (jj + nd * diditb_dim2) * diditb_dim1] =
3181 diditb[kk + (jj + nd * diditb_dim2) * diditb_dim1]
3182 - bid3 * (fpntab[kkp + ((ii << 1) - 1) *
3183 fpntab_dim1] - fpntab[kkm + ((ii << 1) - 1) *
3184 fpntab_dim1]) - bid4 * (fpntab[kkp + (ii << 1) *
3185 fpntab_dim1] - fpntab[kkm + (ii << 1) *
3186 fpntab_dim1]);
3187 /* L400: */
3188 }
3189 /* L300: */
3190 }
3191 /* L200: */
3192 }
3193
3194 /* ------------ Case when the discretization is done only on the roots */
3195 /* ---------- of Legendre polynom of uneven degree, 0 is root */
3196
3197
3198
3199 if (*nbpntu % 2 == 1) {
3200 i__2 = *iordru + 1;
3201 for (ii = 1; ii <= i__2; ++ii) {
3202 i__3 = nvroo;
3203 for (jj = 1; jj <= i__3; ++jj) {
3204 bid1 = sotbu1[jj + (nd + ii * sotbu1_dim2) * sotbu1_dim1]
3205 * fpntab[nuroo + 1 + ((ii << 1) - 1) *
3206 fpntab_dim1] + sotbu2[jj + (nd + ii * sotbu2_dim2)
3207 * sotbu2_dim1] * fpntab[nuroo + 1 + (ii << 1) *
3208 fpntab_dim1];
3209 sosotb[(jj + nd * sosotb_dim2) * sosotb_dim1] -= bid1;
3210 bid2 = ditbu1[jj + (nd + ii * ditbu1_dim2) * ditbu1_dim1]
3211 * fpntab[nuroo + 1 + ((ii << 1) - 1) *
3212 fpntab_dim1] + ditbu2[jj + (nd + ii * ditbu2_dim2)
3213 * ditbu2_dim1] * fpntab[nuroo + 1 + (ii << 1) *
3214 fpntab_dim1];
3215 diditb[(jj + nd * diditb_dim2) * diditb_dim1] -= bid2;
3216 /* L550: */
3217 }
3218 /* L500: */
3219 }
3220 }
3221
3222 if (*nbpntv % 2 == 1) {
3223 i__2 = *iordru + 1;
3224 for (ii = 1; ii <= i__2; ++ii) {
3225 i__3 = nuroo;
3226 for (kk = 1; kk <= i__3; ++kk) {
3227 kkp = (*nbpntu + 1) / 2 + kk;
3228 kkm = nuroo - kk + 1;
3229 bid1 = sotbu1[(nd + ii * sotbu1_dim2) * sotbu1_dim1] * (
3230 fpntab[kkp + ((ii << 1) - 1) * fpntab_dim1] +
3231 fpntab[kkm + ((ii << 1) - 1) * fpntab_dim1]) +
3232 sotbu2[(nd + ii * sotbu2_dim2) * sotbu2_dim1] * (
3233 fpntab[kkp + (ii << 1) * fpntab_dim1] + fpntab[
3234 kkm + (ii << 1) * fpntab_dim1]);
3235 sosotb[kk + nd * sosotb_dim2 * sosotb_dim1] -= bid1;
3236 bid2 = sotbu1[(nd + ii * sotbu1_dim2) * sotbu1_dim1] * (
3237 fpntab[kkp + ((ii << 1) - 1) * fpntab_dim1] -
3238 fpntab[kkm + ((ii << 1) - 1) * fpntab_dim1]) +
3239 sotbu2[(nd + ii * sotbu2_dim2) * sotbu2_dim1] * (
3240 fpntab[kkp + (ii << 1) * fpntab_dim1] - fpntab[
3241 kkm + (ii << 1) * fpntab_dim1]);
3242 diditb[kk + nd * diditb_dim2 * diditb_dim1] -= bid2;
3243 /* L650: */
3244 }
3245 /* L600: */
3246 }
3247 }
3248
3249 if (*nbpntu % 2 == 1 && *nbpntv % 2 == 1) {
3250 i__2 = *iordru + 1;
3251 for (ii = 1; ii <= i__2; ++ii) {
3252 bid1 = sotbu1[(nd + ii * sotbu1_dim2) * sotbu1_dim1] * fpntab[
3253 nuroo + 1 + ((ii << 1) - 1) * fpntab_dim1] + sotbu2[(
3254 nd + ii * sotbu2_dim2) * sotbu2_dim1] * fpntab[nuroo
3255 + 1 + (ii << 1) * fpntab_dim1];
3256 sosotb[nd * sosotb_dim2 * sosotb_dim1] -= bid1;
3257 /* L700: */
3258 }
3259 }
3260
3261 /* L100: */
3262 }
3263 goto L9999;
3264
3265 /* ------------------------------ The End -------------------------------
3266 */
3267
3268 L9999:
3269 if (ibb >= 3) {
3270 AdvApp2Var_SysBase::mgsomsg_("MMA2CD3", 7L);
3271 }
3272 return 0;
3273 } /* mma2cd3_ */
3274
3275 //=======================================================================
3276 //function : mma2cdi_
3277 //purpose :
3278 //=======================================================================
mma2cdi_(integer * ndimen,integer * nbpntu,doublereal * urootl,integer * nbpntv,doublereal * vrootl,integer * iordru,integer * iordrv,doublereal * contr1,doublereal * contr2,doublereal * contr3,doublereal * contr4,doublereal * sotbu1,doublereal * sotbu2,doublereal * ditbu1,doublereal * ditbu2,doublereal * sotbv1,doublereal * sotbv2,doublereal * ditbv1,doublereal * ditbv2,doublereal * sosotb,doublereal * soditb,doublereal * disotb,doublereal * diditb,integer * iercod)3279 int AdvApp2Var_ApproxF2var::mma2cdi_( integer *ndimen,
3280 integer *nbpntu,
3281 doublereal *urootl,
3282 integer *nbpntv,
3283 doublereal *vrootl,
3284 integer *iordru,
3285 integer *iordrv,
3286 doublereal *contr1,
3287 doublereal *contr2,
3288 doublereal *contr3,
3289 doublereal *contr4,
3290 doublereal *sotbu1,
3291 doublereal *sotbu2,
3292 doublereal *ditbu1,
3293 doublereal *ditbu2,
3294 doublereal *sotbv1,
3295 doublereal *sotbv2,
3296 doublereal *ditbv1,
3297 doublereal *ditbv2,
3298 doublereal *sosotb,
3299 doublereal *soditb,
3300 doublereal *disotb,
3301 doublereal *diditb,
3302 integer *iercod)
3303
3304 {
3305 integer c__8 = 8;
3306
3307 /* System generated locals */
3308 integer contr1_dim1, contr1_dim2, contr1_offset, contr2_dim1, contr2_dim2,
3309 contr2_offset, contr3_dim1, contr3_dim2, contr3_offset,
3310 contr4_dim1, contr4_dim2, contr4_offset, sosotb_dim1, sosotb_dim2,
3311 sosotb_offset, diditb_dim1, diditb_dim2, diditb_offset,
3312 soditb_dim1, soditb_dim2, soditb_offset, disotb_dim1, disotb_dim2,
3313 disotb_offset;
3314
3315 /* Local variables */
3316 integer ilong;
3317 intptr_t iofwr;
3318 doublereal* wrkar = 0;
3319 doublereal* wrkar_off;
3320 integer iszwr;
3321 integer ibb, ier = 0;
3322 integer isz1, isz2, isz3, isz4;
3323 intptr_t ipt1, ipt2, ipt3;
3324
3325
3326
3327
3328 /* **********************************************************************
3329 */
3330
3331 /* FUNCTION : */
3332 /* ---------- */
3333 /* Discretisation on the parameters of polynomes of interpolation */
3334 /* of constraints of order IORDRE. */
3335
3336 /* KEYWORDS : */
3337 /* ----------- */
3338 /* TOUS, AB_SPECIFI::CONTRAINTE&, DISCRETISATION, &POINT */
3339
3340 //* INPUT ARGUMENTS : */
3341 /* ------------------ */
3342 /* NDIMEN: Dimension of the space. */
3343 /* NBPNTU: Nb of INTERNAL parameters of discretisation by U. */
3344 /* This is also the nb of root of Legendre polynom where discretization is done. */
3345 /* UROOTL: Table of parameters of discretisation ON (-1,1) by U.
3346 */
3347 /* NBPNTV: Nb of INTERNAL parameters of discretisation by V. */
3348 /* This is also the nb of root of Legendre polynom where discretization is done. */
3349 /* VROOTL: Table of parameters of discretisation ON (-1,1) by V.*/
3350
3351 /* IORDRV: Order of constraint imposed at the extremities of iso-U */
3352 /* = 0, calculate the extremities of iso-U */
3353 /* = 1, calculate, additionally, the 1st derivative in the direction of iso-U */
3354 /* = 2, calculate, additionally, the 2nd derivative in the direction of iso-U */
3355 /* IORDRU: Order of constraint imposed at the extremities of iso-V */
3356 /* = 0, calculate the extremities of iso-V */
3357 /* = 1, calculate, additionally, the 1st derivative in the direction of iso-V */
3358 /* = 2, calculate, additionally, the 2nd derivative in the direction of iso-V */
3359 /* CONTR1: Contains, if IORDRU and IORDRV>=0, the values at the */
3360 /* extremities of F(U0,V0) and its derivatives. */
3361 /* CONTR2: Contains, if IORDRU and IORDRV>=0, the values at the */
3362 /* extremities of F(U1,V0) and its derivatives. */
3363 /* CONTR3: Contains, if IORDRU and IORDRV>=0, the values at the */
3364 /* extremities of F(U0,V1) and its derivatives. */
3365 /* CONTR4: Contains, if IORDRU and IORDRV>=0, the values at the */
3366 /* extremities of F(U1,V1) and its derivatives. */
3367 /* SOTBU1: Table of NBPNTU/2 sums of 2 index points */
3368 /* NBPNTU-II+1 and II, for II = 1, NBPNTU/2 on iso-V0. */
3369 /* SOTBU2: Table of NBPNTV/2 sums of 2 index points */
3370 /* NBPNTU-II+1 and II, for II = 1, NBPNTU/2 on iso-V1. */
3371 /* DITBU1: Table of NBPNTU/2 differences of 2 index points */
3372 /* NBPNTU-II+1 and II, for II = 1, NBPNTU/2 on iso-V0. */
3373 /* DITBU2: Table of NBPNTU/2 differences of 2 index points */
3374 /* NBPNTU-II+1 and II, for II = 1, NBPNTU/2 on iso-V1. */
3375 /* SOTBV1: Table of NBPNTV/2 sums of 2 index points */
3376 /* NBPNTV-II+1 and II, for II = 1, NBPNTV/2 on iso-V0. */
3377 /* SOTBV2: Table of NBPNTV/2 sums of 2 index points */
3378 /* NBPNTV-II+1 and II, for II = 1, NBPNTV/2 on iso-V1. */
3379 /* DITBV1: Table of NBPNTV/2 differences of 2 index points */
3380 /* NBPNTV-II+1 and II, for II = 1, NBPNTV/2 on iso-V0. */
3381 /* DITBV2: Table of NBPNTV/2 differences of 2 index points */
3382 /* NBPNTV-II+1 and II, for II = 1, NBPNTV/2 on iso-V1. */
3383 /* SOSOTB: Preinitialized table (input/output argument). */
3384 /* DISOTB: Preinitialized table (input/output argument). */
3385 /* SODITB: Preinitialized table (input/output argument). */
3386 /* DIDITB: Preinitialized table (input/output argument) */
3387
3388 /* ARGUMENTS DE SORTIE : */
3389 /* ------------------- */
3390 /* SOSOTB: Table where the terms of constraints are added */
3391 /* C(ui,vj) + C(ui,-vj) + C(-ui,vj) + C(-ui,-vj) */
3392 /* with ui and vj positive roots of the Legendre polynom */
3393 /* of degree NBPNTU and NBPNTV respectively. */
3394 /* DISOTB: Table where the terms of constraints are added */
3395 /* C(ui,vj) + C(ui,-vj) - C(-ui,vj) - C(-ui,-vj) */
3396 /* with ui and vj positive roots of the polynom of Legendre */
3397 /* of degree NBPNTU and NBPNTV respectively. */
3398 /* SODITB: Table where the terms of constraints are added */
3399 /* C(ui,vj) - C(ui,-vj) + C(-ui,vj) - C(-ui,-vj) */
3400 /* with ui and vj positive roots of the polynom of Legendre */
3401 /* of degree NBPNTU and NBPNTV respectively. */
3402 /* DIDITB: Table where the terms of constraints are added */
3403 /* C(ui,vj) - C(ui,-vj) - C(-ui,vj) + C(-ui,-vj) */
3404 /* with ui and vj positive roots of the polynom of Legendre */
3405 /* of degree NBPNTU and NBPNTV respectively. */
3406 /* IERCOD: = 0, OK, */
3407 /* = 1, Value or IORDRV or IORDRU is out of allowed values. */
3408 /* =13, Pb of dynamic allocation. */
3409
3410 /* COMMONS USED : */
3411 /* ---------------- */
3412
3413 /* REFERENCES CALLED : */
3414 /* -------------------- */
3415
3416 /* DESCRIPTION/NOTES/LIMITATIONS : */
3417 /* ------------------------------- */
3418
3419 /* > */
3420 /* **********************************************************************
3421 */
3422
3423 /* The name of the routine */
3424
3425
3426 /* Parameter adjustments */
3427 --urootl;
3428 diditb_dim1 = *nbpntu / 2 + 1;
3429 diditb_dim2 = *nbpntv / 2 + 1;
3430 diditb_offset = diditb_dim1 * diditb_dim2;
3431 diditb -= diditb_offset;
3432 disotb_dim1 = *nbpntu / 2;
3433 disotb_dim2 = *nbpntv / 2;
3434 disotb_offset = disotb_dim1 * (disotb_dim2 + 1) + 1;
3435 disotb -= disotb_offset;
3436 soditb_dim1 = *nbpntu / 2;
3437 soditb_dim2 = *nbpntv / 2;
3438 soditb_offset = soditb_dim1 * (soditb_dim2 + 1) + 1;
3439 soditb -= soditb_offset;
3440 sosotb_dim1 = *nbpntu / 2 + 1;
3441 sosotb_dim2 = *nbpntv / 2 + 1;
3442 sosotb_offset = sosotb_dim1 * sosotb_dim2;
3443 sosotb -= sosotb_offset;
3444 --vrootl;
3445 contr4_dim1 = *ndimen;
3446 contr4_dim2 = *iordru + 2;
3447 contr4_offset = contr4_dim1 * (contr4_dim2 + 1) + 1;
3448 contr4 -= contr4_offset;
3449 contr3_dim1 = *ndimen;
3450 contr3_dim2 = *iordru + 2;
3451 contr3_offset = contr3_dim1 * (contr3_dim2 + 1) + 1;
3452 contr3 -= contr3_offset;
3453 contr2_dim1 = *ndimen;
3454 contr2_dim2 = *iordru + 2;
3455 contr2_offset = contr2_dim1 * (contr2_dim2 + 1) + 1;
3456 contr2 -= contr2_offset;
3457 contr1_dim1 = *ndimen;
3458 contr1_dim2 = *iordru + 2;
3459 contr1_offset = contr1_dim1 * (contr1_dim2 + 1) + 1;
3460 contr1 -= contr1_offset;
3461 --sotbu1;
3462 --sotbu2;
3463 --ditbu1;
3464 --ditbu2;
3465 --sotbv1;
3466 --sotbv2;
3467 --ditbv1;
3468 --ditbv2;
3469 AdvApp2Var_SysBase anAdvApp2Var_SysBase;
3470
3471 /* Function Body */
3472 ibb = AdvApp2Var_SysBase::mnfndeb_();
3473 if (ibb >= 3) {
3474 AdvApp2Var_SysBase::mgenmsg_("MMA2CDI", 7L);
3475 }
3476 *iercod = 0;
3477 iofwr = 0;
3478 if (*iordru < -1 || *iordru > 2) {
3479 goto L9100;
3480 }
3481 if (*iordrv < -1 || *iordrv > 2) {
3482 goto L9100;
3483 }
3484
3485 /* ------------------------- Set to zero --------------------------------
3486 */
3487
3488 ilong = (*nbpntu / 2 + 1) * (*nbpntv / 2 + 1) * *ndimen;
3489 AdvApp2Var_SysBase::mvriraz_(&ilong, &sosotb[sosotb_offset]);
3490 AdvApp2Var_SysBase::mvriraz_(&ilong, &diditb[diditb_offset]);
3491 ilong = *nbpntu / 2 * (*nbpntv / 2) * *ndimen;
3492 AdvApp2Var_SysBase::mvriraz_(&ilong, &soditb[soditb_offset]);
3493 AdvApp2Var_SysBase::mvriraz_(&ilong, &disotb[disotb_offset]);
3494 if (*iordru == -1 && *iordrv == -1) {
3495 goto L9999;
3496 }
3497
3498
3499
3500 isz1 = ((*iordru + 1) << 2) * (*iordru + 1);
3501 isz2 = ((*iordrv + 1) << 2) * (*iordrv + 1);
3502 isz3 = ((*iordru + 1) << 1) * *nbpntu;
3503 isz4 = ((*iordrv + 1) << 1) * *nbpntv;
3504 iszwr = isz1 + isz2 + isz3 + isz4;
3505 anAdvApp2Var_SysBase.mcrrqst_(&c__8, &iszwr, wrkar, &iofwr, &ier);
3506 if (ier > 0) {
3507 goto L9013;
3508 }
3509 wrkar_off = reinterpret_cast<double*>(iofwr * sizeof(double));
3510 ipt1 = isz1;
3511 ipt2 = ipt1 + isz2;
3512 ipt3 = ipt2 + isz3;
3513
3514 if (*iordru >= 0 && *iordru <= 2) {
3515
3516 /* --- Return 2*(IORDRU+1) coeff of 2*(IORDRU+1) polynoms of Hermite
3517 --- */
3518
3519 AdvApp2Var_ApproxF2var::mma1her_(iordru, wrkar_off, iercod);
3520 if (*iercod > 0) {
3521 goto L9100;
3522 }
3523
3524 /* ---- Subract discretizations of polynoms of constraints
3525 ---- */
3526
3527 mma2cd3_(ndimen, nbpntu, &urootl[1], nbpntv, iordru, &sotbu1[1],
3528 &sotbu2[1], &ditbu1[1], &ditbu2[1], &wrkar_off[ipt2], wrkar_off,
3529 &sosotb[sosotb_offset], &soditb[soditb_offset],
3530 &disotb[disotb_offset], &diditb[diditb_offset]);
3531 }
3532
3533 if (*iordrv >= 0 && *iordrv <= 2) {
3534
3535 /* --- Return 2*(IORDRV+1) coeff of 2*(IORDRV+1) polynoms of Hermite
3536 --- */
3537
3538 AdvApp2Var_ApproxF2var::mma1her_(iordrv, &wrkar_off[ipt1], iercod);
3539 if (*iercod > 0) {
3540 goto L9100;
3541 }
3542
3543 /* ---- Subtract discretisations of polynoms of constraint
3544 ---- */
3545
3546 mma2cd2_(ndimen, nbpntu, nbpntv, &vrootl[1], iordrv, &sotbv1[1],
3547 &sotbv2[1], &ditbv1[1], &ditbv2[1], &wrkar_off[ipt3], &wrkar_off[ipt1],
3548 &sosotb[sosotb_offset], &soditb[soditb_offset],
3549 &disotb[disotb_offset], &diditb[diditb_offset]);
3550 }
3551
3552 /* --------------- Subtract constraints of corners ----------------
3553 */
3554
3555 if (*iordru >= 0 && *iordrv >= 0) {
3556 mma2cd1_(ndimen, nbpntu, &urootl[1], nbpntv, &vrootl[1], iordru,
3557 iordrv, &contr1[contr1_offset], &contr2[contr2_offset],
3558 &contr3[contr3_offset], &contr4[contr4_offset], &wrkar_off[ipt2],
3559 &wrkar_off[ipt3], wrkar_off, &wrkar_off[ipt1],
3560 &sosotb[sosotb_offset], &soditb[soditb_offset],
3561 &disotb[disotb_offset], &diditb[diditb_offset]);
3562 }
3563 goto L9999;
3564
3565 /* ------------------------------ The End -------------------------------
3566 */
3567 /* --> IORDRE is not within the autorised diapason. */
3568 L9100:
3569 *iercod = 1;
3570 goto L9999;
3571 /* --> PB of dynamic allocation. */
3572 L9013:
3573 *iercod = 13;
3574 goto L9999;
3575
3576 L9999:
3577 if (iofwr != 0) {
3578 anAdvApp2Var_SysBase.mcrdelt_(&c__8, &iszwr, wrkar, &iofwr, &ier);
3579 }
3580 if (ier > 0) {
3581 *iercod = 13;
3582 }
3583 AdvApp2Var_SysBase::maermsg_("MMA2CDI", iercod, 7L);
3584 if (ibb >= 3) {
3585 AdvApp2Var_SysBase::mgsomsg_("MMA2CDI", 7L);
3586 }
3587 return 0;
3588 } /* mma2cdi_ */
3589
3590 //=======================================================================
3591 //function : mma2ce1_
3592 //purpose :
3593 //=======================================================================
mma2ce1_(integer * numdec,integer * ndimen,integer * nbsesp,integer * ndimse,integer * ndminu,integer * ndminv,integer * ndguli,integer * ndgvli,integer * ndjacu,integer * ndjacv,integer * iordru,integer * iordrv,integer * nbpntu,integer * nbpntv,doublereal * epsapr,doublereal * sosotb,doublereal * disotb,doublereal * soditb,doublereal * diditb,doublereal * patjac,doublereal * errmax,doublereal * errmoy,integer * ndegpu,integer * ndegpv,integer * itydec,integer * iercod)3594 int AdvApp2Var_ApproxF2var::mma2ce1_(integer *numdec,
3595 integer *ndimen,
3596 integer *nbsesp,
3597 integer *ndimse,
3598 integer *ndminu,
3599 integer *ndminv,
3600 integer *ndguli,
3601 integer *ndgvli,
3602 integer *ndjacu,
3603 integer *ndjacv,
3604 integer *iordru,
3605 integer *iordrv,
3606 integer *nbpntu,
3607 integer *nbpntv,
3608 doublereal *epsapr,
3609 doublereal *sosotb,
3610 doublereal *disotb,
3611 doublereal *soditb,
3612 doublereal *diditb,
3613 doublereal *patjac,
3614 doublereal *errmax,
3615 doublereal *errmoy,
3616 integer *ndegpu,
3617 integer *ndegpv,
3618 integer *itydec,
3619 integer *iercod)
3620
3621 {
3622 integer c__8 = 8;
3623
3624 /* System generated locals */
3625 integer sosotb_dim1, sosotb_dim2, sosotb_offset, disotb_dim1, disotb_dim2,
3626 disotb_offset, soditb_dim1, soditb_dim2, soditb_offset,
3627 diditb_dim1, diditb_dim2, diditb_offset, patjac_dim1, patjac_dim2,
3628 patjac_offset;
3629
3630 /* Local variables */
3631 logical ldbg;
3632 intptr_t iofwr;
3633 doublereal* wrkar = 0;
3634 doublereal* wrkar_off;
3635 integer iszwr;
3636 integer ier;
3637 integer isz1, isz2, isz3, isz4, isz5, isz6, isz7;
3638 intptr_t ipt1, ipt2, ipt3, ipt4, ipt5, ipt6;
3639
3640
3641
3642 /* **********************************************************************
3643 */
3644
3645 /* FUNCTION : */
3646 /* ---------- */
3647 /* Calculation of coefficients of polynomial approximation of degree */
3648 /* (NDJACU,NDJACV) of a function F(u,v), starting from its */
3649 /* discretization on roots of Legendre polynom of degree */
3650 /* NBPNTU by U and NBPNTV by V. */
3651
3652 /* KEYWORDS : */
3653 /* ----------- */
3654 /* TOUS,AB_SPECIFI::FONCTION&,APPROXIMATION,&POLYNOME,&ERREUR */
3655
3656 /* INPUT ARGUMENTS : */
3657 /* ------------------ */
3658 /* NUMDEC: Indicates if it is POSSIBLE to cut function F(u,v). */
3659 /* = 5, It is POSSIBLE to cut by U or by V or in both directions simultaneously. */
3660 /* = 4, It is POSSIBLE to cut by U or by V BUT NOT in both */
3661 /* directions simultaneously (cutting by V is preferable). */
3662 /* = 3, It is POSSIBLE to cut by U or by V BUT NOT in both */
3663 /* directions simultaneously (cutting by U is preferable). */
3664 /* = 2, It is POSSIBLE to cut only by V (i.e. insert parameter */
3665 /* of cutting Vj). */
3666 /* = 1, It is POSSIBLE to cut only by U (i.e. insert parameter */
3667 /* of cutting Ui). */
3668 /* = 0, It is not POSSIBLE to cut anything */
3669 /* NDIMEN: Dimension of the space. */
3670 /* NBSESP: Nb of independent sub-spaces on which the errors are calculated. */
3671 /* NDIMSE: Table of dimensions of each of sub-spaces. */
3672 /* NDMINU: Minimum degree by U to be preserved for the approximation. */
3673 /* NDMINV: Minimum degree by V to be preserved for the approximation. */
3674 /* NDGULI: Limit of nb of coefficients by U of the solution. */
3675 /* NDGVLI: Limit of nb of coefficients by V of the solution. */
3676 /* NDJACU: Max degree of the polynom of approximation by U. */
3677 /* The representation in the orthogonal base starts from degree */
3678 /* 0 to degree NDJACU-2*(IORDRU+1). The polynomial base is the base of */
3679 /* Jacobi of order -1 (Legendre), 0, 1 or 2. */
3680 /* It is required that 2*IORDRU+1 <= NDMINU <= NDGULI < NDJACU */
3681 /* NDJACV: Max degree of the polynom of approximation by V. */
3682 /* The representation in the orthogonal base starts from degree */
3683 /* 0 to degree NDJACV-2*(IORDRV+1). The polynomial base is */
3684 /* the base of Jacobi of order -1 (Legendre), 0, 1 or 2 */
3685 /* It is required that 2*IORDRV+1 <= NDMINV <= NDGVLI < NDJACV */
3686 /* IORDRU: Order of the Jacobi base (-1,0,1 or 2) by U. Corresponds */
3687 /* to the step of constraints C0, C1 or C2. */
3688 /* IORDRV: Order of the Jacobi base (-1,0,1 or 2) by U. Corresponds */
3689 /* to the step of constraints C0, C1 or C2. */
3690 /* NBPNTU: Degree of Legendre polynom on the roots which of are */
3691 /* calculated the coefficients of integration by u */
3692 /* by Gauss method. It is required that NBPNTU = 30, 40, */
3693 /* 50 or 61 and NDJACU-2*(IORDRU+1) < NBPNTU. */
3694 /* NBPNTV: Degree of Legendre polynom on the roots which of are */
3695 /* calculated the coefficients of integration by u */
3696 /* by Gauss method. It is required that NBPNTV = 30, 40, */
3697 /* 50 or 61 and NDJACV-2*(IORDRV+1) < NBPNTV. */
3698 /* EPSAPR: Table of NBSESP tolerances imposed on each sub-spaces. */
3699 /* SOSOTB: Table of F(ui,vj) + F(ui,-vj) + F(-ui,vj) + F(-ui,-vj) */
3700 /* with ui and vj - positive roots of the Legendre polynom */
3701 /* of degree NBPNTU and NBPNTV respectively. Additionally, */
3702 /* table SOSOTB(0,j) contains F(0,vj) + F(0,-vj), */
3703 /* table SOSOTB(i,0) contains F(ui,0) + F(-ui,0) and */
3704 /* SOSOTB(0,0) contains F(0,0). */
3705 /* DISOTB: Table of F(ui,vj) + F(ui,-vj) - F(-ui,vj) - F(-ui,-vj) */
3706 /* with ui and vj positive roots of Legendre polynom */
3707 /* of degree NBPNTU and NBPNTV respectively. */
3708 /* SODITB: Table of F(ui,vj) - F(ui,-vj) + F(-ui,vj) - F(-ui,-vj) */
3709 /* with ui and vj positive roots of Legendre polynom */
3710 /* of degree NBPNTU and NBPNTV respectively. */
3711 /* DIDITB: Table of F(ui,vj) - F(ui,-vj) - F(-ui,vj) + F(-ui,-vj) */
3712 /* with ui and vj positive roots of Legendre polynom */
3713 /* of degree NBPNTU and NBPNTV respectively. Additionally, */
3714 /* table DIDITB(0,j) contains F(0,vj) - F(0,-vj), */
3715 /* and table DIDITB(i,0) contains F(ui,0) - F(-ui,0). */
3716
3717 /* OUTPUT ARGUMENTS */
3718 /* --------------- */
3719 /* PATJAC: Table of coefficients of polynom P(u,v) of approximation */
3720 /* of F(u,v) with eventually taking into account of */
3721 /* constraints. P(u,v) is of degree (NDJACU,NDJACV). */
3722 /* This table contains other coeff if ITYDEC = 0. */
3723 /* ERRMAX: For 1<=i<=NBSESP, ERRMAX(i) contains max errors */
3724 /* on each of sub-spaces SI ITYDEC = 0. */
3725 /* ERRMOY: Contains average errors for each of NBSESP sub-spaces SI ITYDEC = 0. */
3726 /* NDEGPU: Degree by U for square PATJAC. Valable if ITYDEC=0. */
3727 /* NDEGPV: Degree by V for square PATJAC. Valable if ITYDEC=0. */
3728 /* ITYDEC: Shows if it is NECESSARY to cut again function F(u,v). */
3729 /* = 0, it is not NECESSARY to cut anything, PATJAC is OK. */
3730 /* = 1, it is NECESSARY to cut only by U (i.e. insert parameter of cutting Ui). */
3731 /* = 2, it is NECESSARY to cut only by V (i.e. insert parameter of cutting Vj). */
3732 /* = 3, it is NECESSARY to cut both by U AND by V. */
3733 /* IERCOD: Error code. */
3734 /* = 0, Everything is OK. */
3735 /* = -1, There is the best possible solution, but the */
3736 /* user tolerance is not satisfactory (3*only) */
3737 /* = 1, Incoherent entries. */
3738
3739 /* COMMONS USED : */
3740 /* ---------------- */
3741
3742 /* REFERENCES CALLED : */
3743 /* --------------------- */
3744
3745 /* DESCRIPTION/NOTES/LIMITATIONS : */
3746 /* ------------------------------- */
3747
3748 /* > */
3749 /* **********************************************************************
3750 */
3751 /* Name of the routine */
3752
3753
3754 /* --------------------------- Initialisations --------------------------
3755 */
3756
3757 /* Parameter adjustments */
3758 --errmoy;
3759 --errmax;
3760 --epsapr;
3761 --ndimse;
3762 patjac_dim1 = *ndjacu + 1;
3763 patjac_dim2 = *ndjacv + 1;
3764 patjac_offset = patjac_dim1 * patjac_dim2;
3765 patjac -= patjac_offset;
3766 diditb_dim1 = *nbpntu / 2 + 1;
3767 diditb_dim2 = *nbpntv / 2 + 1;
3768 diditb_offset = diditb_dim1 * diditb_dim2;
3769 diditb -= diditb_offset;
3770 soditb_dim1 = *nbpntu / 2;
3771 soditb_dim2 = *nbpntv / 2;
3772 soditb_offset = soditb_dim1 * (soditb_dim2 + 1) + 1;
3773 soditb -= soditb_offset;
3774 disotb_dim1 = *nbpntu / 2;
3775 disotb_dim2 = *nbpntv / 2;
3776 disotb_offset = disotb_dim1 * (disotb_dim2 + 1) + 1;
3777 disotb -= disotb_offset;
3778 sosotb_dim1 = *nbpntu / 2 + 1;
3779 sosotb_dim2 = *nbpntv / 2 + 1;
3780 sosotb_offset = sosotb_dim1 * sosotb_dim2;
3781 sosotb -= sosotb_offset;
3782
3783 /* Function Body */
3784 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
3785 if (ldbg) {
3786 AdvApp2Var_SysBase::mgenmsg_("MMA2CE1", 7L);
3787 }
3788 *iercod = 0;
3789 iofwr = 0;
3790
3791 isz1 = (*nbpntu / 2 + 1) * (*ndjacu - ((*iordru + 1) << 1) + 1);
3792 isz2 = (*nbpntv / 2 + 1) * (*ndjacv - ((*iordrv + 1) << 1) + 1);
3793 isz3 = (*nbpntv / 2 + 1) * (*ndjacu - ((*iordru + 1) << 1) + 1) * *ndimen;
3794 isz4 = *nbpntv / 2 * (*ndjacu - ((*iordru + 1) << 1) + 1) * *ndimen;
3795 isz5 = *ndjacu + 1 - ((*iordru + 1) << 1);
3796 isz6 = *ndjacv + 1 - ((*iordrv + 1) << 1);
3797 isz7 = *ndimen << 2;
3798 iszwr = isz1 + isz2 + isz3 + isz4 + isz5 + isz6 + isz7;
3799 AdvApp2Var_SysBase anAdvApp2Var_SysBase;
3800 anAdvApp2Var_SysBase.mcrrqst_(&c__8, &iszwr, wrkar, &iofwr, &ier);
3801 wrkar_off = reinterpret_cast<double*> (iofwr * sizeof(double));
3802 if (ier > 0) {
3803 goto L9013;
3804 }
3805 ipt1 = isz1;
3806 ipt2 = ipt1 + isz2;
3807 ipt3 = ipt2 + isz3;
3808 ipt4 = ipt3 + isz4;
3809 ipt5 = ipt4 + isz5;
3810 ipt6 = ipt5 + isz6;
3811
3812 /* ----------------- Return Gauss coefficients of integration ----------------
3813 */
3814
3815 AdvApp2Var_ApproxF2var::mmapptt_(ndjacu, nbpntu, iordru, wrkar_off, iercod);
3816 if (*iercod > 0) {
3817 goto L9999;
3818 }
3819 AdvApp2Var_ApproxF2var::mmapptt_(ndjacv, nbpntv, iordrv, &wrkar_off[ipt1], iercod);
3820 if (*iercod > 0) {
3821 goto L9999;
3822 }
3823
3824 /* ------------------- Return max polynoms of Jacobi ------------
3825 */
3826
3827 AdvApp2Var_ApproxF2var::mma2jmx_(ndjacu, iordru, &wrkar_off[ipt5]);
3828 AdvApp2Var_ApproxF2var::mma2jmx_(ndjacv, iordrv, &wrkar_off[ipt5]);
3829
3830 /* ------ Calculate the coefficients and their contribution to the error ----
3831 */
3832
3833 mma2ce2_(numdec, ndimen, nbsesp, &ndimse[1], ndminu, ndminv, ndguli,
3834 ndgvli, ndjacu, ndjacv, iordru, iordrv, nbpntu, nbpntv, &epsapr[1],
3835 &sosotb[sosotb_offset], &disotb[disotb_offset], &soditb[soditb_offset],
3836 &diditb[diditb_offset], wrkar_off, &wrkar_off[ipt1],
3837 &wrkar_off[ipt4], &wrkar_off[ipt5], &wrkar_off[ipt6], &wrkar_off[ipt2],
3838 &wrkar_off[ipt3], &patjac[patjac_offset], &errmax[1], &errmoy[1], ndegpu,
3839 ndegpv, itydec, iercod);
3840 if (*iercod > 0) {
3841 goto L9999;
3842 }
3843 goto L9999;
3844
3845 /* ------------------------------ The end -------------------------------
3846 */
3847
3848 L9013:
3849 *iercod = 13;
3850 goto L9999;
3851
3852 L9999:
3853 if (iofwr != 0) {
3854 anAdvApp2Var_SysBase.mcrdelt_(&c__8, &iszwr, wrkar, &iofwr, &ier);
3855 }
3856 if (ier > 0) {
3857 *iercod = 13;
3858 }
3859 AdvApp2Var_SysBase::maermsg_("MMA2CE1", iercod, 7L);
3860 if (ldbg) {
3861 AdvApp2Var_SysBase::mgsomsg_("MMA2CE1", 7L);
3862 }
3863 return 0;
3864 } /* mma2ce1_ */
3865
3866 //=======================================================================
3867 //function : mma2ce2_
3868 //purpose :
3869 //=======================================================================
mma2ce2_(integer * numdec,integer * ndimen,integer * nbsesp,integer * ndimse,integer * ndminu,integer * ndminv,integer * ndguli,integer * ndgvli,integer * ndjacu,integer * ndjacv,integer * iordru,integer * iordrv,integer * nbpntu,integer * nbpntv,doublereal * epsapr,doublereal * sosotb,doublereal * disotb,doublereal * soditb,doublereal * diditb,doublereal * gssutb,doublereal * gssvtb,doublereal * xmaxju,doublereal * xmaxjv,doublereal * vecerr,doublereal * chpair,doublereal * chimpr,doublereal * patjac,doublereal * errmax,doublereal * errmoy,integer * ndegpu,integer * ndegpv,integer * itydec,integer * iercod)3870 int mma2ce2_(integer *numdec,
3871 integer *ndimen,
3872 integer *nbsesp,
3873 integer *ndimse,
3874 integer *ndminu,
3875 integer *ndminv,
3876 integer *ndguli,
3877 integer *ndgvli,
3878 integer *ndjacu,
3879 integer *ndjacv,
3880 integer *iordru,
3881 integer *iordrv,
3882 integer *nbpntu,
3883 integer *nbpntv,
3884 doublereal *epsapr,
3885 doublereal *sosotb,
3886 doublereal *disotb,
3887 doublereal *soditb,
3888 doublereal *diditb,
3889 doublereal *gssutb,
3890 doublereal *gssvtb,
3891 doublereal *xmaxju,
3892 doublereal *xmaxjv,
3893 doublereal *vecerr,
3894 doublereal *chpair,
3895 doublereal *chimpr,
3896 doublereal *patjac,
3897 doublereal *errmax,
3898 doublereal *errmoy,
3899 integer *ndegpu,
3900 integer *ndegpv,
3901 integer *itydec,
3902 integer *iercod)
3903
3904 {
3905 /* System generated locals */
3906 integer sosotb_dim1, sosotb_dim2, sosotb_offset, disotb_dim1, disotb_dim2,
3907 disotb_offset, soditb_dim1, soditb_dim2, soditb_offset,
3908 diditb_dim1, diditb_dim2, diditb_offset, gssutb_dim1, gssvtb_dim1,
3909 chpair_dim1, chpair_dim2, chpair_offset, chimpr_dim1,
3910 chimpr_dim2, chimpr_offset, patjac_dim1, patjac_dim2,
3911 patjac_offset, vecerr_dim1, vecerr_offset, i__1, i__2, i__3, i__4;
3912
3913 /* Local variables */
3914 logical ldbg;
3915 integer idim, igsu, minu, minv, maxu, maxv, igsv;
3916 doublereal vaux[3];
3917 integer i2rdu, i2rdv, ndses, nd, ii, jj, kk, nu, nv;
3918 doublereal zu, zv;
3919 integer nu1, nv1;
3920
3921 /* **********************************************************************
3922 */
3923 /* FUNCTION : */
3924 /* ---------- */
3925 /* Calculation of coefficients of polynomial approximation of degree */
3926 /* (NDJACU,NDJACV) of a function F(u,v), starting from its */
3927 /* discretization on roots of Legendre polynom of degree */
3928 /* NBPNTU by U and NBPNTV by V. */
3929
3930 /* KEYWORDS : */
3931 /* ----------- */
3932 /* TOUS,AB_SPECIFI::FONCTION&,APPROXIMATION,&COEFFICIENT,&POLYNOME */
3933
3934 /* INPUT ARGUMENTS : */
3935 /* ------------------ */
3936 /* NUMDEC: Indicates if it is POSSIBLE to cut function F(u,v). */
3937 /* = 5, It is POSSIBLE to cut by U or by V or in both directions simultaneously. */
3938 /* = 4, It is POSSIBLE to cut by U or by V BUT NOT in both */
3939 /* directions simultaneously (cutting by V is preferable). */
3940 /* = 3, It is POSSIBLE to cut by U or by V BUT NOT in both */
3941 /* directions simultaneously (cutting by U is preferable). */
3942 /* = 2, It is POSSIBLE to cut only by V (i.e. insert parameter */
3943 /* of cutting Vj). */
3944 /* = 1, It is POSSIBLE to cut only by U (i.e. insert parameter */
3945 /* of cutting Ui). */
3946 /* = 0, It is not POSSIBLE to cut anything */
3947 /* NDIMEN: Total dimension of the space. */
3948 /* NBSESP: Nb of independent sub-spaces on which the errors are calculated. */
3949 /* NDIMSE: Table of dimensions of each of sub-spaces. */
3950 /* NDMINU: Minimum degree by U to be preserved for the approximation. */
3951 /* NDMINV: Minimum degree by V to be preserved for the approximation. */
3952 /* NDGULI: Limit of nb of coefficients by U of the solution. */
3953 /* NDGVLI: Limit of nb of coefficients by V of the solution. */
3954 /* NDJACU: Max degree of the polynom of approximation by U. */
3955 /* The representation in the orthogonal base starts from degree */
3956 /* 0 to degree NDJACU-2*(IORDRU+1). The polynomial base is the base of */
3957 /* Jacobi of order -1 (Legendre), 0, 1 or 2. */
3958 /* It is required that 2*IORDRU+1 <= NDMINU <= NDGULI < NDJACU */
3959 /* NDJACV: Max degree of the polynom of approximation by V. */
3960 /* The representation in the orthogonal base starts from degree */
3961 /* 0 to degree NDJACV-2*(IORDRV+1). The polynomial base is */
3962 /* the base of Jacobi of order -1 (Legendre), 0, 1 or 2 */
3963 /* It is required that 2*IORDRV+1 <= NDMINV <= NDGVLI < NDJACV */
3964 /* IORDRU: Order of the Jacobi base (-1,0,1 or 2) by U. Corresponds */
3965 /* to the step of constraints C0, C1 or C2. */
3966 /* IORDRV: Order of the Jacobi base (-1,0,1 or 2) by U. Corresponds */
3967 /* to the step of constraints C0, C1 or C2. */
3968 /* NBPNTU: Degree of Legendre polynom on the roots which of are */
3969 /* calculated the coefficients of integration by u */
3970 /* by Gauss method. It is required that NBPNTU = 30, 40, */
3971 /* 50 or 61 and NDJACU-2*(IORDRU+1) < NBPNTU. */
3972 /* NBPNTV: Degree of Legendre polynom on the roots which of are */
3973 /* calculated the coefficients of integration by u */
3974 /* by Gauss method. It is required that NBPNTV = 30, 40, */
3975 /* 50 or 61 and NDJACV-2*(IORDRV+1) < NBPNTV. */
3976 /* EPSAPR: Table of NBSESP tolerances imposed on each sub-spaces. */
3977 /* SOSOTB: Table of F(ui,vj) + F(ui,-vj) + F(-ui,vj) + F(-ui,-vj) */
3978 /* with ui and vj - positive roots of the Legendre polynom */
3979 /* of degree NBPNTU and NBPNTV respectively. Additionally, */
3980 /* table SOSOTB(0,j) contains F(0,vj) + F(0,-vj), */
3981 /* table SOSOTB(i,0) contains F(ui,0) + F(-ui,0) and */
3982 /* SOSOTB(0,0) contains F(0,0). */
3983 /* DISOTB: Table of F(ui,vj) + F(ui,-vj) - F(-ui,vj) - F(-ui,-vj) */
3984 /* with ui and vj positive roots of Legendre polynom */
3985 /* of degree NBPNTU and NBPNTV respectively. */
3986 /* SODITB: Table of F(ui,vj) - F(ui,-vj) + F(-ui,vj) - F(-ui,-vj) */
3987 /* with ui and vj positive roots of Legendre polynom */
3988 /* of degree NBPNTU and NBPNTV respectively. */
3989 /* DIDITB: Table of F(ui,vj) - F(ui,-vj) - F(-ui,vj) + F(-ui,-vj) */
3990 /* with ui and vj positive roots of Legendre polynom */
3991 /* of degree NBPNTU and NBPNTV respectively. Additionally, */
3992 /* table DIDITB(0,j) contains F(0,vj) - F(0,-vj), */
3993 /* and table DIDITB(i,0) contains F(ui,0) - F(-ui,0). */
3994 /* GSSUTB: Table of coefficients of integration by Gauss method */
3995 /* by U: i varies from 0 to NBPNTU/2 and k varies from 0 to */
3996 /* NDJACU-2*(IORDRU+1). */
3997 /* GSSVTB: Table of coefficients of integration by Gauss method */
3998 /* by V: i varies from 0 to NBPNTV/2 and k varies from 0 to */
3999 /* NDJACV-2*(IORDRV+1). */
4000 /* XMAXJU: Maximum value of Jacobi polynoms of order IORDRU, */
4001 /* from degree 0 to degree NDJACU - 2*(IORDRU+1) */
4002 /* XMAXJV: Maximum value of Jacobi polynoms of order IORDRV, */
4003 /* from degree 0 to degree NDJACV - 2*(IORDRV+1) */
4004
4005 /* OUTPUT ARGUMENTS : */
4006 /* ------------------- */
4007 /* VECERR: Auxiliary table. */
4008 /* CHPAIR: Auxiliary table of terms connected to degree NDJACU by U */
4009 /* to calculate the coeff. of approximation of EVEN degree by V. */
4010 /* CHIMPR: Auxiliary table of terms connected to degree NDJACU by U */
4011 /* to calculate the coeff. of approximation of UNEVEN degree by V. */
4012 /* PATJAC: Table of coefficients of polynom P(u,v) of approximation */
4013 /* of F(u,v) with eventually taking into account of */
4014 /* constraints. P(u,v) is of degree (NDJACU,NDJACV). */
4015 /* This table contains other coeff if ITYDEC = 0. */
4016 /* ERRMAX: For 1<=i<=NBSESP, ERRMAX(i) contains max errors */
4017 /* on each of sub-spaces SI ITYDEC = 0. */
4018 /* ERRMOY: Contains average errors for each of NBSESP sub-spaces SI ITYDEC = 0. */
4019 /* NDEGPU: Degree by U for square PATJAC. Valable if ITYDEC=0. */
4020 /* NDEGPV: Degree by V for square PATJAC. Valable if ITYDEC=0. */
4021 /* ITYDEC: Shows if it is NECESSARY to cut again function F(u,v). */
4022 /* = 0, it is not NECESSARY to cut anything, PATJAC is OK. */
4023 /* = 1, it is NECESSARY to cut only by U (i.e. insert parameter of cutting Ui). */
4024 /* = 2, it is NECESSARY to cut only by V (i.e. insert parameter of cutting Vj). */
4025 /* = 3, it is NECESSARY to cut both by U AND by V. */
4026 /* IERCOD: Error code. */
4027 /* = 0, Everything is OK. */
4028 /* = -1, There is the best possible solution, but the */
4029 /* user tolerance is not satisfactory (3*only) */
4030 /* = 1, Incoherent entries. */
4031
4032 /* COMMONS USED : */
4033 /* ---------------- */
4034
4035 /* REFERENCES CALLED : */
4036 /* --------------------- */
4037
4038 /* DESCRIPTION/NOTES/LIMITATIONS : */
4039 /* > */
4040 /* **********************************************************************
4041 */
4042 /* Name of the routine */
4043
4044
4045 /* --------------------------- Initialisations --------------------------
4046 */
4047
4048 /* Parameter adjustments */
4049 vecerr_dim1 = *ndimen;
4050 vecerr_offset = vecerr_dim1 + 1;
4051 vecerr -= vecerr_offset;
4052 --errmoy;
4053 --errmax;
4054 --epsapr;
4055 --ndimse;
4056 patjac_dim1 = *ndjacu + 1;
4057 patjac_dim2 = *ndjacv + 1;
4058 patjac_offset = patjac_dim1 * patjac_dim2;
4059 patjac -= patjac_offset;
4060 gssutb_dim1 = *nbpntu / 2 + 1;
4061 chimpr_dim1 = *nbpntv / 2;
4062 chimpr_dim2 = *ndjacu - ((*iordru + 1) << 1) + 1;
4063 chimpr_offset = chimpr_dim1 * chimpr_dim2 + 1;
4064 chimpr -= chimpr_offset;
4065 chpair_dim1 = *nbpntv / 2 + 1;
4066 chpair_dim2 = *ndjacu - ((*iordru + 1) << 1) + 1;
4067 chpair_offset = chpair_dim1 * chpair_dim2;
4068 chpair -= chpair_offset;
4069 gssvtb_dim1 = *nbpntv / 2 + 1;
4070 diditb_dim1 = *nbpntu / 2 + 1;
4071 diditb_dim2 = *nbpntv / 2 + 1;
4072 diditb_offset = diditb_dim1 * diditb_dim2;
4073 diditb -= diditb_offset;
4074 soditb_dim1 = *nbpntu / 2;
4075 soditb_dim2 = *nbpntv / 2;
4076 soditb_offset = soditb_dim1 * (soditb_dim2 + 1) + 1;
4077 soditb -= soditb_offset;
4078 disotb_dim1 = *nbpntu / 2;
4079 disotb_dim2 = *nbpntv / 2;
4080 disotb_offset = disotb_dim1 * (disotb_dim2 + 1) + 1;
4081 disotb -= disotb_offset;
4082 sosotb_dim1 = *nbpntu / 2 + 1;
4083 sosotb_dim2 = *nbpntv / 2 + 1;
4084 sosotb_offset = sosotb_dim1 * sosotb_dim2;
4085 sosotb -= sosotb_offset;
4086
4087 /* Function Body */
4088 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
4089 if (ldbg) {
4090 AdvApp2Var_SysBase::mgenmsg_("MMA2CE2", 7L);
4091 }
4092 /* --> A priori everything is OK */
4093 *iercod = 0;
4094 /* --> test of inputs */
4095 if (*numdec < 0 || *numdec > 5) {
4096 goto L9001;
4097 }
4098 if ((*iordru << 1) + 1 > *ndminu) {
4099 goto L9001;
4100 }
4101 if (*ndminu > *ndguli) {
4102 goto L9001;
4103 }
4104 if (*ndguli >= *ndjacu) {
4105 goto L9001;
4106 }
4107 if ((*iordrv << 1) + 1 > *ndminv) {
4108 goto L9001;
4109 }
4110 if (*ndminv > *ndgvli) {
4111 goto L9001;
4112 }
4113 if (*ndgvli >= *ndjacv) {
4114 goto L9001;
4115 }
4116 /* --> A priori, no cuts to be done */
4117 *itydec = 0;
4118 /* --> Min. degrees to return: NDMINU,NDMINV */
4119 *ndegpu = *ndminu;
4120 *ndegpv = *ndminv;
4121 /* --> For the moment, max errors are null */
4122 AdvApp2Var_SysBase::mvriraz_(nbsesp, &errmax[1]);
4123 nd = *ndimen << 2;
4124 AdvApp2Var_SysBase::mvriraz_(&nd, &vecerr[vecerr_offset]);
4125 /* --> and the square, too. */
4126 nd = (*ndjacu + 1) * (*ndjacv + 1) * *ndimen;
4127 AdvApp2Var_SysBase::mvriraz_(&nd, &patjac[patjac_offset]);
4128
4129 i2rdu = (*iordru + 1) << 1;
4130 i2rdv = (*iordrv + 1) << 1;
4131
4132 /* **********************************************************************
4133 */
4134 /* -------------------- HERE IT IS POSSIBLE TO CUT ----------------------
4135 */
4136 /* **********************************************************************
4137 */
4138
4139 if (*numdec > 0 && *numdec <= 5) {
4140
4141 /* ******************************************************************
4142 **** */
4143 /* ---------------------- Calculate coeff of zone 4 -------------
4144 ---- */
4145
4146 minu = *ndguli + 1;
4147 maxu = *ndjacu;
4148 minv = *ndgvli + 1;
4149 maxv = *ndjacv;
4150 if (minu > maxu) {
4151 goto L9001;
4152 }
4153 if (minv > maxv) {
4154 goto L9001;
4155 }
4156
4157 /* ---------------- Calculate the terms connected to degree by U ---------
4158 ---- */
4159
4160 i__1 = *ndimen;
4161 for (nd = 1; nd <= i__1; ++nd) {
4162 i__2 = maxu;
4163 for (kk = minu; kk <= i__2; ++kk) {
4164 igsu = kk - i2rdu;
4165 mma2cfu_(&kk, nbpntu, nbpntv, &sosotb[nd * sosotb_dim2 *
4166 sosotb_dim1], &disotb[(nd * disotb_dim2 + 1) *
4167 disotb_dim1 + 1], &soditb[(nd * soditb_dim2 + 1) *
4168 soditb_dim1 + 1], &diditb[nd * diditb_dim2 *
4169 diditb_dim1], &gssutb[igsu * gssutb_dim1], &chpair[(
4170 igsu + nd * chpair_dim2) * chpair_dim1], &chimpr[(
4171 igsu + nd * chimpr_dim2) * chimpr_dim1 + 1]);
4172 /* L110: */
4173 }
4174 /* L100: */
4175 }
4176
4177 /* ------------------- Calculate the coefficients of PATJAC ------------
4178 ---- */
4179
4180 igsu = minu - i2rdu;
4181 i__1 = maxv;
4182 for (jj = minv; jj <= i__1; ++jj) {
4183 igsv = jj - i2rdv;
4184 i__2 = *ndimen;
4185 for (nd = 1; nd <= i__2; ++nd) {
4186 mma2cfv_(&jj, &minu, &maxu, nbpntv, &gssvtb[igsv *
4187 gssvtb_dim1], &chpair[(igsu + nd * chpair_dim2) *
4188 chpair_dim1], &chimpr[(igsu + nd * chimpr_dim2) *
4189 chimpr_dim1 + 1], &patjac[minu + (jj + nd *
4190 patjac_dim2) * patjac_dim1]);
4191 /* L130: */
4192 }
4193
4194 /* ----- Contribution of calculated terms to the approximation error */
4195 /* for terms (I,J) with MINU <= I <= MAXU, J fixe. */
4196
4197 idim = 1;
4198 i__2 = *nbsesp;
4199 for (nd = 1; nd <= i__2; ++nd) {
4200 ndses = ndimse[nd];
4201 mma2er1_(ndjacu, ndjacv, &ndses, &minu, &maxu, &jj, &jj,
4202 iordru, iordrv, xmaxju, xmaxjv, &patjac[idim *
4203 patjac_dim2 * patjac_dim1], &vecerr[vecerr_dim1 + 1],
4204 &vecerr[nd + (vecerr_dim1 << 2)]);
4205 if (vecerr[nd + (vecerr_dim1 << 2)] > epsapr[nd]) {
4206 goto L9300;
4207 }
4208 idim += ndses;
4209 /* L140: */
4210 }
4211 /* L120: */
4212 }
4213
4214 /* ******************************************************************
4215 **** */
4216 /* ---------------------- Calculate the coeff of zone 2 -------------
4217 ---- */
4218
4219 minu = (*iordru + 1) << 1;
4220 maxu = *ndguli;
4221 minv = *ndgvli + 1;
4222 maxv = *ndjacv;
4223
4224 /* --> If zone 2 is empty, pass to zone 3. */
4225 /* VECERR(ND,2) was already set to zero. */
4226 if (minu > maxu) {
4227 goto L300;
4228 }
4229
4230 /* ---------------- Calculate the terms connected to degree by U ------------
4231 ---- */
4232
4233 i__1 = *ndimen;
4234 for (nd = 1; nd <= i__1; ++nd) {
4235 i__2 = maxu;
4236 for (kk = minu; kk <= i__2; ++kk) {
4237 igsu = kk - i2rdu;
4238 mma2cfu_(&kk, nbpntu, nbpntv, &sosotb[nd * sosotb_dim2 *
4239 sosotb_dim1], &disotb[(nd * disotb_dim2 + 1) *
4240 disotb_dim1 + 1], &soditb[(nd * soditb_dim2 + 1) *
4241 soditb_dim1 + 1], &diditb[nd * diditb_dim2 *
4242 diditb_dim1], &gssutb[igsu * gssutb_dim1], &chpair[(
4243 igsu + nd * chpair_dim2) * chpair_dim1], &chimpr[(
4244 igsu + nd * chimpr_dim2) * chimpr_dim1 + 1]);
4245 /* L210: */
4246 }
4247 /* L200: */
4248 }
4249
4250 /* ------------------- Calculate the coefficients of PATJAC ------------
4251 ---- */
4252
4253 igsu = minu - i2rdu;
4254 i__1 = maxv;
4255 for (jj = minv; jj <= i__1; ++jj) {
4256 igsv = jj - i2rdv;
4257 i__2 = *ndimen;
4258 for (nd = 1; nd <= i__2; ++nd) {
4259 mma2cfv_(&jj, &minu, &maxu, nbpntv, &gssvtb[igsv *
4260 gssvtb_dim1], &chpair[(igsu + nd * chpair_dim2) *
4261 chpair_dim1], &chimpr[(igsu + nd * chimpr_dim2) *
4262 chimpr_dim1 + 1], &patjac[minu + (jj + nd *
4263 patjac_dim2) * patjac_dim1]);
4264 /* L230: */
4265 }
4266 /* L220: */
4267 }
4268
4269 /* -----Contribution of calculated terms to the approximation error */
4270 /* for terms (I,J) with MINU <= I <= MAXU, MINV <= J <= MAXV */
4271
4272 idim = 1;
4273 i__1 = *nbsesp;
4274 for (nd = 1; nd <= i__1; ++nd) {
4275 ndses = ndimse[nd];
4276 mma2er1_(ndjacu, ndjacv, &ndses, &minu, &maxu, &minv, &maxv,
4277 iordru, iordrv, xmaxju, xmaxjv, &patjac[idim *
4278 patjac_dim2 * patjac_dim1], &vecerr[vecerr_dim1 + 1], &
4279 vecerr[nd + (vecerr_dim1 << 1)]);
4280 idim += ndses;
4281 /* L240: */
4282 }
4283
4284 /* ******************************************************************
4285 **** */
4286 /* ---------------------- Calculation of coeff of zone 3 -------------
4287 ---- */
4288
4289 L300:
4290 minu = *ndguli + 1;
4291 maxu = *ndjacu;
4292 minv = (*iordrv + 1) << 1;
4293 maxv = *ndgvli;
4294
4295 /* -> If zone 3 is empty, pass to the test of cutting. */
4296 /* VECERR(ND,3) was already set to zero */
4297 if (minv > maxv) {
4298 goto L400;
4299 }
4300
4301 /* ----------- The terms connected to the degree by U are already calculated -----
4302 ---- */
4303 /* ------------------- Calculation of coefficients of PATJAC ------------
4304 ---- */
4305
4306 igsu = minu - i2rdu;
4307 i__1 = maxv;
4308 for (jj = minv; jj <= i__1; ++jj) {
4309 igsv = jj - i2rdv;
4310 i__2 = *ndimen;
4311 for (nd = 1; nd <= i__2; ++nd) {
4312 mma2cfv_(&jj, &minu, &maxu, nbpntv, &gssvtb[igsv *
4313 gssvtb_dim1], &chpair[(igsu + nd * chpair_dim2) *
4314 chpair_dim1], &chimpr[(igsu + nd * chimpr_dim2) *
4315 chimpr_dim1 + 1], &patjac[minu + (jj + nd *
4316 patjac_dim2) * patjac_dim1]);
4317 /* L330: */
4318 }
4319 /* L320: */
4320 }
4321
4322 /* ----- Contribution of calculated terms to the approximation error */
4323 /* for terms (I,J) with MINU <= I <= MAXU, MINV <= J <= MAXV. */
4324
4325 idim = 1;
4326 i__1 = *nbsesp;
4327 for (nd = 1; nd <= i__1; ++nd) {
4328 ndses = ndimse[nd];
4329 mma2er1_(ndjacu, ndjacv, &ndses, &minu, &maxu, &minv, &maxv,
4330 iordru, iordrv, xmaxju, xmaxjv, &patjac[idim *
4331 patjac_dim2 * patjac_dim1], &vecerr[vecerr_dim1 + 1], &
4332 vecerr[nd + vecerr_dim1 * 3]);
4333 idim += ndses;
4334 /* L340: */
4335 }
4336
4337 /* ******************************************************************
4338 **** */
4339 /* --------------------------- Tests of cutting ---------------------
4340 ---- */
4341
4342 L400:
4343 i__1 = *nbsesp;
4344 for (nd = 1; nd <= i__1; ++nd) {
4345 vaux[0] = vecerr[nd + (vecerr_dim1 << 1)];
4346 vaux[1] = vecerr[nd + (vecerr_dim1 << 2)];
4347 vaux[2] = vecerr[nd + vecerr_dim1 * 3];
4348 ii = 3;
4349 errmax[nd] = AdvApp2Var_MathBase::mzsnorm_(&ii, vaux);
4350 if (errmax[nd] > epsapr[nd]) {
4351 ii = 2;
4352 zv = AdvApp2Var_MathBase::mzsnorm_(&ii, vaux);
4353 zu = AdvApp2Var_MathBase::mzsnorm_(&ii, &vaux[1]);
4354 if (zu > epsapr[nd] && zv > epsapr[nd]) {
4355 goto L9300;
4356 }
4357 if (zu > zv) {
4358 goto L9100;
4359 } else {
4360 goto L9200;
4361 }
4362 }
4363 /* L410: */
4364 }
4365
4366 /* ******************************************************************
4367 **** */
4368 /* --- OK, the square is valid, the coeff of zone 1 are calculated
4369 ---- */
4370
4371 minu = (*iordru + 1) << 1;
4372 maxu = *ndguli;
4373 minv = (*iordrv + 1) << 1;
4374 maxv = *ndgvli;
4375
4376 /* --> If zone 1 is empty, pass to the calculation of Max and Average error. */
4377 if (minu > maxu || minv > maxv) {
4378 goto L600;
4379 }
4380
4381 /* ----------- The terms connected to degree by U are already calculated -----
4382 ---- */
4383 /* ------------------- Calculate the coefficients of PATJAC ------------
4384 ---- */
4385
4386 igsu = minu - i2rdu;
4387 i__1 = maxv;
4388 for (jj = minv; jj <= i__1; ++jj) {
4389 igsv = jj - i2rdv;
4390 i__2 = *ndimen;
4391 for (nd = 1; nd <= i__2; ++nd) {
4392 mma2cfv_(&jj, &minu, &maxu, nbpntv, &gssvtb[igsv *
4393 gssvtb_dim1], &chpair[(igsu + nd * chpair_dim2) *
4394 chpair_dim1], &chimpr[(igsu + nd * chimpr_dim2) *
4395 chimpr_dim1 + 1], &patjac[minu + (jj + nd *
4396 patjac_dim2) * patjac_dim1]);
4397 /* L530: */
4398 }
4399 /* L520: */
4400 }
4401
4402 /* --------------- Now the degree is maximally lowered --------
4403 ---- */
4404
4405 L600:
4406 /* Computing MAX */
4407 i__1 = 1, i__2 = (*iordru << 1) + 1, i__1 = advapp_max(i__1,i__2);
4408 minu = advapp_max(i__1,*ndminu);
4409 maxu = *ndguli;
4410 /* Computing MAX */
4411 i__1 = 1, i__2 = (*iordrv << 1) + 1, i__1 = advapp_max(i__1,i__2);
4412 minv = advapp_max(i__1,*ndminv);
4413 maxv = *ndgvli;
4414 idim = 1;
4415 i__1 = *nbsesp;
4416 for (nd = 1; nd <= i__1; ++nd) {
4417 ndses = ndimse[nd];
4418 if (maxu >= (*iordru + 1) << 1 && maxv >= (*iordrv + 1) << 1) {
4419 mma2er2_(ndjacu, ndjacv, &ndses, &minu, &maxu, &minv, &maxv,
4420 iordru, iordrv, xmaxju, xmaxjv, &patjac[idim *
4421 patjac_dim2 * patjac_dim1], &epsapr[nd], &vecerr[
4422 vecerr_dim1 + 1], &errmax[nd], &nu, &nv);
4423 } else {
4424 nu = maxu;
4425 nv = maxv;
4426 }
4427 nu1 = nu + 1;
4428 nv1 = nv + 1;
4429
4430 /* --> Calculate the average error. */
4431 mma2moy_(ndjacu, ndjacv, &ndses, &nu1, ndjacu, &nv1, ndjacv,
4432 iordru, iordrv, &patjac[idim * patjac_dim2 * patjac_dim1],
4433 &errmoy[nd]);
4434
4435 /* --> Set to 0.D0 the rejected coeffs. */
4436 i__2 = idim + ndses - 1;
4437 for (ii = idim; ii <= i__2; ++ii) {
4438 i__3 = *ndjacv;
4439 for (jj = nv1; jj <= i__3; ++jj) {
4440 i__4 = *ndjacu;
4441 for (kk = nu1; kk <= i__4; ++kk) {
4442 patjac[kk + (jj + ii * patjac_dim2) * patjac_dim1] =
4443 0.;
4444 /* L640: */
4445 }
4446 /* L630: */
4447 }
4448 /* L620: */
4449 }
4450
4451 /* --> Return the nb of coeffs of approximation. */
4452 *ndegpu = advapp_max(*ndegpu,nu);
4453 *ndegpv = advapp_max(*ndegpv,nv);
4454 idim += ndses;
4455 /* L610: */
4456 }
4457
4458 /* ******************************************************************
4459 **** */
4460 /* -------------------- IT IS NOT POSSIBLE TO CUT -------------------
4461 ---- */
4462 /* ******************************************************************
4463 **** */
4464
4465 } else {
4466 minu = (*iordru + 1) << 1;
4467 maxu = *ndjacu;
4468 minv = (*iordrv + 1) << 1;
4469 maxv = *ndjacv;
4470
4471 /* ---------------- Calculate the terms connected to the degree by U ------------
4472 ---- */
4473
4474 i__1 = *ndimen;
4475 for (nd = 1; nd <= i__1; ++nd) {
4476 i__2 = maxu;
4477 for (kk = minu; kk <= i__2; ++kk) {
4478 igsu = kk - i2rdu;
4479 mma2cfu_(&kk, nbpntu, nbpntv, &sosotb[nd * sosotb_dim2 *
4480 sosotb_dim1], &disotb[(nd * disotb_dim2 + 1) *
4481 disotb_dim1 + 1], &soditb[(nd * soditb_dim2 + 1) *
4482 soditb_dim1 + 1], &diditb[nd * diditb_dim2 *
4483 diditb_dim1], &gssutb[igsu * gssutb_dim1], &chpair[(
4484 igsu + nd * chpair_dim2) * chpair_dim1], &chimpr[(
4485 igsu + nd * chimpr_dim2) * chimpr_dim1 + 1]);
4486 /* L710: */
4487 }
4488
4489 /* ---------------------- Calculate all coefficients -------
4490 -------- */
4491
4492 igsu = minu - i2rdu;
4493 i__2 = maxv;
4494 for (jj = minv; jj <= i__2; ++jj) {
4495 igsv = jj - i2rdv;
4496 mma2cfv_(&jj, &minu, &maxu, nbpntv, &gssvtb[igsv *
4497 gssvtb_dim1], &chpair[(igsu + nd * chpair_dim2) *
4498 chpair_dim1], &chimpr[(igsu + nd * chimpr_dim2) *
4499 chimpr_dim1 + 1], &patjac[minu + (jj + nd *
4500 patjac_dim2) * patjac_dim1]);
4501 /* L720: */
4502 }
4503 /* L700: */
4504 }
4505
4506 /* ----- Contribution of calculated terms to the approximation error */
4507 /* for terms (I,J) with MINU <= I <= MAXU, MINV <= J <= MAXV */
4508
4509 idim = 1;
4510 i__1 = *nbsesp;
4511 for (nd = 1; nd <= i__1; ++nd) {
4512 ndses = ndimse[nd];
4513 minu = (*iordru + 1) << 1;
4514 maxu = *ndjacu;
4515 minv = *ndgvli + 1;
4516 maxv = *ndjacv;
4517 mma2er1_(ndjacu, ndjacv, &ndses, &minu, &maxu, &minv, &maxv,
4518 iordru, iordrv, xmaxju, xmaxjv, &patjac[idim *
4519 patjac_dim2 * patjac_dim1], &vecerr[vecerr_dim1 + 1], &
4520 errmax[nd]);
4521 minu = *ndguli + 1;
4522 maxu = *ndjacu;
4523 minv = (*iordrv + 1) << 1;
4524 maxv = *ndgvli;
4525 if (minv <= maxv) {
4526 mma2er1_(ndjacu, ndjacv, &ndses, &minu, &maxu, &minv, &maxv,
4527 iordru, iordrv, xmaxju, xmaxjv, &patjac[idim *
4528 patjac_dim2 * patjac_dim1], &vecerr[vecerr_dim1 + 1],
4529 &errmax[nd]);
4530 }
4531
4532 /* ---------------------------- IF ERRMAX > EPSAPR, stop --------
4533 -------- */
4534
4535 if (errmax[nd] > epsapr[nd]) {
4536 *iercod = -1;
4537 nu = *ndguli;
4538 nv = *ndgvli;
4539
4540 /* ------------- Otherwise, try to remove again the coeff
4541 ------------ */
4542
4543 } else {
4544 /* Computing MAX */
4545 i__2 = 1, i__3 = (*iordru << 1) + 1, i__2 = advapp_max(i__2,i__3);
4546 minu = advapp_max(i__2,*ndminu);
4547 maxu = *ndguli;
4548 /* Computing MAX */
4549 i__2 = 1, i__3 = (*iordrv << 1) + 1, i__2 = advapp_max(i__2,i__3);
4550 minv = advapp_max(i__2,*ndminv);
4551 maxv = *ndgvli;
4552 if (maxu >= (*iordru + 1) << 1 && maxv >= (*iordrv + 1) << 1) {
4553 mma2er2_(ndjacu, ndjacv, &ndses, &minu, &maxu, &minv, &
4554 maxv, iordru, iordrv, xmaxju, xmaxjv, &patjac[
4555 idim * patjac_dim2 * patjac_dim1], &epsapr[nd], &
4556 vecerr[vecerr_dim1 + 1], &errmax[nd], &nu, &nv);
4557 } else {
4558 nu = maxu;
4559 nv = maxv;
4560 }
4561 }
4562
4563 /* --------------------- Calculate the average error -------------
4564 -------- */
4565
4566 nu1 = nu + 1;
4567 nv1 = nv + 1;
4568 mma2moy_(ndjacu, ndjacv, &ndses, &nu1, ndjacu, &nv1, ndjacv,
4569 iordru, iordrv, &patjac[idim * patjac_dim2 * patjac_dim1],
4570 &errmoy[nd]);
4571
4572 /* --------------------- Set to 0.D0 the rejected coeffs ----------
4573 -------- */
4574
4575 i__2 = idim + ndses - 1;
4576 for (ii = idim; ii <= i__2; ++ii) {
4577 i__3 = *ndjacv;
4578 for (jj = nv1; jj <= i__3; ++jj) {
4579 i__4 = *ndjacu;
4580 for (kk = nu1; kk <= i__4; ++kk) {
4581 patjac[kk + (jj + ii * patjac_dim2) * patjac_dim1] =
4582 0.;
4583 /* L760: */
4584 }
4585 /* L750: */
4586 }
4587 /* L740: */
4588 }
4589
4590 /* --------------- Return the nb of coeff of approximation ---
4591 -------- */
4592
4593 *ndegpu = advapp_max(*ndegpu,nu);
4594 *ndegpv = advapp_max(*ndegpv,nv);
4595 idim += ndses;
4596 /* L730: */
4597 }
4598 }
4599
4600 goto L9999;
4601
4602 /* ------------------------------ The end -------------------------------
4603 */
4604 /* --> Error in inputs */
4605 L9001:
4606 *iercod = 1;
4607 goto L9999;
4608
4609 /* --------- Management of cuts, it is required 0 < NUMDEC <= 5 -------
4610 */
4611
4612 /* --> Here it is possible and necessary to cut, choose by U if it is possible */
4613 L9100:
4614 if (*numdec <= 0 || *numdec > 5) {
4615 goto L9001;
4616 }
4617 if (*numdec != 2) {
4618 *itydec = 1;
4619 } else {
4620 *itydec = 2;
4621 }
4622 goto L9999;
4623 /* --> Here it is possible and necessary to cut, choose by U if it is possible */
4624 L9200:
4625 if (*numdec <= 0 || *numdec > 5) {
4626 goto L9001;
4627 }
4628 if (*numdec != 1) {
4629 *itydec = 2;
4630 } else {
4631 *itydec = 1;
4632 }
4633 goto L9999;
4634 /* --> Here it is possible and necessary to cut, choose by 4 if it is possible */
4635 L9300:
4636 if (*numdec <= 0 || *numdec > 5) {
4637 goto L9001;
4638 }
4639 if (*numdec == 5) {
4640 *itydec = 3;
4641 } else if (*numdec == 2 || *numdec == 4) {
4642 *itydec = 2;
4643 } else if (*numdec == 1 || *numdec == 3) {
4644 *itydec = 1;
4645 } else {
4646 goto L9001;
4647 }
4648 goto L9999;
4649
4650 L9999:
4651 AdvApp2Var_SysBase::maermsg_("MMA2CE2", iercod, 7L);
4652 if (ldbg) {
4653 AdvApp2Var_SysBase::mgsomsg_("MMA2CE2", 7L);
4654 }
4655 return 0;
4656 } /* mma2ce2_ */
4657
4658 //=======================================================================
4659 //function : mma2cfu_
4660 //purpose :
4661 //=======================================================================
mma2cfu_(integer * ndujac,integer * nbpntu,integer * nbpntv,doublereal * sosotb,doublereal * disotb,doublereal * soditb,doublereal * diditb,doublereal * gssutb,doublereal * chpair,doublereal * chimpr)4662 int mma2cfu_(integer *ndujac,
4663 integer *nbpntu,
4664 integer *nbpntv,
4665 doublereal *sosotb,
4666 doublereal *disotb,
4667 doublereal *soditb,
4668 doublereal *diditb,
4669 doublereal *gssutb,
4670 doublereal *chpair,
4671 doublereal *chimpr)
4672
4673 {
4674 /* System generated locals */
4675 integer sosotb_dim1, disotb_dim1, disotb_offset, soditb_dim1,
4676 soditb_offset, diditb_dim1, i__1, i__2;
4677
4678 /* Local variables */
4679 logical ldbg;
4680 integer nptu2, nptv2, ii, jj;
4681 doublereal bid0, bid1, bid2;
4682
4683 /* **********************************************************************
4684 */
4685
4686 /* FUNCTION : */
4687 /* ---------- */
4688 /* Calculate the terms connected to degree NDUJAC by U of the polynomial approximation */
4689 /* of function F(u,v), starting from its discretisation */
4690 /* on the roots of Legendre polynom of degree */
4691 /* NBPNTU by U and NBPNTV by V. */
4692
4693 /* KEYWORDS : */
4694 /* ----------- */
4695 /* FONCTION,APPROXIMATION,COEFFICIENT,POLYNOME */
4696
4697 /* INPUT ARGUMENTSE : */
4698 /* ------------------ */
4699 /* NDUJAC: Fixed degree by U for which the terms */
4700 /* allowing to obtain the Legendre or Jacobi coeff*/
4701 /* of even or uneven degree by V are calculated. */
4702 /* NBPNTU: Degree of Legendre polynom on the roots which of */
4703 /* the coefficients of integration by U are calculated */
4704 /* by Gauss method. It is required that NBPNTU = 30, 40, 50 or 61. */
4705 /* NBPNTV: Degree of Legendre polynom on the roots which of */
4706 /* the coefficients of integration by V are calculated */
4707 /* by Gauss method. It is required that NBPNTV = 30, 40, 50 or 61. */
4708 /* SOSOTB: Table of F(ui,vj) + F(ui,-vj) + F(-ui,vj) + F(-ui,-vj) */
4709 /* with ui and vj positive roots of Legendre polynom */
4710 /* of degree NBPNTU and NBPNTV respectively. Moreover, */
4711 /* table SOSOTB(0,j) contains F(0,vj) + F(0,-vj), */
4712 /* table SOSOTB(i,0) contains F(ui,0) + F(-ui,0) and */
4713 /* SOSOTB(0,0) contains F(0,0). */
4714 /* DISOTB: Table of F(ui,vj) + F(ui,-vj) - F(-ui,vj) - F(-ui,-vj) */
4715 /* with ui and vj positive roots of Legendre polynom */
4716 /* of degree NBPNTU and NBPNTV respectively. */
4717 /* SODITB: Table of F(ui,vj) - F(ui,-vj) + F(-ui,vj) - F(-ui,-vj) */
4718 /* with ui and vj positive roots of Legendre polynom */
4719 /* of degree NBPNTU and NBPNTV respectively. */
4720 /* DIDITB: Table of F(ui,vj) - F(ui,-vj) - F(-ui,vj) + F(-ui,-vj) */
4721 /* avec ui and vj positive roots of Legendre polynom */
4722 /* of degree NBPNTU and NBPNTV respectively. Moreover, */
4723 /* table DIDITB(0,j) contains F(0,vj) - F(0,-vj), */
4724 /* and table DIDITB(i,0) contains F(ui,0) - F(-ui,0). */
4725 /* GSSUTB: Table of coefficients of integration by Gauss method */
4726 /* Gauss by U for fixed NDUJAC : i varies from 0 to NBPNTU/2. */
4727
4728 /* OUTPUT ARGUMENTS : */
4729 /* ------------------- */
4730 /* CHPAIR: Table of terms connected to degree NDUJAC by U to calculate the */
4731 /* coeff. of the approximation of EVEN degree by V. */
4732 /* CHIMPR: Table of terms connected to degree NDUJAC by U to calculate */
4733 /* the coeff. of approximation of UNEVEN degree by V. */
4734
4735 /* COMMONS USED : */
4736 /* ---------------- */
4737
4738 /* REFERENCES CALLED : */
4739 /* ----------------------- */
4740
4741 /* DESCRIPTION/NOTES/LIMITATIONS : */
4742 /* ----------------------------------- */
4743
4744
4745 /* > */
4746 /* **********************************************************************
4747 */
4748 /* Name of the routine */
4749
4750
4751 /* --------------------------- Initialisations --------------------------
4752 */
4753
4754 /* Parameter adjustments */
4755 --chimpr;
4756 diditb_dim1 = *nbpntu / 2 + 1;
4757 soditb_dim1 = *nbpntu / 2;
4758 soditb_offset = soditb_dim1 + 1;
4759 soditb -= soditb_offset;
4760 disotb_dim1 = *nbpntu / 2;
4761 disotb_offset = disotb_dim1 + 1;
4762 disotb -= disotb_offset;
4763 sosotb_dim1 = *nbpntu / 2 + 1;
4764
4765 /* Function Body */
4766 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
4767 if (ldbg) {
4768 AdvApp2Var_SysBase::mgenmsg_("MMA2CFU", 7L);
4769 }
4770
4771 nptu2 = *nbpntu / 2;
4772 nptv2 = *nbpntv / 2;
4773
4774 /* **********************************************************************
4775 */
4776 /* CALCULATE COEFFICIENTS BY U */
4777
4778 /* ----------------- Calculate coefficients of even degree --------------
4779 */
4780
4781 if (*ndujac % 2 == 0) {
4782 i__1 = nptv2;
4783 for (jj = 1; jj <= i__1; ++jj) {
4784 bid1 = 0.;
4785 bid2 = 0.;
4786 i__2 = nptu2;
4787 for (ii = 1; ii <= i__2; ++ii) {
4788 bid0 = gssutb[ii];
4789 bid1 += sosotb[ii + jj * sosotb_dim1] * bid0;
4790 bid2 += soditb[ii + jj * soditb_dim1] * bid0;
4791 /* L200: */
4792 }
4793 chpair[jj] = bid1;
4794 chimpr[jj] = bid2;
4795 /* L100: */
4796 }
4797
4798 /* --------------- Calculate coefficients of uneven degree ----------
4799 ---- */
4800
4801 } else {
4802 i__1 = nptv2;
4803 for (jj = 1; jj <= i__1; ++jj) {
4804 bid1 = 0.;
4805 bid2 = 0.;
4806 i__2 = nptu2;
4807 for (ii = 1; ii <= i__2; ++ii) {
4808 bid0 = gssutb[ii];
4809 bid1 += disotb[ii + jj * disotb_dim1] * bid0;
4810 bid2 += diditb[ii + jj * diditb_dim1] * bid0;
4811 /* L250: */
4812 }
4813 chpair[jj] = bid1;
4814 chimpr[jj] = bid2;
4815 /* L150: */
4816 }
4817 }
4818
4819 /* ------- Add terms connected to the supplementary root (0.D0) ------ */
4820 /* ----------- of Legendre polynom of uneven degree NBPNTU -----------
4821 */
4822 /* --> Only even NDUJAC terms are modified as GSSUTB(0) = 0 */
4823 /* when NDUJAC is uneven. */
4824
4825 if (*nbpntu % 2 != 0 && *ndujac % 2 == 0) {
4826 bid0 = gssutb[0];
4827 i__1 = nptv2;
4828 for (jj = 1; jj <= i__1; ++jj) {
4829 chpair[jj] += sosotb[jj * sosotb_dim1] * bid0;
4830 chimpr[jj] += diditb[jj * diditb_dim1] * bid0;
4831 /* L300: */
4832 }
4833 }
4834
4835 /* ------ Calculate the terms connected to supplementary roots (0.D0) ------
4836 */
4837 /* ----------- of Legendre polynom of uneven degree NBPNTV -----------
4838 */
4839
4840 if (*nbpntv % 2 != 0) {
4841 /* --> Only CHPAIR terms are calculated as GSSVTB(0,IH-IDEBV)=0
4842 */
4843 /* when IH is uneven (see MMA2CFV). */
4844
4845 if (*ndujac % 2 == 0) {
4846 bid1 = 0.;
4847 i__1 = nptu2;
4848 for (ii = 1; ii <= i__1; ++ii) {
4849 bid1 += sosotb[ii] * gssutb[ii];
4850 /* L400: */
4851 }
4852 chpair[0] = bid1;
4853 } else {
4854 bid1 = 0.;
4855 i__1 = nptu2;
4856 for (ii = 1; ii <= i__1; ++ii) {
4857 bid1 += diditb[ii] * gssutb[ii];
4858 /* L500: */
4859 }
4860 chpair[0] = bid1;
4861 }
4862 if (*nbpntu % 2 != 0) {
4863 chpair[0] += sosotb[0] * gssutb[0];
4864 }
4865 }
4866
4867 /* ------------------------------ The end -------------------------------
4868 */
4869
4870 if (ldbg) {
4871 AdvApp2Var_SysBase::mgsomsg_("MMA2CFU", 7L);
4872 }
4873 return 0;
4874 } /* mma2cfu_ */
4875
4876 //=======================================================================
4877 //function : mma2cfv_
4878 //purpose :
4879 //=======================================================================
mma2cfv_(integer * ndvjac,integer * mindgu,integer * maxdgu,integer * nbpntv,doublereal * gssvtb,doublereal * chpair,doublereal * chimpr,doublereal * patjac)4880 int mma2cfv_(integer *ndvjac,
4881 integer *mindgu,
4882 integer *maxdgu,
4883 integer *nbpntv,
4884 doublereal *gssvtb,
4885 doublereal *chpair,
4886 doublereal *chimpr,
4887 doublereal *patjac)
4888
4889 {
4890 /* System generated locals */
4891 integer chpair_dim1, chpair_offset, chimpr_dim1, chimpr_offset,
4892 patjac_offset, i__1, i__2;
4893
4894 /* Local variables */
4895 logical ldbg;
4896 integer nptv2, ii, jj;
4897 doublereal bid1;
4898
4899 /* **********************************************************************
4900 */
4901
4902 /* FUNCTION : */
4903 /* ---------- */
4904 /* Calculate the coefficients of polynomial approximation of F(u,v) */
4905 /* of degree NDVJAC by V and of degree by U varying from MINDGU to MAXDGU.
4906 */
4907
4908 /* Keywords : */
4909 /* ----------- */
4910 /* FONCTION,APPROXIMATION,COEFFICIENT,POLYNOME */
4911
4912 /* INPUT ARGUMENTS : */
4913 /* ------------------ */
4914
4915 /* NDVJAC: Degree of the polynom of approximation by V. */
4916 /* The representation in the orthogonal base starts from degre 0. */
4917 /* The polynomial base is the base of Jacobi of order -1 */
4918 /* (Legendre), 0, 1 or 2 */
4919 /* MINDGU: Degree minimum by U of coeff. to calculate. */
4920 /* MAXDGU: Degree maximum by U of coeff. to calculate. */
4921 /* NBPNTV: Degree of the Legendre polynom on the roots which of */
4922 /* the coefficients of integration by V are calculated */
4923 /* by Gauss method. It is reqired that NBPNTV = 30, 40, 50 or 61 and NDVJAC < NBPNTV. */
4924 /* GSSVTB: Table of coefficients of integration by Gauss method */
4925 /* by V for NDVJAC fixed: j varies from 0 to NBPNTV/2. */
4926 /* CHPAIR: Table of terms connected to degrees from MINDGU to MAXDGU by U to */
4927 /* calculate the coeff. of approximation of EVEN degree NDVJAC by V. */
4928 /* CHIMPR: Table of terms connected to degrees from MINDGU to MAXDGU by U to */
4929 /* calculate the coeff. of approximation of UNEVEN degree NDVJAC by V. */
4930
4931 /* OUTPUT ARGUMENTS : */
4932 /* ------------------- */
4933 /* PATJAC: Table of coefficients by U of the polynom of approximation */
4934 /* P(u,v) of degree MINDGU to MAXDGU by U and NDVJAC by V. */
4935
4936 /* COMMONS USED : */
4937 /* -------------- */
4938
4939 /* REFERENCES CALLED : */
4940 /* --------------------- */
4941
4942 /* DESCRIPTION/NOTES/LIMITATIONS : */
4943 /* ------------------------------- */
4944 /* > */
4945 /* **********************************************************************
4946 */
4947 /* Name of the routine */
4948
4949
4950 /* --------------------------- Initialisations --------------------------
4951 */
4952
4953 /* Parameter adjustments */
4954 patjac_offset = *mindgu;
4955 patjac -= patjac_offset;
4956 chimpr_dim1 = *nbpntv / 2;
4957 chimpr_offset = chimpr_dim1 * *mindgu + 1;
4958 chimpr -= chimpr_offset;
4959 chpair_dim1 = *nbpntv / 2 + 1;
4960 chpair_offset = chpair_dim1 * *mindgu;
4961 chpair -= chpair_offset;
4962
4963 /* Function Body */
4964 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
4965 if (ldbg) {
4966 AdvApp2Var_SysBase::mgenmsg_("MMA2CFV", 7L);
4967 }
4968 nptv2 = *nbpntv / 2;
4969
4970 /* --------- Calculate the coefficients for even degree NDVJAC ----------
4971 */
4972
4973 if (*ndvjac % 2 == 0) {
4974 i__1 = *maxdgu;
4975 for (ii = *mindgu; ii <= i__1; ++ii) {
4976 bid1 = 0.;
4977 i__2 = nptv2;
4978 for (jj = 1; jj <= i__2; ++jj) {
4979 bid1 += chpair[jj + ii * chpair_dim1] * gssvtb[jj];
4980 /* L200: */
4981 }
4982 patjac[ii] = bid1;
4983 /* L100: */
4984 }
4985
4986 /* -------- Calculate the coefficients for uneven degree NDVJAC -----
4987 ---- */
4988
4989 } else {
4990 i__1 = *maxdgu;
4991 for (ii = *mindgu; ii <= i__1; ++ii) {
4992 bid1 = 0.;
4993 i__2 = nptv2;
4994 for (jj = 1; jj <= i__2; ++jj) {
4995 bid1 += chimpr[jj + ii * chimpr_dim1] * gssvtb[jj];
4996 /* L250: */
4997 }
4998 patjac[ii] = bid1;
4999 /* L150: */
5000 }
5001 }
5002
5003 /* ------- Add terms connected to the supplementary root (0.D0) ----- */
5004 /* --------of the Legendre polynom of uneven degree NBPNTV --------- */
5005
5006 if (*nbpntv % 2 != 0 && *ndvjac % 2 == 0) {
5007 bid1 = gssvtb[0];
5008 i__1 = *maxdgu;
5009 for (ii = *mindgu; ii <= i__1; ++ii) {
5010 patjac[ii] += bid1 * chpair[ii * chpair_dim1];
5011 /* L300: */
5012 }
5013 }
5014
5015 /* ------------------------------ The end -------------------------------
5016 */
5017
5018 if (ldbg) {
5019 AdvApp2Var_SysBase::mgsomsg_("MMA2CFV", 7L);
5020 }
5021 return 0;
5022 } /* mma2cfv_ */
5023
5024 //=======================================================================
5025 //function : mma2ds1_
5026 //purpose :
5027 //=======================================================================
mma2ds1_(integer * ndimen,doublereal * uintfn,doublereal * vintfn,const AdvApp2Var_EvaluatorFunc2Var & foncnp,integer * nbpntu,integer * nbpntv,doublereal * urootb,doublereal * vrootb,integer * isofav,doublereal * sosotb,doublereal * disotb,doublereal * soditb,doublereal * diditb,doublereal * fpntab,doublereal * ttable,integer * iercod)5028 int AdvApp2Var_ApproxF2var::mma2ds1_(integer *ndimen,
5029 doublereal *uintfn,
5030 doublereal *vintfn,
5031 const AdvApp2Var_EvaluatorFunc2Var& foncnp,
5032 integer *nbpntu,
5033 integer *nbpntv,
5034 doublereal *urootb,
5035 doublereal *vrootb,
5036 integer *isofav,
5037 doublereal *sosotb,
5038 doublereal *disotb,
5039 doublereal *soditb,
5040 doublereal *diditb,
5041 doublereal *fpntab,
5042 doublereal *ttable,
5043 integer *iercod)
5044
5045 {
5046 /* System generated locals */
5047 integer sosotb_dim1, sosotb_dim2, sosotb_offset, disotb_dim1, disotb_dim2,
5048 disotb_offset, soditb_dim1, soditb_dim2, soditb_offset,
5049 diditb_dim1, diditb_dim2, diditb_offset, fpntab_dim1,
5050 fpntab_offset, i__1;
5051
5052 /* Local variables */
5053 logical ldbg;
5054 integer ibid1, ibid2, iuouv, nd;
5055 integer isz1, isz2;
5056
5057 /* **********************************************************************
5058 */
5059
5060 /* FUNCTION : */
5061 /* ---------- */
5062 /* Discretisation of function F(u,v) on the roots of Legendre polynoms. */
5063
5064 /* KEYWORDS : */
5065 /* ----------- */
5066 /* FONCTION&,DISCRETISATION,&POINT */
5067
5068 /* INPUT ARGUMENTS : */
5069 /* ------------------ */
5070 /* NDIMEN: Dimension of the space. */
5071 /* UINTFN: Limits of the interval of definition by u of the function */
5072 /* to be processed: (UINTFN(1),UINTFN(2)). */
5073 /* VINTFN: Limits of the interval of definition by v of the function */
5074 /* to be processed: (VINTFN(1),VINTFN(2)). */
5075 /* FONCNP: The NAME of the non-polynomial function to be processed. */
5076 /* NBPNTU: The degree of Legendre polynom on the roots which of */
5077 /* FONCNP is discretized by u. */
5078 /* NBPNTV: The degree of Legendre polynom on the roots which of */
5079 /* FONCNP is discretized by v. */
5080 /* UROOTB: Table of STRICTLY POSITIVE roots of the polynom */
5081 /* of Legendre of degree NBPNTU defined on (-1,1). */
5082 /* VROOTB: Table of STRICTLY POSITIVE roots of the polynom */
5083 /* of Legendre of degree NBPNTV defined on (-1,1). */
5084 /* ISOFAV: Shows the type of iso of F(u,v) to be extracted to improve */
5085 /* the rapidity of calculation (has no influence on the form */
5086 /* of result) */
5087 /* = 1, shows that it is necessary to calculate the points of F(u,v) */
5088 /* with fixed u (with NBPNTV values different from v). */
5089 /* = 2, shows that it is necessaty to calculate the points of F(u,v) */
5090 /* with fixed v (with NBPNTU values different from u). */
5091 /* SOSOTB: Preinitialized table (input/output argument). */
5092 /* DISOTB: Preinitialized table (input/output argument). */
5093 /* SODITB: Preinitialized table (input/output argument). */
5094 /* DIDITB: Preinitialized table (input/output argument). */
5095
5096 /* OUTPUT ARGUMENTS : */
5097 /* ------------------- */
5098 /* SOSOTB: Table where the terms */
5099 /* F(ui,vj) + F(ui,-vj) + F(-ui,vj) + F(-ui,-vj) */
5100 /* are added with ui and vj positive roots of Legendre polynom */
5101 /* of degree NBPNTU and NBPNTV respectively. */
5102 /* DISOTB: Table where the terms */
5103 /* F(ui,vj) + F(ui,-vj) - F(-ui,vj) - F(-ui,-vj) */
5104 /* are added with ui and vj positive roots of Legendre polynom */
5105 /* of degree NBPNTU and NBPNTV respectively. */
5106 /* SODITB: Table where the terms */
5107 /* F(ui,vj) - F(ui,-vj) + F(-ui,vj) - F(-ui,-vj) */
5108 /* are added with ui and vj positive roots of Legendre polynom */
5109 /* of degree NBPNTU and NBPNTV respectively. */
5110 /* DIDITB: Table where the terms */
5111 /* F(ui,vj) - F(ui,-vj) - F(-ui,vj) + F(-ui,-vj) */
5112 /* are added with ui and vj positive roots of Legendre polynom */
5113 /* of degree NBPNTU and NBPNTV respectively. */
5114 /* FPNTAB: Auxiliary table. */
5115 /* TTABLE: Auxiliary table. */
5116 /* IERCOD: Error code >100 Pb in the evaluation of FONCNP, */
5117 /* the returned error code is equal to error code of FONCNP + 100. */
5118
5119 /* COMMONS USED : */
5120 /* ---------------- */
5121
5122 /* REFERENCES CALLED : */
5123 /* --------------------- */
5124
5125 /* DESCRIPTION/NOTES/LIMITATIONS : */
5126 /* ----------------------------------- */
5127 /* --> The external function created by the caller of MA2F1K, MA2FDK */
5128 /* where MA2FXK should be in the following form : */
5129 /* SUBROUTINE FONCNP(NDIMEN,UINTFN,VINTFN,ISOFAV,TCONST,NBPTAB */
5130 /* ,TTABLE,IDERIU,IDERIV,PPNTAB,IERCOD) */
5131 /* with the following input arguments : */
5132 /* - NDIMEN is integer defined as the sum of dimensions of */
5133 /* sub-spaces (i.e. total dimension of the problem). */
5134 /* - UINTFN(2) is a table of 2 reals containing the interval */
5135 /* by u where the function to be approximated is defined */
5136 /* (so it is equal to UIFONC). */
5137 /* - VINTFN(2) is a table of 2 reals containing the interval */
5138 /* by v where the function to be approximated is defined */
5139 /* (so it is equal to VIFONC). */
5140 /* - ISOFAV, is 1 if it is necessary to calculate points with constant u, */
5141 /* is 2 if it is necessary to calculate points with constant v. */
5142 /* Any other value is an error. */
5143 /* - TCONST, real, value of the fixed parameter. Takes values */
5144 /* in (UIFONC(1),UIFONC(2)) if ISOFAV = 1 or */
5145 /* ins (VIFONC(1),VIFONC(2)) if ISOFAV = 2. */
5146 /* - NBPTAB, integer. Shows the number of points to be calculated. */
5147 /* - TTABLE, a table of reals NBPTAB. These are the values of */
5148 /* 'free' parameter of discretization (v if IISOFAV=1, */
5149 /* u if IISOFAV=2). */
5150 /* - IDERIU, integer, takes values between 0 (position) */
5151 /* and IORDRE(1) (partial derivative of the function by u */
5152 /* of order IORDRE(1) if IORDRE(1) > 0). */
5153 /* - IDERIV, integer, takes values between 0 (position) */
5154 /* and IORDRE(2) (partial derivative of the function by v */
5155 /* of order IORDRE(2) if IORDRE(2) > 0). */
5156 /* If IDERIU=i and IDERIV=j, FONCNP should calculate the */
5157 /* points of the derivative : */
5158 /* i+j */
5159 /* d F(u,v) */
5160 /* -------- */
5161 /* i j */
5162 /* du dv */
5163
5164 /* and the output arguments aret : */
5165 /* - FPNTAB(NDIMEN,NBPTAB) contains, at output, the table of */
5166 /* NBPTAB points calculated in FONCNP. */
5167 /* - IERCOD is, at output the error code of FONCNP. This code */
5168 /* (integer) should be strictly positive if there is a problem. */
5169
5170 /* The input arguments SHOULD NOT be modified under FONCNP.
5171 */
5172
5173 /* -->As FONCNP is not forcedly defined in (-1,1)*(-1,1), the */
5174 /* values of UROOTB and VROOTB are consequently modified. */
5175
5176 /* -->The results of discretisation are ranked in 4 tables */
5177 /* SOSOTB, DISOTB, SODITB and DIDITB to earn time */
5178 /* during the calculation of coefficients of the polynom of approximation. */
5179
5180 /* When NBPNTU is uneven : */
5181 /* table SOSOTB(0,j) contains F(0,vj) + F(0,-vj), */
5182 /* table DIDITB(0,j) contains F(0,vj) - F(0,-vj), */
5183 /* When NBPNTV is uneven : */
5184 /* table SOSOTB(i,0) contains F(ui,0) + F(-ui,0), */
5185 /* table DIDITB(i,0) contains F(ui,0) - F(-ui,0), */
5186 /* When NBPNTU and NBPNTV are uneven : */
5187 /* term SOSOTB(0,0) contains F(0,0). */
5188
5189 /* > */
5190 /* **********************************************************************
5191 */
5192 /* Name of the routine */
5193
5194
5195 /* --------------------------- Initialization --------------------------
5196 */
5197
5198 /* Parameter adjustments */
5199 fpntab_dim1 = *ndimen;
5200 fpntab_offset = fpntab_dim1 + 1;
5201 fpntab -= fpntab_offset;
5202 --uintfn;
5203 --vintfn;
5204 --urootb;
5205 diditb_dim1 = *nbpntu / 2 + 1;
5206 diditb_dim2 = *nbpntv / 2 + 1;
5207 diditb_offset = diditb_dim1 * diditb_dim2;
5208 diditb -= diditb_offset;
5209 soditb_dim1 = *nbpntu / 2;
5210 soditb_dim2 = *nbpntv / 2;
5211 soditb_offset = soditb_dim1 * (soditb_dim2 + 1) + 1;
5212 soditb -= soditb_offset;
5213 disotb_dim1 = *nbpntu / 2;
5214 disotb_dim2 = *nbpntv / 2;
5215 disotb_offset = disotb_dim1 * (disotb_dim2 + 1) + 1;
5216 disotb -= disotb_offset;
5217 sosotb_dim1 = *nbpntu / 2 + 1;
5218 sosotb_dim2 = *nbpntv / 2 + 1;
5219 sosotb_offset = sosotb_dim1 * sosotb_dim2;
5220 sosotb -= sosotb_offset;
5221 --vrootb;
5222 --ttable;
5223
5224 /* Function Body */
5225 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
5226 if (ldbg) {
5227 AdvApp2Var_SysBase::mgenmsg_("MMA2DS1", 7L);
5228 }
5229 *iercod = 0;
5230 if (*isofav < 1 || *isofav > 2) {
5231 iuouv = 2;
5232 } else {
5233 iuouv = *isofav;
5234 }
5235
5236 /* **********************************************************************
5237 */
5238 /* --------- Discretization by U on the roots of the polynom of ------ */
5239 /* --------------- Legendre of degree NBPNTU, iso-V by iso-V --------- */
5240 /* **********************************************************************
5241 */
5242
5243 if (iuouv == 2) {
5244 mma2ds2_(ndimen, &uintfn[1], &vintfn[1], foncnp, nbpntu, nbpntv, &
5245 urootb[1], &vrootb[1], &iuouv, &sosotb[sosotb_offset], &
5246 disotb[disotb_offset], &soditb[soditb_offset], &diditb[
5247 diditb_offset], &fpntab[fpntab_offset], &ttable[1], iercod);
5248
5249 /* ******************************************************************
5250 **** */
5251 /* --------- Discretization by V on the roots of the polynom of ------ */
5252 /* --------------- Legendre of degree NBPNTV, iso-V by iso-V --------- */
5253 /* ******************************************************************
5254 **** */
5255
5256 } else {
5257 /* --> Inversion of indices of tables */
5258 i__1 = *ndimen;
5259 for (nd = 1; nd <= i__1; ++nd) {
5260 isz1 = *nbpntu / 2 + 1;
5261 isz2 = *nbpntv / 2 + 1;
5262 AdvApp2Var_MathBase::mmfmtb1_(&isz1, &sosotb[nd * sosotb_dim2 * sosotb_dim1], &isz1, &
5263 isz2, &isz2, &sosotb[nd * sosotb_dim2 * sosotb_dim1], &
5264 ibid1, &ibid2, iercod);
5265 if (*iercod > 0) {
5266 goto L9999;
5267 }
5268 AdvApp2Var_MathBase::mmfmtb1_(&isz1, &diditb[nd * diditb_dim2 * diditb_dim1], &isz1, &
5269 isz2, &isz2, &diditb[nd * diditb_dim2 * diditb_dim1], &
5270 ibid1, &ibid2, iercod);
5271 if (*iercod > 0) {
5272 goto L9999;
5273 }
5274 isz1 = *nbpntu / 2;
5275 isz2 = *nbpntv / 2;
5276 AdvApp2Var_MathBase::mmfmtb1_(&isz1, &soditb[(nd * soditb_dim2 + 1) * soditb_dim1 + 1],
5277 &isz1, &isz2, &isz2, &soditb[(nd * soditb_dim2 + 1) *
5278 soditb_dim1 + 1], &ibid1, &ibid2, iercod);
5279 if (*iercod > 0) {
5280 goto L9999;
5281 }
5282 AdvApp2Var_MathBase::mmfmtb1_(&isz1, &disotb[(nd * disotb_dim2 + 1) * disotb_dim1 + 1],
5283 &isz1, &isz2, &isz2, &disotb[(nd * disotb_dim2 + 1) *
5284 disotb_dim1 + 1], &ibid1, &ibid2, iercod);
5285 if (*iercod > 0) {
5286 goto L9999;
5287 }
5288 /* L100: */
5289 }
5290
5291 mma2ds2_(ndimen, &vintfn[1], &uintfn[1], foncnp, nbpntv, nbpntu, &
5292 vrootb[1], &urootb[1], &iuouv, &sosotb[sosotb_offset], &
5293 soditb[soditb_offset], &disotb[disotb_offset], &diditb[
5294 diditb_offset], &fpntab[fpntab_offset], &ttable[1], iercod);
5295 /* --> Inversion of indices of tables */
5296 i__1 = *ndimen;
5297 for (nd = 1; nd <= i__1; ++nd) {
5298 isz1 = *nbpntv / 2 + 1;
5299 isz2 = *nbpntu / 2 + 1;
5300 AdvApp2Var_MathBase::mmfmtb1_(&isz1, &sosotb[nd * sosotb_dim2 * sosotb_dim1], &isz1, &
5301 isz2, &isz2, &sosotb[nd * sosotb_dim2 * sosotb_dim1], &
5302 ibid1, &ibid2, iercod);
5303 if (*iercod > 0) {
5304 goto L9999;
5305 }
5306 AdvApp2Var_MathBase::mmfmtb1_(&isz1, &diditb[nd * diditb_dim2 * diditb_dim1], &isz1, &
5307 isz2, &isz2, &diditb[nd * diditb_dim2 * diditb_dim1], &
5308 ibid1, &ibid2, iercod);
5309 if (*iercod > 0) {
5310 goto L9999;
5311 }
5312 isz1 = *nbpntv / 2;
5313 isz2 = *nbpntu / 2;
5314 AdvApp2Var_MathBase::mmfmtb1_(&isz1, &soditb[(nd * soditb_dim2 + 1) * soditb_dim1 + 1],
5315 &isz1, &isz2, &isz2, &soditb[(nd * soditb_dim2 + 1) *
5316 soditb_dim1 + 1], &ibid1, &ibid2, iercod);
5317 if (*iercod > 0) {
5318 goto L9999;
5319 }
5320 AdvApp2Var_MathBase::mmfmtb1_(&isz1, &disotb[(nd * disotb_dim2 + 1) * disotb_dim1 + 1],
5321 &isz1, &isz2, &isz2, &disotb[(nd * disotb_dim2 + 1) *
5322 disotb_dim1 + 1], &ibid1, &ibid2, iercod);
5323 if (*iercod > 0) {
5324 goto L9999;
5325 }
5326 /* L200: */
5327 }
5328 }
5329
5330 /* ------------------------------ The end -------------------------------
5331 */
5332
5333 L9999:
5334 if (*iercod > 0) {
5335 *iercod += 100;
5336 AdvApp2Var_SysBase::maermsg_("MMA2DS1", iercod, 7L);
5337 }
5338 if (ldbg) {
5339 AdvApp2Var_SysBase::mgsomsg_("MMA2DS1", 7L);
5340 }
5341 return 0;
5342 } /* mma2ds1_ */
5343
5344 //=======================================================================
5345 //function : mma2ds2_
5346 //purpose :
5347 //=======================================================================
mma2ds2_(integer * ndimen,doublereal * uintfn,doublereal * vintfn,const AdvApp2Var_EvaluatorFunc2Var & foncnp,integer * nbpntu,integer * nbpntv,doublereal * urootb,doublereal * vrootb,integer * iiuouv,doublereal * sosotb,doublereal * disotb,doublereal * soditb,doublereal * diditb,doublereal * fpntab,doublereal * ttable,integer * iercod)5348 int mma2ds2_(integer *ndimen,
5349 doublereal *uintfn,
5350 doublereal *vintfn,
5351 const AdvApp2Var_EvaluatorFunc2Var& foncnp,
5352 integer *nbpntu,
5353 integer *nbpntv,
5354 doublereal *urootb,
5355 doublereal *vrootb,
5356 integer *iiuouv,
5357 doublereal *sosotb,
5358 doublereal *disotb,
5359 doublereal *soditb,
5360 doublereal *diditb,
5361 doublereal *fpntab,
5362 doublereal *ttable,
5363 integer *iercod)
5364
5365 {
5366 integer c__0 = 0;
5367 /* System generated locals */
5368 integer sosotb_dim1, sosotb_dim2, sosotb_offset, disotb_dim1, disotb_dim2,
5369 disotb_offset, soditb_dim1, soditb_dim2, soditb_offset,
5370 diditb_dim1, diditb_dim2, diditb_offset, fpntab_dim1,
5371 fpntab_offset, i__1, i__2, i__3;
5372
5373 /* Local variables */
5374 integer jdec;
5375 logical ldbg;
5376 doublereal alinu, blinu, alinv, blinv, tcons;
5377 doublereal dbfn1[2], dbfn2[2];
5378 integer nuroo, nvroo, id, iu, iv;
5379 doublereal um, up;
5380
5381
5382 /* **********************************************************************
5383 */
5384
5385 /* FUNCTION : */
5386 /* ---------- */
5387 /* Discretization of function F(u,v) on the roots of polynoms of Legendre. */
5388
5389 /* KEYWORDS : */
5390 /* ----------- */
5391 /* FONCTION&,DISCRETISATION,&POINT */
5392
5393 /* INPUT ARGUMENTS : */
5394 /* ------------------ */
5395 /* NDIMEN: Dimension of the space. */
5396 /* UINTFN: Limits of the interval of definition by u of the function */
5397 /* to be processed: (UINTFN(1),UINTFN(2)). */
5398 /* VINTFN: Limits of the interval of definition by v of the function */
5399 /* to be processed: (VINTFN(1),VINTFN(2)). */
5400 /* FONCNP: The NAME of the non-polynomial function to be processed. */
5401 /* NBPNTU: The degree of Legendre polynom on the roots which of */
5402 /* FONCNP is discretized by u. */
5403 /* NBPNTV: The degree of Legendre polynom on the roots which of */
5404 /* FONCNP is discretized by v. */
5405 /* UROOTB: Table of STRICTLY POSITIVE roots of the polynom */
5406 /* of Legendre of degree NBPNTU defined on (-1,1). */
5407 /* VROOTB: Table of STRICTLY POSITIVE roots of the polynom */
5408 /* of Legendre of degree NBPNTV defined on (-1,1). */
5409 /* IIUOUV: Shows the type of iso of F(u,v) tom be extracted to improve the */
5410 /* rapidity of calculation (has no influence on the form of result) */
5411 /* = 1, shows that it is necessary to calculate the points of F(u,v) */
5412 /* with fixed u (so with NBPNTV values different from v). */
5413 /* = 2, shows that it is necessary to calculate the points of F(u,v) */
5414 /* with fixed v (so with NBPNTV values different from u). */
5415 /* SOSOTB: Preinitialized table (input/output argument). */
5416 /* DISOTB: Preinitialized table (input/output argument). */
5417 /* SODITB: Preinitialized table (input/output argument). */
5418 /* DIDITB: Preinitialized table (input/output argument). */
5419
5420 /* OUTPUT ARGUMENTS : */
5421 /* ------------------- */
5422 /* SOSOTB: Table where the terms */
5423 /* F(ui,vj) + F(ui,-vj) + F(-ui,vj) + F(-ui,-vj) */
5424 /* are added with ui and vj positive roots of Legendre polynom */
5425 /* of degree NBPNTU and NBPNTV respectively. */
5426 /* DISOTB: Table where the terms */
5427 /* F(ui,vj) + F(ui,-vj) - F(-ui,vj) - F(-ui,-vj) */
5428 /* are added with ui and vj positive roots of Legendre polynom */
5429 /* of degree NBPNTU and NBPNTV respectively. */
5430 /* SODITB: Table where the terms */
5431 /* F(ui,vj) - F(ui,-vj) + F(-ui,vj) - F(-ui,-vj) */
5432 /* are added with ui and vj positive roots of Legendre polynom */
5433 /* of degree NBPNTU and NBPNTV respectively. */
5434 /* DIDITB: Table where the terms */
5435 /* F(ui,vj) - F(ui,-vj) - F(-ui,vj) + F(-ui,-vj) */
5436 /* are added with ui and vj positive roots of Legendre polynom */
5437 /* of degree NBPNTU and NBPNTV respectively. */
5438 /* FPNTAB: Auxiliary table. */
5439 /* TTABLE: Auxiliary table. */
5440 /* IERCOD: Error code >100 Pb in the evaluation of FONCNP, */
5441 /* the returned error code is equal to error code of FONCNP + 100. */
5442
5443 /* COMMONS USED : */
5444 /* ---------------- */
5445
5446 /* REFERENCES CALLED : */
5447 /* --------------------- */
5448
5449 /* DESCRIPTION/NOTES/LIMITATIONS : */
5450 /* ----------------------------------- */
5451 /* --> The external function created by the caller of MA2F1K, MA2FDK */
5452 /* where MA2FXK should be in the following form : */
5453 /* SUBROUTINE FONCNP(NDIMEN,UINTFN,VINTFN,IIIUOUV,TCONST,NBPTAB */
5454 /* ,TTABLE,IDERIU,IDERIV,PPNTAB,IERCOD) */
5455 /* with the following input arguments : */
5456 /* - NDIMEN is integer defined as the sum of dimensions of */
5457 /* sub-spaces (i.e. total dimension of the problem). */
5458 /* - UINTFN(2) is a table of 2 reals containing the interval */
5459 /* by u where the function to be approximated is defined */
5460 /* (so it is equal to UIFONC). */
5461 /* - VINTFN(2) is a table of 2 reals containing the interval */
5462 /* by v where the function to be approximated is defined */
5463 /* (so it is equal to VIFONC). */
5464 /* - IIIUOUV, is 1 if it is necessary to calculate points with constant u, */
5465 /* is 2 if it is necessary to calculate points with constant v. */
5466 /* Any other value is an error. */
5467 /* - TCONST, real, value of the fixed parameter. Takes values */
5468 /* in (UIFONC(1),UIFONC(2)) if ISOFAV = 1 or */
5469 /* ins (VIFONC(1),VIFONC(2)) if ISOFAV = 2. */
5470 /* - NBPTAB, integer. Shows the number of points to be calculated. */
5471 /* - TTABLE, a table of reals NBPTAB. These are the values of */
5472 /* 'free' parameter of discretization (v if IIIUOUV=1, */
5473 /* u if IIIUOUV=2). */
5474 /* - IDERIU, integer, takes values between 0 (position) */
5475 /* and IORDRE(1) (partial derivative of the function by u */
5476 /* of order IORDRE(1) if IORDRE(1) > 0). */
5477 /* - IDERIV, integer, takes values between 0 (position) */
5478 /* and IORDRE(2) (partial derivative of the function by v */
5479 /* of order IORDRE(2) if IORDRE(2) > 0). */
5480 /* If IDERIU=i and IDERIV=j, FONCNP should calculate the */
5481 /* points of the derivative : */
5482 /* i+j */
5483 /* d F(u,v) */
5484 /* -------- */
5485 /* i j */
5486 /* du dv */
5487
5488 /* and the output arguments aret : */
5489 /* - FPNTAB(NDIMEN,NBPTAB) contains, at output, the table of */
5490 /* NBPTAB points calculated in FONCNP. */
5491 /* - IERCOD is, at output the error code of FONCNP. This code */
5492 /* (integer) should be strictly positive if there is a problem. */
5493
5494 /* The input arguments SHOULD NOT be modified under FONCNP.
5495 */
5496
5497 /* -->As FONCNP is not forcedly defined in (-1,1)*(-1,1), the */
5498 /* values of UROOTB and VROOTB are consequently modified. */
5499
5500 /* -->The results of discretisation are ranked in 4 tables */
5501 /* SOSOTB, DISOTB, SODITB and DIDITB to earn time */
5502 /* during the calculation of coefficients of the polynom of approximation. */
5503
5504 /* When NBPNTU is uneven : */
5505 /* table SOSOTB(0,j) contains F(0,vj) + F(0,-vj), */
5506 /* table DIDITB(0,j) contains F(0,vj) - F(0,-vj), */
5507 /* When NBPNTV is uneven : */
5508 /* table SOSOTB(i,0) contains F(ui,0) + F(-ui,0), */
5509 /* table DIDITB(i,0) contains F(ui,0) - F(-ui,0), */
5510 /* When NBPNTU and NBPNTV are uneven : */
5511 /* term SOSOTB(0,0) contains F(0,0). */
5512
5513 /* ATTENTION: These 4 tables are filled by varying the */
5514 /* 1st index first. So, the discretizations */
5515 /* of F(...,t) (for IIUOUV = 2) or of F(t,...) (IIUOUV = 1) */
5516 /* are stored in SOSOTB(...,t), SODITB(...,t), etc... */
5517 /* (this allows to gain important time). */
5518 /* It is required that the caller, in case of IIUOUV=1, */
5519 /* invert the roles of u and v, of SODITB and DISOTB BEFORE the */
5520
5521 /* > */
5522 /* **********************************************************************
5523 */
5524
5525 /* Name of the routine */
5526
5527 /* --> Indices of loops. */
5528
5529 /* --------------------------- Initialization --------------------------
5530 */
5531
5532 /* Parameter adjustments */
5533 --uintfn;
5534 --vintfn;
5535 --ttable;
5536 fpntab_dim1 = *ndimen;
5537 fpntab_offset = fpntab_dim1 + 1;
5538 fpntab -= fpntab_offset;
5539 --urootb;
5540 diditb_dim1 = *nbpntu / 2 + 1;
5541 diditb_dim2 = *nbpntv / 2 + 1;
5542 diditb_offset = diditb_dim1 * diditb_dim2;
5543 diditb -= diditb_offset;
5544 soditb_dim1 = *nbpntu / 2;
5545 soditb_dim2 = *nbpntv / 2;
5546 soditb_offset = soditb_dim1 * (soditb_dim2 + 1) + 1;
5547 soditb -= soditb_offset;
5548 disotb_dim1 = *nbpntu / 2;
5549 disotb_dim2 = *nbpntv / 2;
5550 disotb_offset = disotb_dim1 * (disotb_dim2 + 1) + 1;
5551 disotb -= disotb_offset;
5552 sosotb_dim1 = *nbpntu / 2 + 1;
5553 sosotb_dim2 = *nbpntv / 2 + 1;
5554 sosotb_offset = sosotb_dim1 * sosotb_dim2;
5555 sosotb -= sosotb_offset;
5556 --vrootb;
5557
5558 /* Function Body */
5559 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
5560 if (ldbg) {
5561 AdvApp2Var_SysBase::mgenmsg_("MMA2DS2", 7L);
5562 }
5563 *iercod = 0;
5564
5565 alinu = (uintfn[2] - uintfn[1]) / 2.;
5566 blinu = (uintfn[2] + uintfn[1]) / 2.;
5567 alinv = (vintfn[2] - vintfn[1]) / 2.;
5568 blinv = (vintfn[2] + vintfn[1]) / 2.;
5569
5570 if (*iiuouv == 1) {
5571 dbfn1[0] = vintfn[1];
5572 dbfn1[1] = vintfn[2];
5573 dbfn2[0] = uintfn[1];
5574 dbfn2[1] = uintfn[2];
5575 } else {
5576 dbfn1[0] = uintfn[1];
5577 dbfn1[1] = uintfn[2];
5578 dbfn2[0] = vintfn[1];
5579 dbfn2[1] = vintfn[2];
5580 }
5581
5582 /* **********************************************************************
5583 */
5584 /* -------- Discretization by U on the roots of Legendre polynom -------- */
5585 /* ---------------- of degree NBPNTU, with Vj fixed -------------------- */
5586 /* **********************************************************************
5587 */
5588
5589 nuroo = *nbpntu / 2;
5590 nvroo = *nbpntv / 2;
5591 jdec = (*nbpntu + 1) / 2;
5592
5593 /* ----------- Loading of parameters of discretization by U ------------- */
5594
5595 i__1 = *nbpntu;
5596 for (iu = 1; iu <= i__1; ++iu) {
5597 ttable[iu] = blinu + alinu * urootb[iu];
5598 /* L100: */
5599 }
5600
5601 /* -------------- For Vj fixed, negative root of Legendre ------------- */
5602
5603 i__1 = nvroo;
5604 for (iv = 1; iv <= i__1; ++iv) {
5605 tcons = blinv + alinv * vrootb[iv];
5606 (*const_cast <AdvApp2Var_EvaluatorFunc2Var*> (&foncnp)).Evaluate (
5607 ndimen, dbfn1, dbfn2, iiuouv, &tcons, nbpntu, &
5608 ttable[1], &c__0, &c__0, &fpntab[fpntab_offset], iercod);
5609 if (*iercod > 0) {
5610 goto L9999;
5611 }
5612 i__2 = *ndimen;
5613 for (id = 1; id <= i__2; ++id) {
5614 i__3 = nuroo;
5615 for (iu = 1; iu <= i__3; ++iu) {
5616 up = fpntab[id + (iu + jdec) * fpntab_dim1];
5617 um = fpntab[id + (nuroo - iu + 1) * fpntab_dim1];
5618 sosotb[iu + (nvroo - iv + 1 + id * sosotb_dim2) * sosotb_dim1]
5619 = sosotb[iu + (nvroo - iv + 1 + id * sosotb_dim2) *
5620 sosotb_dim1] + up + um;
5621 disotb[iu + (nvroo - iv + 1 + id * disotb_dim2) * disotb_dim1]
5622 = disotb[iu + (nvroo - iv + 1 + id * disotb_dim2) *
5623 disotb_dim1] + up - um;
5624 soditb[iu + (nvroo - iv + 1 + id * soditb_dim2) * soditb_dim1]
5625 = soditb[iu + (nvroo - iv + 1 + id * soditb_dim2) *
5626 soditb_dim1] - up - um;
5627 diditb[iu + (nvroo - iv + 1 + id * diditb_dim2) * diditb_dim1]
5628 = diditb[iu + (nvroo - iv + 1 + id * diditb_dim2) *
5629 diditb_dim1] - up + um;
5630 /* L220: */
5631 }
5632 if (*nbpntu % 2 != 0) {
5633 up = fpntab[id + jdec * fpntab_dim1];
5634 sosotb[(nvroo - iv + 1 + id * sosotb_dim2) * sosotb_dim1] +=
5635 up;
5636 diditb[(nvroo - iv + 1 + id * diditb_dim2) * diditb_dim1] -=
5637 up;
5638 }
5639 /* L210: */
5640 }
5641 /* L200: */
5642 }
5643
5644 /* --------- For Vj = 0 (uneven NBPNTV), discretization by U ----------- */
5645
5646 if (*nbpntv % 2 != 0) {
5647 tcons = blinv;
5648 (*const_cast <AdvApp2Var_EvaluatorFunc2Var*> (&foncnp)).Evaluate (
5649 ndimen, dbfn1, dbfn2, iiuouv, &tcons, nbpntu, &
5650 ttable[1], &c__0, &c__0, &fpntab[fpntab_offset], iercod);
5651 if (*iercod > 0) {
5652 goto L9999;
5653 }
5654 i__1 = *ndimen;
5655 for (id = 1; id <= i__1; ++id) {
5656 i__2 = nuroo;
5657 for (iu = 1; iu <= i__2; ++iu) {
5658 up = fpntab[id + (jdec + iu) * fpntab_dim1];
5659 um = fpntab[id + (nuroo - iu + 1) * fpntab_dim1];
5660 sosotb[iu + id * sosotb_dim2 * sosotb_dim1] = sosotb[iu + id *
5661 sosotb_dim2 * sosotb_dim1] + up + um;
5662 diditb[iu + id * diditb_dim2 * diditb_dim1] = diditb[iu + id *
5663 diditb_dim2 * diditb_dim1] + up - um;
5664 /* L310: */
5665 }
5666 if (*nbpntu % 2 != 0) {
5667 up = fpntab[id + jdec * fpntab_dim1];
5668 sosotb[id * sosotb_dim2 * sosotb_dim1] += up;
5669 }
5670 /* L300: */
5671 }
5672 }
5673
5674 /* -------------- For Vj fixed, positive root of Legendre ------------- */
5675
5676 i__1 = nvroo;
5677 for (iv = 1; iv <= i__1; ++iv) {
5678 tcons = alinv * vrootb[(*nbpntv + 1) / 2 + iv] + blinv;
5679 (*const_cast <AdvApp2Var_EvaluatorFunc2Var*> (&foncnp)).Evaluate (
5680 ndimen, dbfn1, dbfn2, iiuouv, &tcons, nbpntu, &
5681 ttable[1], &c__0, &c__0, &fpntab[fpntab_offset], iercod);
5682 if (*iercod > 0) {
5683 goto L9999;
5684 }
5685 i__2 = *ndimen;
5686 for (id = 1; id <= i__2; ++id) {
5687 i__3 = nuroo;
5688 for (iu = 1; iu <= i__3; ++iu) {
5689 up = fpntab[id + (iu + jdec) * fpntab_dim1];
5690 um = fpntab[id + (nuroo - iu + 1) * fpntab_dim1];
5691 sosotb[iu + (iv + id * sosotb_dim2) * sosotb_dim1] = sosotb[
5692 iu + (iv + id * sosotb_dim2) * sosotb_dim1] + up + um;
5693 disotb[iu + (iv + id * disotb_dim2) * disotb_dim1] = disotb[
5694 iu + (iv + id * disotb_dim2) * disotb_dim1] + up - um;
5695 soditb[iu + (iv + id * soditb_dim2) * soditb_dim1] = soditb[
5696 iu + (iv + id * soditb_dim2) * soditb_dim1] + up + um;
5697 diditb[iu + (iv + id * diditb_dim2) * diditb_dim1] = diditb[
5698 iu + (iv + id * diditb_dim2) * diditb_dim1] + up - um;
5699 /* L420: */
5700 }
5701 if (*nbpntu % 2 != 0) {
5702 up = fpntab[id + jdec * fpntab_dim1];
5703 sosotb[(iv + id * sosotb_dim2) * sosotb_dim1] += up;
5704 diditb[(iv + id * diditb_dim2) * diditb_dim1] += up;
5705 }
5706 /* L410: */
5707 }
5708 /* L400: */
5709 }
5710
5711 /* ------------------------------ The end -------------------------------
5712 */
5713
5714 L9999:
5715 if (*iercod > 0) {
5716 *iercod += 100;
5717 AdvApp2Var_SysBase::maermsg_("MMA2DS2", iercod, 7L);
5718 }
5719 if (ldbg) {
5720 AdvApp2Var_SysBase::mgsomsg_("MMA2DS2", 7L);
5721 }
5722 return 0;
5723 } /* mma2ds2_ */
5724
5725 //=======================================================================
5726 //function : mma2er1_
5727 //purpose :
5728 //=======================================================================
mma2er1_(integer * ndjacu,integer * ndjacv,integer * ndimen,integer * mindgu,integer * maxdgu,integer * mindgv,integer * maxdgv,integer * iordru,integer * iordrv,doublereal * xmaxju,doublereal * xmaxjv,doublereal * patjac,doublereal * vecerr,doublereal * erreur)5729 int mma2er1_(integer *ndjacu,
5730 integer *ndjacv,
5731 integer *ndimen,
5732 integer *mindgu,
5733 integer *maxdgu,
5734 integer *mindgv,
5735 integer *maxdgv,
5736 integer *iordru,
5737 integer *iordrv,
5738 doublereal *xmaxju,
5739 doublereal *xmaxjv,
5740 doublereal *patjac,
5741 doublereal *vecerr,
5742 doublereal *erreur)
5743
5744 {
5745 /* System generated locals */
5746 integer patjac_dim1, patjac_dim2, patjac_offset, i__1, i__2, i__3;
5747 doublereal d__1;
5748
5749 /* Local variables */
5750 logical ldbg;
5751 integer minu, minv;
5752 doublereal vaux[2];
5753 integer ii, nd, jj;
5754 doublereal bid0, bid1;
5755
5756 /* **********************************************************************
5757 */
5758
5759 /* FUNCTION : */
5760 /* ---------- */
5761 /* Calculate max approximation error done when */
5762 /* the coefficients of PATJAC such that the degree by U varies between */
5763 /* MINDGU and MAXDGU and the degree by V varies between MINDGV and MAXDGV are removed. */
5764
5765 /* KEYWORDS : */
5766 /* ----------- */
5767 /* TOUS,AB_SPECIFI:: CARREAU&,CALCUL,&ERREUR */
5768
5769 /* INPUT ARGUMENTS : */
5770 /* ------------------ */
5771 /* NDJACU: Dimension by U of table PATJAC. */
5772 /* NDJACV: Dimension by V of table PATJAC. */
5773 /* NDIMEN: Dimension of the space. */
5774 /* MINDGU: Lower limit of index by U of coeff. of PATJAC to be taken into account. */
5775 /* MAXDGU: Upper limit of index by U of coeff. of PATJAC to be taken into account. */
5776 /* MINDGV: Lower limit of index by V of coeff. of PATJAC to be taken into account. */
5777 /* MAXDGV: Upper limit of index by V of coeff. of PATJAC to be taken into account. */
5778 /* IORDRU: Order of continuity by U provided by square PATJAC (from -1 to 2) */
5779 /* IORDRV: Order of continuity by U provided by square PATJAC (from -1 to 2) */
5780 /* XMAXJU: Maximum value of Jacobi polynoms of order IORDRU, */
5781 /* from degree 0 to MAXDGU - 2*(IORDU+1) */
5782 /* XMAXJV: Maximum value of Jacobi polynoms of order IORDRV, */
5783 /* from degree 0 to MAXDGV - 2*(IORDV+1) */
5784 /* PATJAC: Table of coeff. of square of approximation with */
5785 /* constraints of order IORDRU by U and IORDRV by V. */
5786 /* VECERR: Auxiliary vector. */
5787 /* ERREUR: MAX Error committed during removal of ALREADY CALCULATED coeff of PATJAC */
5788
5789 /* OUTPUT ARGUMENTS : */
5790 /* ------------------- */
5791 /* ERREUR: MAX Error committed during removal of coeff of PATJAC */
5792 /* of indices from MINDGU to MAXDGU by U and from MINDGV to MAXDGV by V */
5793 /* THEN the already calculated error. */
5794
5795 /* COMMONS USED : */
5796 /* ---------------- */
5797
5798 /* REFERENCES CALLED : */
5799 /* --------------------- */
5800
5801 /* DESCRIPTION/NOTES/LIMITATIONS : */
5802 /* ----------------------------------- */
5803 /* Table PATJAC is the place of storage of coeff. Cij of the square of */
5804 /* approximation of F(U,V). The indices i and j show the degree */
5805 /* by U and by V of base polynoms. These polynoms have the form: */
5806
5807 /* ((1 - U*U)**(IORDRU+1)).J(i-2*(IORDRU+1)(U), where */
5808
5809 /* polynom J(i-2*(IORDU+1)(U) is the Jacobi polynom of order */
5810 /* IORDRU+1 (the same by V by replacing U u V in the expression above). */
5811
5812 /* The contribution to the error of term Cij when it is */
5813 /* removed from PATJAC is increased by: */
5814
5815 /* DABS(Cij)*XMAXJU(i-2*(IORDRU+1))*XMAXJV(J-2*(IORDRV+1)) where */
5816
5817 /* XMAXJU(i-2*(IORDRU+1) = ((1 - U*U)**(IORDRU+1)).J(i-2*(IORDRU+1)(U),
5818 */
5819 /* XMAXJV(i-2*(IORDRV+1) = ((1 - V*V)**(IORDRV+1)).J(j-2*(IORDRV+1)(V).
5820 */
5821
5822 /* > */
5823 /* ***********************************************************************
5824 */
5825 /* Name of the routine */
5826
5827
5828 /* ----------------------------- Initialisations ------------------------
5829 */
5830
5831 /* Parameter adjustments */
5832 --vecerr;
5833 patjac_dim1 = *ndjacu + 1;
5834 patjac_dim2 = *ndjacv + 1;
5835 patjac_offset = patjac_dim1 * patjac_dim2;
5836 patjac -= patjac_offset;
5837
5838 /* Function Body */
5839 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
5840 if (ldbg) {
5841 AdvApp2Var_SysBase::mgenmsg_("MMA2ER1", 7L);
5842 }
5843
5844 minu = (*iordru + 1) << 1;
5845 minv = (*iordrv + 1) << 1;
5846
5847 /* ------------------- Calculate the increment of the max error --------------- */
5848 /* ----- during the removal of the coeffs of indices from MINDGU to MAXDGU ---- */
5849 /* ---------------- by U and indices from MINDGV to MAXDGV by V --------------- */
5850
5851 i__1 = *ndimen;
5852 for (nd = 1; nd <= i__1; ++nd) {
5853 bid1 = 0.;
5854 i__2 = *maxdgv;
5855 for (jj = *mindgv; jj <= i__2; ++jj) {
5856 bid0 = 0.;
5857 i__3 = *maxdgu;
5858 for (ii = *mindgu; ii <= i__3; ++ii) {
5859 bid0 += (d__1 = patjac[ii + (jj + nd * patjac_dim2) *
5860 patjac_dim1], advapp_abs(d__1)) * xmaxju[ii - minu];
5861 /* L300: */
5862 }
5863 bid1 = bid0 * xmaxjv[jj - minv] + bid1;
5864 /* L200: */
5865 }
5866 vecerr[nd] = bid1;
5867
5868 /* L100: */
5869 }
5870
5871 /* ----------------------- Calculate the max error ----------------------*/
5872
5873 bid1 = AdvApp2Var_MathBase::mzsnorm_(ndimen, &vecerr[1]);
5874 vaux[0] = *erreur;
5875 vaux[1] = bid1;
5876 nd = 2;
5877 *erreur = AdvApp2Var_MathBase::mzsnorm_(&nd, vaux);
5878
5879 /* ------------------------- The end ------------------------------------
5880 */
5881
5882 if (ldbg) {
5883 AdvApp2Var_SysBase::mgsomsg_("MMA2ER1", 7L);
5884 }
5885 return 0;
5886 } /* mma2er1_ */
5887
5888 //=======================================================================
5889 //function : mma2er2_
5890 //purpose :
5891 //=======================================================================
mma2er2_(integer * ndjacu,integer * ndjacv,integer * ndimen,integer * mindgu,integer * maxdgu,integer * mindgv,integer * maxdgv,integer * iordru,integer * iordrv,doublereal * xmaxju,doublereal * xmaxjv,doublereal * patjac,doublereal * epmscut,doublereal * vecerr,doublereal * erreur,integer * newdgu,integer * newdgv)5892 int mma2er2_(integer *ndjacu,
5893 integer *ndjacv,
5894 integer *ndimen,
5895 integer *mindgu,
5896 integer *maxdgu,
5897 integer *mindgv,
5898 integer *maxdgv,
5899 integer *iordru,
5900 integer *iordrv,
5901 doublereal *xmaxju,
5902 doublereal *xmaxjv,
5903 doublereal *patjac,
5904 doublereal *epmscut,
5905 doublereal *vecerr,
5906 doublereal *erreur,
5907 integer *newdgu,
5908 integer *newdgv)
5909
5910 {
5911 /* System generated locals */
5912 integer patjac_dim1, patjac_dim2, patjac_offset, i__1, i__2;
5913 doublereal d__1;
5914
5915 /* Local variables */
5916 logical ldbg;
5917 doublereal vaux[2];
5918 integer i2rdu, i2rdv;
5919 doublereal errnu, errnv;
5920 integer ii, nd, jj, nu, nv;
5921 doublereal bid0, bid1;
5922
5923 /* **********************************************************************
5924 */
5925
5926 /* FUNCTION : */
5927 /* ---------- */
5928 /* Remove coefficients of PATJAC to obtain the minimum degree */
5929 /* by U and V checking the imposed tolerance. */
5930
5931 /* KEYWORDS : */
5932 /* ----------- */
5933 /* TOUS,AB_SPECIFI:: CARREAU&,CALCUL,&ERREUR */
5934
5935 /* INPUT ARGUMENTS : */
5936 /* ------------------ */
5937 /* NDJACU: Degree by U of table PATJAC. */
5938 /* NDJACV: Degree by V of table PATJAC. */
5939 /* NDIMEN: Dimension of the space. */
5940 /* MINDGU: Limit of index by U of coeff. of PATJAC to be PRESERVED (should be >=0). */
5941 /* MAXDGU: Upper limit of index by U of coeff. of PATJAC to be taken into account. */
5942 /* MINDGV: Limit of index by V of coeff. of PATJAC to be PRESERVED (should be >=0). */
5943 /* MAXDGV: Upper limit of index by V of coeff. of PATJAC to be taken into account. */
5944 /* IORDRU: Order of continuity by U provided by square PATJAC (from -1 to 2) */
5945 /* IORDRV: Order of continuity by U provided by square PATJAC (from -1 to 2) */
5946 /* XMAXJU: Maximum value of Jacobi polynoms of order IORDRU, */
5947 /* from degree 0 to MAXDGU - 2*(IORDU+1) */
5948 /* XMAXJV: Maximum value of Jacobi polynoms of order IORDRV, */
5949 /* from degree 0 to MAXDGV - 2*(IORDV+1) */
5950 /* PATJAC: Table of coeff. of square of approximation with */
5951 /* constraints of order IORDRU by U and IORDRV by V. */
5952 /* EPMSCUT: Tolerance of approximation. */
5953 /* VECERR: Auxiliary vector. */
5954 /* ERREUR: MAX Error committed ALREADY CALCULATED */
5955
5956 /* OUTPUT ARGUMENTS : */
5957 /* ------------------- */
5958 /* ERREUR: MAX Error committed by preserving only coeff of PATJAC */
5959 /* of indices from 0 to NEWDGU by U and from 0 to NEWDGV by V */
5960 /* PLUS the already calculated error. */
5961 /* NEWDGU: Min. Degree by U such as the square of approximation */
5962 /* could check the tolerance. There is always NEWDGU >= MINDGU >= 0. */
5963 /* NEWDGV: Min. Degree by V such as the square of approximation */
5964 /* could check the tolerance. There is always NEWDGV >= MINDGV >= 0. */
5965
5966
5967 /* COMMONS USED : */
5968 /* ---------------- */
5969
5970 /* REFERENCES CALLED : */
5971 /* --------------------- */
5972
5973 /* DESCRIPTION/NOTES/LIMITATIONS : */
5974 /* ----------------------------------- */
5975 /* Table PATJAC is the place of storage of coeff. Cij of the square of */
5976 /* approximation of F(U,V). The indices i and j show the degree */
5977 /* by U and by V of base polynoms. These polynoms have the form: */
5978
5979 /* ((1 - U*U)**(IORDRU+1)).J(i-2*(IORDRU+1)(U), where */
5980
5981 /* polynom J(i-2*(IORDU+1)(U) is the Jacobi polynom of order */
5982 /* IORDRU+1 (the same by V by replacing U u V in the expression above). */
5983
5984 /* The contribution to the error of term Cij when it is */
5985 /* removed from PATJAC is increased by: */
5986
5987 /* DABS(Cij)*XMAXJU(i-2*(IORDRU+1))*XMAXJV(J-2*(IORDRV+1)) where */
5988
5989 /* XMAXJU(i-2*(IORDRU+1) = ((1 - U*U)**(IORDRU+1)).J(i-2*(IORDRU+1)(U),
5990 */
5991 /* XMAXJV(i-2*(IORDRV+1) = ((1 - V*V)**(IORDRV+1)).J(j-2*(IORDRV+1)(V).
5992 */
5993
5994 /* > */
5995 /* **********************************************************************
5996 */
5997 /* Name of the routine */
5998
5999
6000 /* ----------------------------- Initialisations ------------------------
6001 */
6002
6003 /* Parameter adjustments */
6004 --vecerr;
6005 patjac_dim1 = *ndjacu + 1;
6006 patjac_dim2 = *ndjacv + 1;
6007 patjac_offset = patjac_dim1 * patjac_dim2;
6008 patjac -= patjac_offset;
6009
6010 /* Function Body */
6011 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
6012 if (ldbg) {
6013 AdvApp2Var_SysBase::mgenmsg_("MMA2ER2", 7L);
6014 }
6015
6016 i2rdu = (*iordru + 1) << 1;
6017 i2rdv = (*iordrv + 1) << 1;
6018 nu = *maxdgu;
6019 nv = *maxdgv;
6020
6021 /* **********************************************************************
6022 */
6023 /* -------------------- Cutting of oefficients ------------------------
6024 */
6025 /* **********************************************************************
6026 */
6027
6028 L1001:
6029
6030 /* ------------------- Calculate the increment of max error --------------- */
6031 /* ----- during the removal of coeff. of indices from MINDGU to MAXDGU ------ */
6032 /* ---------------- by U, the degree by V is fixed to NV -----------------
6033 */
6034
6035 bid0 = 0.;
6036 if (nv > *mindgv) {
6037 bid0 = xmaxjv[nv - i2rdv];
6038 i__1 = *ndimen;
6039 for (nd = 1; nd <= i__1; ++nd) {
6040 bid1 = 0.;
6041 i__2 = nu;
6042 for (ii = i2rdu; ii <= i__2; ++ii) {
6043 bid1 += (d__1 = patjac[ii + (nv + nd * patjac_dim2) *
6044 patjac_dim1], advapp_abs(d__1)) * xmaxju[ii - i2rdu] * bid0;
6045 /* L200: */
6046 }
6047 vecerr[nd] = bid1;
6048 /* L100: */
6049 }
6050 } else {
6051 vecerr[1] = *epmscut * 2;
6052 }
6053 errnv = AdvApp2Var_MathBase::mzsnorm_(ndimen, &vecerr[1]);
6054
6055 /* ------------------- Calculate the increment of max error --------------- */
6056 /* ----- during the removal of coeff. of indices from MINDGV to MAXDGV ------ */
6057 /* ---------------- by V, the degree by U is fixed to NU -----------------
6058 */
6059
6060 bid0 = 0.;
6061 if (nu > *mindgu) {
6062 bid0 = xmaxju[nu - i2rdu];
6063 i__1 = *ndimen;
6064 for (nd = 1; nd <= i__1; ++nd) {
6065 bid1 = 0.;
6066 i__2 = nv;
6067 for (jj = i2rdv; jj <= i__2; ++jj) {
6068 bid1 += (d__1 = patjac[nu + (jj + nd * patjac_dim2) *
6069 patjac_dim1], advapp_abs(d__1)) * xmaxjv[jj - i2rdv] * bid0;
6070 /* L400: */
6071 }
6072 vecerr[nd] = bid1;
6073 /* L300: */
6074 }
6075 } else {
6076 vecerr[1] = *epmscut * 2;
6077 }
6078 errnu = AdvApp2Var_MathBase::mzsnorm_(ndimen, &vecerr[1]);
6079
6080 /* ----------------------- Calculate the max error ----------------------
6081 */
6082
6083 vaux[0] = *erreur;
6084 vaux[1] = errnu;
6085 nd = 2;
6086 errnu = AdvApp2Var_MathBase::mzsnorm_(&nd, vaux);
6087 vaux[1] = errnv;
6088 errnv = AdvApp2Var_MathBase::mzsnorm_(&nd, vaux);
6089
6090 if (errnu > errnv) {
6091 if (errnv < *epmscut) {
6092 *erreur = errnv;
6093 --nv;
6094 } else {
6095 goto L2001;
6096 }
6097 } else {
6098 if (errnu < *epmscut) {
6099 *erreur = errnu;
6100 --nu;
6101 } else {
6102 goto L2001;
6103 }
6104 }
6105
6106 goto L1001;
6107
6108 /* -------------------------- Return the degrees -------------------
6109 */
6110
6111 L2001:
6112 *newdgu = advapp_max(nu,1);
6113 *newdgv = advapp_max(nv,1);
6114
6115 /* ----------------------------------- The end --------------------------
6116 */
6117
6118 if (ldbg) {
6119 AdvApp2Var_SysBase::mgsomsg_("MMA2ER2", 7L);
6120 }
6121 return 0;
6122 } /* mma2er2_ */
6123
6124 //=======================================================================
6125 //function : mma2fnc_
6126 //purpose :
6127 //=======================================================================
mma2fnc_(integer * ndimen,integer * nbsesp,integer * ndimse,doublereal * uvfonc,const AdvApp2Var_EvaluatorFunc2Var & foncnp,doublereal * tconst,integer * isofav,integer * nbroot,doublereal * rootlg,integer * iordre,integer * ideriv,integer * ndgjac,integer * nbcrmx,integer * ncflim,doublereal * epsapr,integer * ncoeff,doublereal * courbe,integer * nbcrbe,doublereal * somtab,doublereal * diftab,doublereal * contr1,doublereal * contr2,doublereal * tabdec,doublereal * errmax,doublereal * errmoy,integer * iercod)6128 int AdvApp2Var_ApproxF2var::mma2fnc_(integer *ndimen,
6129 integer *nbsesp,
6130 integer *ndimse,
6131 doublereal *uvfonc,
6132 const AdvApp2Var_EvaluatorFunc2Var& foncnp,
6133 doublereal *tconst,
6134 integer *isofav,
6135 integer *nbroot,
6136 doublereal *rootlg,
6137 integer *iordre,
6138 integer *ideriv,
6139 integer *ndgjac,
6140 integer *nbcrmx,
6141 integer *ncflim,
6142 doublereal *epsapr,
6143 integer *ncoeff,
6144 doublereal *courbe,
6145 integer *nbcrbe,
6146 doublereal *somtab,
6147 doublereal *diftab,
6148 doublereal *contr1,
6149 doublereal *contr2,
6150 doublereal *tabdec,
6151 doublereal *errmax,
6152 doublereal *errmoy,
6153 integer *iercod)
6154
6155 {
6156 integer c__8 = 8;
6157
6158 /* System generated locals */
6159 integer courbe_dim1, courbe_dim2, courbe_offset, somtab_dim1, somtab_dim2,
6160 somtab_offset, diftab_dim1, diftab_dim2, diftab_offset,
6161 contr1_dim1, contr1_dim2, contr1_offset, contr2_dim1, contr2_dim2,
6162 contr2_offset, errmax_dim1, errmax_offset, errmoy_dim1,
6163 errmoy_offset, i__1;
6164 doublereal d__1;
6165
6166 /* Local variables */
6167 integer ideb;
6168 doublereal tmil;
6169 integer ideb1, ibid1, ibid2, ncfja, ndgre, ilong,
6170 ndwrk;
6171 doublereal* wrkar = 0;
6172 doublereal* wrkar_off;
6173 integer nupil;
6174 intptr_t iofwr;
6175 doublereal uvpav[4] /* was [2][2] */;
6176 integer nd, ii;
6177 integer ibb;
6178 integer ier = 0;
6179 doublereal uv11[4] /* was [2][2] */;
6180 integer ncb1;
6181 doublereal eps3;
6182 integer isz1, isz2, isz3, isz4, isz5;
6183 intptr_t ipt1, ipt2, ipt3, ipt4,iptt, jptt;
6184
6185 /* **********************************************************************
6186 */
6187
6188 /* FUNCTION : */
6189 /* ---------- */
6190 /* Approximation of a limit of non polynomial function F(u,v) */
6191 /* (in the space of dimension NDIMEN) by SEVERAL */
6192 /* polynomial curves, by the method of least squares. The parameter of the function is preserved. */
6193
6194 /* KEYWORDS : */
6195 /* ----------- */
6196 /* TOUS, AB_SPECIFI :: FONCTION&,EXTREMITE&, APPROXIMATION, &COURBE. */
6197
6198 /* INPUT ARGUMENTS : */
6199 /* ----------------- */
6200 /* NDIMEN: Total Dimension of the space (sum of dimensions */
6201 /* of sub-spaces) */
6202 /* NBSESP: Number of "independent" sub-spaces. */
6203 /* NDIMSE: Table of dimensions of sub-spaces. */
6204 /* UVFONC: Limits of the interval (a,b)x(c,d) of definition of the */
6205 /* function to be approached by U (UVFONC(*,1) contains (a,b)) */
6206 /* and by V (UVFONC(*,2) contains (c,d)). */
6207 /* FONCNP: External function of position on the non polynomial function to be approached. */
6208 /* TCONST: Value of isoparameter of F(u,v) to be discretized. */
6209 /* ISOFAV: Type of chosen iso, = 1, shose that discretization is with u */
6210 /* fixed; = 2, shows that v is fixed. */
6211 /* NBROOT: Nb of points of discretisation of the iso, extremities not included. */
6212 /* ROOTLG: Table of roots of the polynom of Legendre defined on */
6213 /* (-1,1), of degree NBROOT. */
6214 /* IORDRE: Order of constraint at the extremities of the limit */
6215 /* -1 = no constraints, */
6216 /* 0 = constraints of passage to limits (i.e. C0), */
6217 /* 1 = C0 + constraints of 1st derivatives (i.e. C1), */
6218 /* 2 = C1 + constraints of 2nd derivatives (i.e. C2). */
6219 /* IDERIV: Order of derivative of the limit. */
6220 /* NDGJAC: Degree of serial development to be used for calculation in */
6221 /* the Jacobi base. */
6222 /* NBCRMX: Max Nb of curves to be created. */
6223 /* NCFLIM: Max Nb of coeff of the polynomial curve */
6224 /* of approximation (should be above or equal to */
6225 /* 2*IORDRE+2 and below or equal to 50). */
6226 /* EPSAPR: Table of required errors of approximation */
6227 /* sub-space by sub-space. */
6228
6229 /* OUTPUT ARGUMENTS : */
6230 /* ------------------- */
6231 /* NCOEFF: Number of significative coeff of calculated curves. */
6232 /* COURBE: Table of coeff. of calculated polynomial curves. */
6233 /* Should be dimensioned in (NCFLIM,NDIMEN,NBCRMX). */
6234 /* These curves are ALWAYS parametrized in (-1,1). */
6235 /* NBCRBE: Nb of calculated curves. */
6236 /* SOMTAB: For F defined on (-1,1) (otherwise rescale the */
6237 /* parameters), this is the table of sums F(u,vj) + F(u,-vj)
6238 */
6239 /* if ISOFAV = 1 (and IDERIV=0, otherwise the derivatives */
6240 /* by u of order IDERIV are taken) or sumes F(ui,v) + F(-ui,v) if */
6241 /* ISOFAV = 2 (and IDERIV=0, otherwise the derivatives by */
6242 /* v of order IDERIV are taken). */
6243 /* DIFTAB: For F defined on (-1,1) (otherwise rescale the */
6244 /* parameters), this is the table of sums F(u,vj) - F(u,-vj)
6245 */
6246 /* if ISOFAV = 1 (and IDERIV=0, otherwise the derivatives */
6247 /* by u of order IDERIV are taken) or sumes F(ui,v) + F(-ui,v) if */
6248 /* ISOFAV = 2 (and IDERIV=0, otherwise the derivatives by */
6249 /* v of order IDERIV are taken). */
6250 /* CONTR1: Contains the coordinates of the left extremity of the iso */
6251 /* and of its derivatives till order IORDRE */
6252 /* CONTR2: Contains the coordinates of the right extremity of the iso */
6253 /* and of its derivatives till order IORDRE */
6254 /* TABDEC: Table of NBCRBE+1 parameters of cut of UVFONC(1:2,1)
6255 */
6256 /* if ISOFAV=2, or of UVFONC(1:2,2) if ISOFAV=1. */
6257 /* ERRMAX: Table of MAX errors (sub-space by sub-space) */
6258 /* committed in the approximation of FONCNP by NBCRBE curves. */
6259 /* ERRMOY: Table of AVERAGE errors (sub-space by sub-space) */
6260 /* committed in the approximation of FONCNP by NBCRBE curves. */
6261 /* IERCOD: Error code: */
6262 /* -1 = ERRMAX > EPSAPR for at least one sub-space. */
6263 /* (the resulting curves of at least mathematic degree NCFLIM-1 */
6264 /* are calculated). */
6265 /* 0 = Everything is ok. */
6266 /* 1 = Pb of incoherence of inputs. */
6267 /* 10 = Pb of calculation of the interpolation of constraints. */
6268 /* 13 = Pb in the dynamic allocation. */
6269 /* 33 = Pb in the data recuperation from block data */
6270 /* of coeff. of integration by GAUSS method. */
6271 /* >100 Pb in the evaluation of FONCNP, the returned error code */
6272 /* is equal to the error code of FONCNP + 100. */
6273
6274 /* COMMONS USED : */
6275 /* ---------------- */
6276
6277 /* REFERENCES CALLED : */
6278 /* ----------------------- */
6279
6280 /* DESCRIPTION/NOTES/LIMITATIONS : */
6281 /* ----------------------------------- */
6282 /* --> The approximation part is done in the space of dimension */
6283 /* NDIMEN (the sum of dimensions of sub-spaces). For example : */
6284 /* If NBSESP=2 and NDIMSE(1)=3, NDIMSE(2)=2, there is smoothing with */
6285 /* NDIMEN=5. The result (in COURBE(NDIMEN,NCOEFF,i) ), will be */
6286 /* composed of the result of smoothing of 3D function in */
6287 /* COURBE(1:3,1:NCOEFF,i) and of smoothing of 2D function in */
6288 /* COURBE(4:5,1:NCOEFF,i). */
6289
6290 /* --> Routine FONCNP should be declared EXTERNAL in the program */
6291 /* calling MMA2FNC. */
6292
6293 /* --> Function FONCNP, declared externally, should be declared */
6294 /* IMPERATIVELY in form : */
6295 /* SUBROUTINE FONCNP(NDIMEN,UINTFN,VINTFN,IIUOUV,TCONST,NBPTAB */
6296 /* ,TTABLE,IDERIU,IDERIV,IERCOD) */
6297 /* where the input arguments are : */
6298 /* - NDIMEN is integer defined as the sum of dimensions of */
6299 /* sub-spaces (i.e. total dimension of the problem). */
6300 /* - UINTFN(2) is a table of 2 reals containing the interval */
6301 /* by u where the function to be approximated is defined */
6302 /* (so it is equal to UIFONC). */
6303 /* - VINTFN(2) is a table of 2 reals containing the interval */
6304 /* by v where the function to be approximated is defined */
6305 /* (so it is equal to VIFONC). */
6306 /* - IIUOUV, shows that the points to be calculated have a constant U */
6307 /* (IIUOUV=1) or a constant V (IIUOUV=2). */
6308 /* - TCONST, real, value of the fixed discretisation parameter. Takes values */
6309 /* in (UINTFN(1),UINTFN(2)) if IIUOUV=1, */
6310 /* or in (VINTFN(1),VINTFN(2)) if IIUOUV=2. */
6311 /* - NBPTAB, the nb of point of discretisation following the free variable */
6312 /* : V if IIUOUV=1 or U if IIUOUV = 2. */
6313 /* - TTABLE, Table of NBPTAB parametres of discretisation. . */
6314 /* - IDERIU, integer, takes values between 0 (position) */
6315 /* and IORDREU (partial derivative of the function by u */
6316 /* of order IORDREU if IORDREU > 0). */
6317 /* - IDERIV, integer, takes values between 0 (position) */
6318 /* and IORDREV (partial derivative of the function by v */
6319 /* of order IORDREV if IORDREV > 0). */
6320 /* and the output arguments are : */
6321 /* - FPNTAB(NDIMEN,NBPTAB) contains, at output, the table of */
6322 /* NBPTAB points calculated in FONCNP. */
6323 /* - IERCOD is, at output the error code of FONCNP. This code */
6324 /* (integer) should be strictly positive if there is a problem. */
6325
6326 /* The input arguments SHOULD NOT BE modified under FONCNP.
6327 */
6328
6329 /* --> If IERCOD=-1, the required precision can't be reached (ERRMAX */
6330 /* is above EPSAPR on at least one sub-space), but
6331 */
6332 /* one gives the best possible result for NCFLIM and EPSAPR */
6333 /* chosen by the user. In this case (and for IERCOD=0), there is a solution. */
6334
6335 /* > */
6336 /* **********************************************************************
6337 */
6338 /* Name of the routine */
6339
6340 /* Parameter adjustments */
6341 --epsapr;
6342 --ndimse;
6343 uvfonc -= 3;
6344 --rootlg;
6345 errmoy_dim1 = *nbsesp;
6346 errmoy_offset = errmoy_dim1 + 1;
6347 errmoy -= errmoy_offset;
6348 errmax_dim1 = *nbsesp;
6349 errmax_offset = errmax_dim1 + 1;
6350 errmax -= errmax_offset;
6351 contr2_dim1 = *ndimen;
6352 contr2_dim2 = *iordre + 2;
6353 contr2_offset = contr2_dim1 * (contr2_dim2 + 1) + 1;
6354 contr2 -= contr2_offset;
6355 contr1_dim1 = *ndimen;
6356 contr1_dim2 = *iordre + 2;
6357 contr1_offset = contr1_dim1 * (contr1_dim2 + 1) + 1;
6358 contr1 -= contr1_offset;
6359 diftab_dim1 = *nbroot / 2 + 1;
6360 diftab_dim2 = *ndimen;
6361 diftab_offset = diftab_dim1 * (diftab_dim2 + 1);
6362 diftab -= diftab_offset;
6363 somtab_dim1 = *nbroot / 2 + 1;
6364 somtab_dim2 = *ndimen;
6365 somtab_offset = somtab_dim1 * (somtab_dim2 + 1);
6366 somtab -= somtab_offset;
6367 --ncoeff;
6368 courbe_dim1 = *ncflim;
6369 courbe_dim2 = *ndimen;
6370 courbe_offset = courbe_dim1 * (courbe_dim2 + 1) + 1;
6371 courbe -= courbe_offset;
6372 AdvApp2Var_SysBase anAdvApp2Var_SysBase;
6373
6374 /* Function Body */
6375 ibb = AdvApp2Var_SysBase::mnfndeb_();
6376 if (ibb >= 1) {
6377 AdvApp2Var_SysBase::mgenmsg_("MMA2FNC", 7L);
6378 }
6379 *iercod = 0;
6380 iofwr = 0;
6381
6382 /* ---------------- Set to zero the coefficients of CURVE --------------
6383 */
6384
6385 ilong = *ndimen * *ncflim * *nbcrmx;
6386 AdvApp2Var_SysBase::mvriraz_(&ilong, &courbe[courbe_offset]);
6387
6388 /* **********************************************************************
6389 */
6390 /* -------------------------- Checking of entries ------------------
6391 */
6392 /* **********************************************************************
6393 */
6394
6395 AdvApp2Var_MathBase::mmveps3_(&eps3);
6396 if ((d__1 = uvfonc[4] - uvfonc[3], advapp_abs(d__1)) < eps3) {
6397 goto L9100;
6398 }
6399 if ((d__1 = uvfonc[6] - uvfonc[5], advapp_abs(d__1)) < eps3) {
6400 goto L9100;
6401 }
6402
6403 uv11[0] = -1.;
6404 uv11[1] = 1.;
6405 uv11[2] = -1.;
6406 uv11[3] = 1.;
6407
6408 /* ********************************************************************** */
6409 /* ------------- Preparation of parameters of discretisation ----------- */
6410 /* **********************************************************************
6411 */
6412
6413 /* -- Allocation of a table of parameters and points of discretisation -- */
6414 /* --> For the parameters of discretisation. */
6415 isz1 = *nbroot + 2;
6416 /* --> For the points of discretisation in MMA1FDI and MMA1CDI and
6417 */
6418 /* the auxiliary curve for MMAPCMP */
6419 ibid1 = *ndimen * (*nbroot + 2);
6420 ibid2 = ((*iordre + 1) << 1) * *nbroot;
6421 isz2 = advapp_max(ibid1,ibid2);
6422 ibid1 = (((*ncflim - 1) / 2 + 1) << 1) * *ndimen;
6423 isz2 = advapp_max(ibid1,isz2);
6424 /* --> To return the polynoms of hermit. */
6425 isz3 = ((*iordre + 1) << 2) * (*iordre + 1);
6426 /* --> For the Gauss coeff. of integration. */
6427 isz4 = (*nbroot / 2 + 1) * (*ndgjac + 1 - ((*iordre + 1) << 1));
6428 /* --> For the coeff of the curve in the base of Jacobi */
6429 isz5 = (*ndgjac + 1) * *ndimen;
6430
6431 ndwrk = isz1 + isz2 + isz3 + isz4 + isz5;
6432 anAdvApp2Var_SysBase.mcrrqst_(&c__8, &ndwrk, wrkar, &iofwr, &ier);
6433 wrkar_off = reinterpret_cast<double*>(iofwr * sizeof(double));
6434 if (ier > 0) {
6435 goto L9013; }
6436 /* --> For the parameters of discretisation (NBROOT+2 extremities). */
6437 /* --> For the points of discretisation FPNTAB(NDIMEN,NBROOT+2), */
6438 /* FPNTAB(NBROOT,2*(IORDRE+1)) and for WRKAR of MMAPCMP. */
6439 ipt1 = isz1;
6440 /* --> For the polynoms of Hermit */
6441 ipt2 = ipt1 + isz2;
6442 /* --> For the Gauss coeff of integration. */
6443 ipt3 = ipt2 + isz3;
6444 /* --> For the curve in Jacobi. */
6445 ipt4 = ipt3 + isz4;
6446
6447 /* ------------------ Initialisation of management of cuts ---------
6448 */
6449
6450 if (*isofav == 1) {
6451 uvpav[0] = uvfonc[3];
6452 uvpav[1] = uvfonc[4];
6453 tabdec[0] = uvfonc[5];
6454 tabdec[1] = uvfonc[6];
6455 } else if (*isofav == 2) {
6456 tabdec[0] = uvfonc[3];
6457 tabdec[1] = uvfonc[4];
6458 uvpav[2] = uvfonc[5];
6459 uvpav[3] = uvfonc[6];
6460 } else {
6461 goto L9100;
6462 }
6463
6464 nupil = 1;
6465 *nbcrbe = 0;
6466
6467 /* **********************************************************************
6468 */
6469 /* APPROXIMATION WITH CUTS */
6470 /* **********************************************************************
6471 */
6472
6473 L1000:
6474 /* --> When the top is reached, this is the end ! */
6475 if (nupil - *nbcrbe == 0) {
6476 goto L9900;
6477 }
6478 ncb1 = *nbcrbe + 1;
6479 if (*isofav == 1) {
6480 uvpav[2] = tabdec[*nbcrbe];
6481 uvpav[3] = tabdec[*nbcrbe + 1];
6482 } else if (*isofav == 2) {
6483 uvpav[0] = tabdec[*nbcrbe];
6484 uvpav[1] = tabdec[*nbcrbe + 1];
6485 } else {
6486 goto L9100;
6487 }
6488
6489 /* -------------------- Normalization of parameters -------------------- */
6490
6491 mma1nop_(nbroot, &rootlg[1], uvpav, isofav, wrkar_off, &ier);
6492 if (ier > 0) {
6493 goto L9100;
6494 }
6495
6496 /* -------------------- Discretisation of FONCNP ------------------------ */
6497
6498 mma1fdi_(ndimen, uvpav, foncnp, isofav, tconst, nbroot, wrkar_off,
6499 iordre, ideriv, &wrkar_off[ipt1], &somtab[(ncb1 * somtab_dim2 + 1) *
6500 somtab_dim1], &diftab[(ncb1 * diftab_dim2 + 1) * diftab_dim1], &
6501 contr1[(ncb1 * contr1_dim2 + 1) * contr1_dim1 + 1], &contr2[(ncb1
6502 * contr2_dim2 + 1) * contr2_dim1 + 1], iercod);
6503 if (*iercod > 0) {
6504 goto L9900;
6505 }
6506
6507 /* -----------Cut the discretisation of constraints ------------*/
6508
6509 if (*iordre >= 0) {
6510 mma1cdi_(ndimen, nbroot, &rootlg[1], iordre, &contr1[(ncb1 *
6511 contr1_dim2 + 1) * contr1_dim1 + 1], &contr2[(ncb1 *
6512 contr2_dim2 + 1) * contr2_dim1 + 1], &somtab[(ncb1 *
6513 somtab_dim2 + 1) * somtab_dim1], &diftab[(ncb1 * diftab_dim2
6514 + 1) * diftab_dim1], &wrkar_off[ipt1], &wrkar_off[ipt2], &ier);
6515 if (ier > 0) {
6516 goto L9100;
6517 }
6518 }
6519
6520 /* **********************************************************************
6521 */
6522 /* -------------------- Calculate the curve of approximation -------------
6523 */
6524 /* **********************************************************************
6525 */
6526
6527 mma1jak_(ndimen, nbroot, iordre, ndgjac, &somtab[(ncb1 * somtab_dim2 + 1)
6528 * somtab_dim1], &diftab[(ncb1 * diftab_dim2 + 1) * diftab_dim1],
6529 &wrkar_off[ipt3], &wrkar_off[ipt4], &ier);
6530 if (ier > 0) {
6531 goto L9100;
6532 }
6533
6534 /* **********************************************************************
6535 */
6536 /* ---------------- Add polynom of interpolation -------------------
6537 */
6538 /* **********************************************************************
6539 */
6540
6541 if (*iordre >= 0) {
6542 mma1cnt_(ndimen, iordre, &contr1[(ncb1 * contr1_dim2 + 1) *
6543 contr1_dim1 + 1], &contr2[(ncb1 * contr2_dim2 + 1) *
6544 contr2_dim1 + 1], &wrkar_off[ipt2], ndgjac, &wrkar_off[ipt4]);
6545 }
6546
6547 /* **********************************************************************
6548 */
6549 /* --------------- Calculate Max and Average error ----------------------
6550 */
6551 /* **********************************************************************
6552 */
6553
6554 mma1fer_(ndimen, nbsesp, &ndimse[1], iordre, ndgjac, &wrkar_off[ipt4], ncflim,
6555 &epsapr[1], &wrkar_off[ipt1], &errmax[ncb1 * errmax_dim1 + 1], &
6556 errmoy[ncb1 * errmoy_dim1 + 1], &ncoeff[ncb1], &ier);
6557 if (ier > 0) {
6558 goto L9100;
6559 }
6560
6561 if (ier == 0 || (ier == -1 && nupil == *nbcrmx)) {
6562
6563 /* ******************************************************************
6564 **** */
6565 /* ----------------------- Compression du resultat ------------------
6566 ---- */
6567 /* ******************************************************************
6568 **** */
6569
6570 if (ier == -1) {
6571 *iercod = -1;
6572 }
6573 ncfja = *ndgjac + 1;
6574 /* -> Compression of result in WRKAR(IPT2) */
6575 /*pkv f*/
6576 /*
6577 AdvApp2Var_MathBase::mmapcmp_(ndimen,
6578 &ncfja, &ncoeff[ncb1], &wrkar[ipt5], &wrkar[ipt2]);
6579 */
6580 AdvApp2Var_MathBase::mmapcmp_((integer*)ndimen,
6581 &ncfja,
6582 &ncoeff[ncb1],
6583 &wrkar_off[ipt4],
6584 &wrkar_off[ipt1]);
6585 /*pkv t*/
6586 ilong = *ndimen * *ncflim;
6587 AdvApp2Var_SysBase::mvriraz_(&ilong, &wrkar_off[ipt4]);
6588 /* -> Passage to canonic base (-1,1) (result in WRKAR(IPT5)).
6589 */
6590 ndgre = ncoeff[ncb1] - 1;
6591 i__1 = *ndimen;
6592 for (nd = 1; nd <= i__1; ++nd) {
6593 iptt = ipt1 + ((nd - 1) << 1) * (ndgre / 2 + 1);
6594 jptt = ipt4 + (nd - 1) * ncoeff[ncb1];
6595 AdvApp2Var_MathBase::mmjacan_(iordre, &ndgre, &wrkar_off[iptt], &wrkar_off[jptt]);
6596 /* L400: */
6597 }
6598
6599 /* -> Store the calculated curve */
6600 ibid1 = 1;
6601 AdvApp2Var_MathBase::mmfmca8_(&ncoeff[ncb1], ndimen, &ibid1, ncflim, ndimen, &ibid1,
6602 &wrkar_off[ipt4], &courbe[(ncb1 * courbe_dim2 + 1) * courbe_dim1 +
6603 1]);
6604
6605 /* -> Before normalization of constraints on (-1,1), recalculate */
6606 /* the true constraints. */
6607 i__1 = *iordre;
6608 for (ii = 0; ii <= i__1; ++ii) {
6609 mma1noc_(uv11, ndimen, &ii, &contr1[(ii + 1 + ncb1 * contr1_dim2)
6610 * contr1_dim1 + 1], uvpav, isofav, ideriv, &contr1[(ii +
6611 1 + ncb1 * contr1_dim2) * contr1_dim1 + 1]);
6612 mma1noc_(uv11, ndimen, &ii, &contr2[(ii + 1 + ncb1 * contr2_dim2)
6613 * contr2_dim1 + 1], uvpav, isofav, ideriv, &contr2[(ii +
6614 1 + ncb1 * contr2_dim2) * contr2_dim1 + 1]);
6615 /* L200: */
6616 }
6617 ii = 0;
6618 ibid1 = (*nbroot / 2 + 1) * *ndimen;
6619 mma1noc_(uv11, &ibid1, &ii, &somtab[(ncb1 * somtab_dim2 + 1) *
6620 somtab_dim1], uvpav, isofav, ideriv, &somtab[(ncb1 *
6621 somtab_dim2 + 1) * somtab_dim1]);
6622 mma1noc_(uv11, &ibid1, &ii, &diftab[(ncb1 * diftab_dim2 + 1) *
6623 diftab_dim1], uvpav, isofav, ideriv, &diftab[(ncb1 *
6624 diftab_dim2 + 1) * diftab_dim1]);
6625 ii = 0;
6626 i__1 = *ndimen;
6627 for (nd = 1; nd <= i__1; ++nd) {
6628 mma1noc_(uv11, &ncoeff[ncb1], &ii, &courbe[(nd + ncb1 *
6629 courbe_dim2) * courbe_dim1 + 1], uvpav, isofav, ideriv, &
6630 courbe[(nd + ncb1 * courbe_dim2) * courbe_dim1 + 1]);
6631 /* L210: */
6632 }
6633
6634 /* -> Update the nb of already created curves */
6635 ++(*nbcrbe);
6636
6637 /* -> ...otherwise try to cut the current interval in 2... */
6638 } else {
6639 tmil = (tabdec[*nbcrbe + 1] + tabdec[*nbcrbe]) / 2.;
6640 ideb = *nbcrbe + 1;
6641 ideb1 = ideb + 1;
6642 ilong = (nupil - *nbcrbe) << 3;
6643 AdvApp2Var_SysBase::mcrfill_(&ilong, &tabdec[ideb],&tabdec[ideb1]);
6644 tabdec[ideb] = tmil;
6645 ++nupil;
6646 }
6647
6648 /* ---------- Make approximation of the rest -----------
6649 */
6650
6651 goto L1000;
6652
6653 /* --------------------- Return code of error -----------------
6654 */
6655 /* --> Pb with dynamic allocation */
6656 L9013:
6657 *iercod = 13;
6658 goto L9900;
6659 /* --> Inputs incoherent. */
6660 L9100:
6661 *iercod = 1;
6662 goto L9900;
6663
6664 /* -------------------------- Dynamic desallocation -------------------
6665 */
6666
6667 L9900:
6668 if (iofwr != 0) {
6669 anAdvApp2Var_SysBase.mcrdelt_(&c__8, &ndwrk, wrkar, &iofwr, &ier);
6670 }
6671 if (ier > 0) {
6672 *iercod = 13;
6673 }
6674 goto L9999;
6675
6676 /* ------------------------------ The end -------------------------------
6677 */
6678
6679 L9999:
6680 if (*iercod != 0) {
6681 AdvApp2Var_SysBase::maermsg_("MMA2FNC", iercod, 7L);
6682 }
6683 if (ibb >= 2) {
6684 AdvApp2Var_SysBase::mgsomsg_("MMA2FNC", 7L);
6685 }
6686 return 0;
6687 } /* mma2fnc_ */
6688
6689 //=======================================================================
6690 //function : mma2fx6_
6691 //purpose :
6692 //=======================================================================
mma2fx6_(integer * ncfmxu,integer * ncfmxv,integer * ndimen,integer * nbsesp,integer * ndimse,integer * nbupat,integer * nbvpat,integer * iordru,integer * iordrv,doublereal * epsapr,doublereal * epsfro,doublereal * patcan,doublereal * errmax,integer * ncoefu,integer * ncoefv)6693 int AdvApp2Var_ApproxF2var::mma2fx6_(integer *ncfmxu,
6694 integer *ncfmxv,
6695 integer *ndimen,
6696 integer *nbsesp,
6697 integer *ndimse,
6698 integer *nbupat,
6699 integer *nbvpat,
6700 integer *iordru,
6701 integer *iordrv,
6702 doublereal *epsapr,
6703 doublereal *epsfro,
6704 doublereal *patcan,
6705 doublereal *errmax,
6706 integer *ncoefu,
6707 integer *ncoefv)
6708
6709 {
6710 /* System generated locals */
6711 integer epsfro_dim1, epsfro_offset, patcan_dim1, patcan_dim2, patcan_dim3,
6712 patcan_dim4, patcan_offset, errmax_dim1, errmax_dim2,
6713 errmax_offset, ncoefu_dim1, ncoefu_offset, ncoefv_dim1,
6714 ncoefv_offset, i__1, i__2, i__3, i__4, i__5;
6715 doublereal d__1, d__2;
6716
6717 /* Local variables */
6718 integer idim, ncfu, ncfv, id, ii, nd, jj, ku, kv, ns, ibb;
6719 doublereal bid;
6720 doublereal tol;
6721
6722 /* **********************************************************************
6723 */
6724
6725 /* FUNCTION : */
6726 /* ---------- */
6727 /* Reduction of degree when the squares are the squares of constraints. */
6728
6729 /* KEYWORDS : */
6730 /* ----------- */
6731 /* TOUS,AB_SPECIFI::CARREAU&,REDUCTION,&CARREAU */
6732
6733 /* INPUT ARGUMENTS : */
6734 /* ------------------ */
6735 /* NCFMXU: Max Nb of coeff by u of solution P(u,v) (table */
6736 /* PATCAN). This argument serves only to declare the size of this table. */
6737 /* NCFMXV: Max Nb of coeff by v of solution P(u,v) (table */
6738 /* PATCAN). This argument serves only to declare the size of this table. */
6739 /* NDIMEN: Total dimension of the space where the processed function */
6740 /* takes its values.(sum of dimensions of sub-spaces) */
6741 /* NBSESP: Nb of independent sub-spaces where the errors are measured. */
6742 /* NDIMSE: Table of dimensions of NBSESP sub-spaces. */
6743 /* NBUPAT: Nb of square solution by u. */
6744 /* NBVPAT: Nb of square solution by v. */
6745 /* IORDRU: Order of constraint imposed at the extremities of iso-V */
6746 /* = 0, the extremities of iso-V are calculated */
6747 /* = 1, additionally the 1st derivative in the direction of iso-V is calculated */
6748 /* = 2, additionally the 2nd derivative in the direction of iso-V is calculated */
6749 /* IORDRV: Ordre de contrainte impose aux extremites de l'iso-U */
6750 /* = 0, on calcule les extremites de l'iso-U. */
6751 /* = 1, additionally the 1st derivative in the direction of iso-U is calculated */
6752 /* = 2, additionally the 2nd derivative in the direction of iso-U is calculated */
6753 /* EPSAPR: Table of imposed precisions, sub-space by sub-space. */
6754 /* EPSFRO: Table of imposed precisions, sub-space by sub-space on the limits of squares. */
6755 /* PATCAN: Table of coeff. in the canonic base of squares P(u,v) calculated for (u,v) in (-1,1). */
6756 /* ERRMAX: Table of MAX errors (sub-space by sub-space) */
6757 /* committed in the approximation of F(u,v) by P(u,v). */
6758 /* NCOEFU: Table of Nb of significative coeffs. by u of calculated squares. */
6759 /* NCOEFV: Table of Nb of significative coeffs. by v of calculated squares. */
6760
6761 /* OUTPUT ARGUMENTS : */
6762 /* ------------------- */
6763 /* NCOEFU: Table of Nb of significative coeffs. by u of calculated squares. */
6764 /* NCOEFV: Table of Nb of significative coeffs. by v of calculated squares. */
6765
6766 /* COMMONS USED : */
6767 /* ---------------- */
6768
6769 /* REFERENCES CALLED : */
6770 /* --------------------- */
6771
6772 /* DESCRIPTION/NOTES/LIMITATIONS : */
6773 /* ------------------------------- */
6774 /* > */
6775 /* **********************************************************************
6776 */
6777
6778 /* Name of the routine */
6779
6780
6781 /* Parameter adjustments */
6782 epsfro_dim1 = *nbsesp;
6783 epsfro_offset = epsfro_dim1 * 5 + 1;
6784 epsfro -= epsfro_offset;
6785 --epsapr;
6786 --ndimse;
6787 ncoefv_dim1 = *nbupat;
6788 ncoefv_offset = ncoefv_dim1 + 1;
6789 ncoefv -= ncoefv_offset;
6790 ncoefu_dim1 = *nbupat;
6791 ncoefu_offset = ncoefu_dim1 + 1;
6792 ncoefu -= ncoefu_offset;
6793 errmax_dim1 = *nbsesp;
6794 errmax_dim2 = *nbupat;
6795 errmax_offset = errmax_dim1 * (errmax_dim2 + 1) + 1;
6796 errmax -= errmax_offset;
6797 patcan_dim1 = *ncfmxu;
6798 patcan_dim2 = *ncfmxv;
6799 patcan_dim3 = *ndimen;
6800 patcan_dim4 = *nbupat;
6801 patcan_offset = patcan_dim1 * (patcan_dim2 * (patcan_dim3 * (patcan_dim4
6802 + 1) + 1) + 1) + 1;
6803 patcan -= patcan_offset;
6804
6805 /* Function Body */
6806 ibb = AdvApp2Var_SysBase::mnfndeb_();
6807 if (ibb >= 3) {
6808 AdvApp2Var_SysBase::mgenmsg_("MMA2FX6", 7L);
6809 }
6810
6811
6812 i__1 = *nbvpat;
6813 for (jj = 1; jj <= i__1; ++jj) {
6814 i__2 = *nbupat;
6815 for (ii = 1; ii <= i__2; ++ii) {
6816 ncfu = ncoefu[ii + jj * ncoefu_dim1];
6817 ncfv = ncoefv[ii + jj * ncoefv_dim1];
6818
6819 /* ********************************************************************** */
6820 /* -------------------- Reduction of degree by U ------------------------- */
6821 /* ********************************************************************** */
6822
6823 L200:
6824 if (ncfu <= (*iordru + 1) << 1 && ncfu > 2) {
6825
6826 idim = 0;
6827 i__3 = *nbsesp;
6828 for (ns = 1; ns <= i__3; ++ns) {
6829 tol = epsapr[ns];
6830 /* Computing MIN */
6831 d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 9];
6832 tol = advapp_min(d__1,d__2);
6833 /* Computing MIN */
6834 d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 10];
6835 tol = advapp_min(d__1,d__2);
6836 /* Computing MIN */
6837 d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 11];
6838 tol = advapp_min(d__1,d__2);
6839 /* Computing MIN */
6840 d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 12];
6841 tol = advapp_min(d__1,d__2);
6842 if (ii == 1 || ii == *nbupat || jj == 1 || jj == *nbvpat)
6843 {
6844 /* Computing MIN */
6845 d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 5];
6846 tol = advapp_min(d__1,d__2);
6847 /* Computing MIN */
6848 d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 6];
6849 tol = advapp_min(d__1,d__2);
6850 /* Computing MIN */
6851 d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 7];
6852 tol = advapp_min(d__1,d__2);
6853 /* Computing MIN */
6854 d__1 = tol, d__2 = epsfro[ns + (epsfro_dim1 << 3)];
6855 tol = advapp_min(d__1,d__2);
6856 }
6857 bid = 0.;
6858
6859 i__4 = ndimse[ns];
6860 for (nd = 1; nd <= i__4; ++nd) {
6861 id = idim + nd;
6862 i__5 = ncfv;
6863 for (kv = 1; kv <= i__5; ++kv) {
6864 bid += (d__1 = patcan[ncfu + (kv + (id + (ii + jj
6865 * patcan_dim4) * patcan_dim3) *
6866 patcan_dim2) * patcan_dim1], advapp_abs(d__1));
6867 /* L230: */
6868 }
6869 /* L220: */
6870 }
6871
6872 if (bid > tol * 1e-6 || bid > errmax[ns + (ii + jj *
6873 errmax_dim2) * errmax_dim1]) {
6874 goto L300;
6875 }
6876 idim += ndimse[ns];
6877 /* L210: */
6878 }
6879
6880 --ncfu;
6881 goto L200;
6882 }
6883
6884 /* ********************************************************************** */
6885 /* -------------------- Reduction of degree by V ------------------------- */
6886 /* ********************************************************************** */
6887
6888 L300:
6889 if (ncfv <= (*iordrv + 1) << 1 && ncfv > 2) {
6890
6891 idim = 0;
6892 i__3 = *nbsesp;
6893 for (ns = 1; ns <= i__3; ++ns) {
6894 tol = epsapr[ns];
6895 /* Computing MIN */
6896 d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 9];
6897 tol = advapp_min(d__1,d__2);
6898 /* Computing MIN */
6899 d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 10];
6900 tol = advapp_min(d__1,d__2);
6901 /* Computing MIN */
6902 d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 11];
6903 tol = advapp_min(d__1,d__2);
6904 /* Computing MIN */
6905 d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 12];
6906 tol = advapp_min(d__1,d__2);
6907 if (ii == 1 || ii == *nbupat || jj == 1 || jj == *nbvpat)
6908 {
6909 /* Computing MIN */
6910 d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 5];
6911 tol = advapp_min(d__1,d__2);
6912 /* Computing MIN */
6913 d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 6];
6914 tol = advapp_min(d__1,d__2);
6915 /* Computing MIN */
6916 d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 7];
6917 tol = advapp_min(d__1,d__2);
6918 /* Computing MIN */
6919 d__1 = tol, d__2 = epsfro[ns + (epsfro_dim1 << 3)];
6920 tol = advapp_min(d__1,d__2);
6921 }
6922 bid = 0.;
6923
6924 i__4 = ndimse[ns];
6925 for (nd = 1; nd <= i__4; ++nd) {
6926 id = idim + nd;
6927 i__5 = ncfu;
6928 for (ku = 1; ku <= i__5; ++ku) {
6929 bid += (d__1 = patcan[ku + (ncfv + (id + (ii + jj
6930 * patcan_dim4) * patcan_dim3) *
6931 patcan_dim2) * patcan_dim1], advapp_abs(d__1));
6932 /* L330: */
6933 }
6934 /* L320: */
6935 }
6936
6937 if (bid > tol * 1e-6 || bid > errmax[ns + (ii + jj *
6938 errmax_dim2) * errmax_dim1]) {
6939 goto L400;
6940 }
6941 idim += ndimse[ns];
6942 /* L310: */
6943 }
6944
6945 --ncfv;
6946 goto L300;
6947 }
6948
6949 /* --- Return the nbs of coeff. and pass to the next square --- */
6950
6951 L400:
6952 ncoefu[ii + jj * ncoefu_dim1] = advapp_max(ncfu,2);
6953 ncoefv[ii + jj * ncoefv_dim1] = advapp_max(ncfv,2);
6954 /* L110: */
6955 }
6956 /* L100: */
6957 }
6958
6959 /* ------------------------------ The End -------------------------------
6960 */
6961
6962 if (ibb >= 3) {
6963 AdvApp2Var_SysBase::mgsomsg_("MMA2FX6", 7L);
6964 }
6965
6966 return 0 ;
6967 } /* mma2fx6_ */
6968
6969 //=======================================================================
6970 //function : mma2jmx_
6971 //purpose :
6972 //=======================================================================
mma2jmx_(integer * ndgjac,integer * iordre,doublereal * xjacmx)6973 int AdvApp2Var_ApproxF2var::mma2jmx_(integer *ndgjac,
6974 integer *iordre,
6975 doublereal *xjacmx)
6976 {
6977 /* Initialized data */
6978
6979 static doublereal xmax2[57] = { .9682458365518542212948163499456,
6980 .986013297183269340427888048593603,
6981 1.07810420343739860362585159028115,
6982 1.17325804490920057010925920756025,
6983 1.26476561266905634732910520370741,
6984 1.35169950227289626684434056681946,
6985 1.43424378958284137759129885012494,
6986 1.51281316274895465689402798226634,
6987 1.5878364329591908800533936587012,
6988 1.65970112228228167018443636171226,
6989 1.72874345388622461848433443013543,
6990 1.7952515611463877544077632304216,
6991 1.85947199025328260370244491818047,
6992 1.92161634324190018916351663207101,
6993 1.98186713586472025397859895825157,
6994 2.04038269834980146276967984252188,
6995 2.09730119173852573441223706382076,
6996 2.15274387655763462685970799663412,
6997 2.20681777186342079455059961912859,
6998 2.25961782459354604684402726624239,
6999 2.31122868752403808176824020121524,
7000 2.36172618435386566570998793688131,
7001 2.41117852396114589446497298177554,
7002 2.45964731268663657873849811095449,
7003 2.50718840313973523778244737914028,
7004 2.55385260994795361951813645784034,
7005 2.59968631659221867834697883938297,
7006 2.64473199258285846332860663371298,
7007 2.68902863641518586789566216064557,
7008 2.73261215675199397407027673053895,
7009 2.77551570192374483822124304745691,
7010 2.8177699459714315371037628127545,
7011 2.85940333797200948896046563785957,
7012 2.90044232019793636101516293333324,
7013 2.94091151970640874812265419871976,
7014 2.98083391718088702956696303389061,
7015 3.02023099621926980436221568258656,
7016 3.05912287574998661724731962377847,
7017 3.09752842783622025614245706196447,
7018 3.13546538278134559341444834866301,
7019 3.17295042316122606504398054547289,
7020 3.2099992681699613513775259670214,
7021 3.24662674946606137764916854570219,
7022 3.28284687953866689817670991319787,
7023 3.31867291347259485044591136879087,
7024 3.35411740487202127264475726990106,
7025 3.38919225660177218727305224515862,
7026 3.42390876691942143189170489271753,
7027 3.45827767149820230182596660024454,
7028 3.49230918177808483937957161007792,
7029 3.5260130200285724149540352829756,
7030 3.55939845146044235497103883695448,
7031 3.59247431368364585025958062194665,
7032 3.62524904377393592090180712976368,
7033 3.65773070318071087226169680450936,
7034 3.68992700068237648299565823810245,
7035 3.72184531357268220291630708234186 };
7036 static doublereal xmax4[55] = { 1.1092649593311780079813740546678,
7037 1.05299572648705464724876659688996,
7038 1.0949715351434178709281698645813,
7039 1.15078388379719068145021100764647,
7040 1.2094863084718701596278219811869,
7041 1.26806623151369531323304177532868,
7042 1.32549784426476978866302826176202,
7043 1.38142537365039019558329304432581,
7044 1.43575531950773585146867625840552,
7045 1.48850442653629641402403231015299,
7046 1.53973611681876234549146350844736,
7047 1.58953193485272191557448229046492,
7048 1.63797820416306624705258190017418,
7049 1.68515974143594899185621942934906,
7050 1.73115699602477936547107755854868,
7051 1.77604489805513552087086912113251,
7052 1.81989256661534438347398400420601,
7053 1.86276344480103110090865609776681,
7054 1.90471563564740808542244678597105,
7055 1.94580231994751044968731427898046,
7056 1.98607219357764450634552790950067,
7057 2.02556989246317857340333585562678,
7058 2.06433638992049685189059517340452,
7059 2.10240936014742726236706004607473,
7060 2.13982350649113222745523925190532,
7061 2.17661085564771614285379929798896,
7062 2.21280102016879766322589373557048,
7063 2.2484214321456956597803794333791,
7064 2.28349755104077956674135810027654,
7065 2.31805304852593774867640120860446,
7066 2.35210997297725685169643559615022,
7067 2.38568889602346315560143377261814,
7068 2.41880904328694215730192284109322,
7069 2.45148841120796359750021227795539,
7070 2.48374387161372199992570528025315,
7071 2.5155912654873773953959098501893,
7072 2.54704548720896557684101746505398,
7073 2.57812056037881628390134077704127,
7074 2.60882970619319538196517982945269,
7075 2.63918540521920497868347679257107,
7076 2.66919945330942891495458446613851,
7077 2.69888301230439621709803756505788,
7078 2.72824665609081486737132853370048,
7079 2.75730041251405791603760003778285,
7080 2.78605380158311346185098508516203,
7081 2.81451587035387403267676338931454,
7082 2.84269522483114290814009184272637,
7083 2.87060005919012917988363332454033,
7084 2.89823818258367657739520912946934,
7085 2.92561704377132528239806135133273,
7086 2.95274375377994262301217318010209,
7087 2.97962510678256471794289060402033,
7088 3.00626759936182712291041810228171,
7089 3.03267744830655121818899164295959,
7090 3.05886060707437081434964933864149 };
7091 static doublereal xmax6[53] = { 1.21091229812484768570102219548814,
7092 1.11626917091567929907256116528817,
7093 1.1327140810290884106278510474203,
7094 1.1679452722668028753522098022171,
7095 1.20910611986279066645602153641334,
7096 1.25228283758701572089625983127043,
7097 1.29591971597287895911380446311508,
7098 1.3393138157481884258308028584917,
7099 1.3821288728999671920677617491385,
7100 1.42420414683357356104823573391816,
7101 1.46546895108549501306970087318319,
7102 1.50590085198398789708599726315869,
7103 1.54550385142820987194251585145013,
7104 1.58429644271680300005206185490937,
7105 1.62230484071440103826322971668038,
7106 1.65955905239130512405565733793667,
7107 1.69609056468292429853775667485212,
7108 1.73193098017228915881592458573809,
7109 1.7671112206990325429863426635397,
7110 1.80166107681586964987277458875667,
7111 1.83560897003644959204940535551721,
7112 1.86898184653271388435058371983316,
7113 1.90180515174518670797686768515502,
7114 1.93410285411785808749237200054739,
7115 1.96589749778987993293150856865539,
7116 1.99721027139062501070081653790635,
7117 2.02806108474738744005306947877164,
7118 2.05846864831762572089033752595401,
7119 2.08845055210580131460156962214748,
7120 2.11802334209486194329576724042253,
7121 2.14720259305166593214642386780469,
7122 2.17600297710595096918495785742803,
7123 2.20443832785205516555772788192013,
7124 2.2325216999457379530416998244706,
7125 2.2602654243075083168599953074345,
7126 2.28768115912702794202525264301585,
7127 2.3147799369092684021274946755348,
7128 2.34157220782483457076721300512406,
7129 2.36806787963276257263034969490066,
7130 2.39427635443992520016789041085844,
7131 2.42020656255081863955040620243062,
7132 2.44586699364757383088888037359254,
7133 2.47126572552427660024678584642791,
7134 2.49641045058324178349347438430311,
7135 2.52130850028451113942299097584818,
7136 2.54596686772399937214920135190177,
7137 2.5703922285006754089328998222275,
7138 2.59459096001908861492582631591134,
7139 2.61856915936049852435394597597773,
7140 2.64233265984385295286445444361827,
7141 2.66588704638685848486056711408168,
7142 2.68923766976735295746679957665724,
7143 2.71238965987606292679677228666411 };
7144
7145 /* System generated locals */
7146 integer i__1;
7147
7148 /* Local variables */
7149 logical ldbg;
7150 integer numax, ii;
7151 doublereal bid;
7152
7153
7154 /* **********************************************************************
7155 */
7156
7157 /* FUNCTION : */
7158 /* ---------- */
7159 /* Calculate the max of Jacobo polynoms multiplied by the weight on */
7160 /* (-1,1) for order 0,4,6 or Legendre. */
7161
7162 /* KEYWORDSS : */
7163 /* ----------- */
7164 /* LEGENDRE,APPROXIMATION,ERREUR. */
7165
7166 /* INPUT ARGUMENTS : */
7167 /* ------------------ */
7168 /* NDGJAC: Nb of Jacobi coeff. of approximation. */
7169 /* IORDRE: Order of continuity (from -1 to 2) */
7170
7171 /* OUTPUT ARGUMENTS : */
7172 /* ------------------- */
7173 /* XJACMX: Table of maximums of Jacobi polynoms. */
7174
7175 /* COMMONS USED : */
7176 /* ---------------- */
7177
7178 /* REFERENCES CALLED : */
7179 /* --------------------- */
7180
7181 /* DESCRIPTION/NOTES/LIMITATIONS : */
7182 /* ----------------------------------- */
7183
7184 /* > */
7185 /* ***********************************************************************
7186 */
7187 /* Name of the routine */
7188 /* ----------------------------- Initialisations ------------------------
7189 */
7190
7191 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
7192 if (ldbg) {
7193 AdvApp2Var_SysBase::mgenmsg_("MMA2JMX", 7L);
7194 }
7195
7196 numax = *ndgjac - ((*iordre + 1) << 1);
7197 if (*iordre == -1) {
7198 i__1 = numax;
7199 for (ii = 0; ii <= i__1; ++ii) {
7200 bid = (ii * 2. + 1.) / 2.;
7201 xjacmx[ii] = sqrt(bid);
7202 /* L100: */
7203 }
7204 } else if (*iordre == 0) {
7205 i__1 = numax;
7206 for (ii = 0; ii <= i__1; ++ii) {
7207 xjacmx[ii] = xmax2[ii];
7208 /* L200: */
7209 }
7210 } else if (*iordre == 1) {
7211 i__1 = numax;
7212 for (ii = 0; ii <= i__1; ++ii) {
7213 xjacmx[ii] = xmax4[ii];
7214 /* L400: */
7215 }
7216 } else if (*iordre == 2) {
7217 i__1 = numax;
7218 for (ii = 0; ii <= i__1; ++ii) {
7219 xjacmx[ii] = xmax6[ii];
7220 /* L600: */
7221 }
7222 }
7223
7224 /* ------------------------- The end ------------------------------------
7225 */
7226
7227 if (ldbg) {
7228 AdvApp2Var_SysBase::mgsomsg_("MMA2JMX", 7L);
7229 }
7230 return 0;
7231 } /* mma2jmx_ */
7232
7233 //=======================================================================
7234 //function : mma2moy_
7235 //purpose :
7236 //=======================================================================
mma2moy_(integer * ndgumx,integer * ndgvmx,integer * ndimen,integer * mindgu,integer * maxdgu,integer * mindgv,integer * maxdgv,integer * iordru,integer * iordrv,doublereal * patjac,doublereal * errmoy)7237 int mma2moy_(integer *ndgumx,
7238 integer *ndgvmx,
7239 integer *ndimen,
7240 integer *mindgu,
7241 integer *maxdgu,
7242 integer *mindgv,
7243 integer *maxdgv,
7244 integer *iordru,
7245 integer *iordrv,
7246 doublereal *patjac,
7247 doublereal *errmoy)
7248 {
7249 /* System generated locals */
7250 integer patjac_dim1, patjac_dim2, patjac_offset, i__1, i__2, i__3;
7251
7252 /* Local variables */
7253 logical ldbg;
7254 integer minu, minv, idebu, idebv, ii, nd, jj;
7255 doublereal bid0, bid1;
7256
7257
7258 /* **********************************************************************
7259 */
7260
7261 /* FUNCTION : */
7262 /* ---------- */
7263 /* Calculate the average approximation error made when only */
7264 /* the coefficients of PATJAC of degree between */
7265 /* 2*(IORDRU+1) and MINDGU by U and 2*(IORDRV+1) and MINDGV by V are preserved. */
7266
7267 /* KEYWORDS : */
7268 /* ----------- */
7269 /* LEGENDRE,APPROXIMATION, AVERAGE ERROR */
7270
7271 /* INPUT ARGUMENTS : */
7272 /* ------------------ */
7273 /* NDGUMX: Dimension by U of table PATJAC. */
7274 /* NDGVMX: Dimension by V of table PATJAC. */
7275 /* NDIMEN: Dimension of the space. */
7276 /* MINDGU: Lower limit of the index by U of PATJAC coeff to be taken into account. */
7277 /* MAXDGU: Upper limit of the index by U of PATJAC coeff to be taken into account. */
7278 /* MINDGV: Lower limit of the index by V of PATJAC coeff to be taken into account. */
7279 /* MAXDGV: Upper limit of the index by V of PATJAC coeff to be taken into account. */
7280 /* IORDRU: Order of continuity by U provided by square PATJAC (from -1 to 2) */
7281 /* IORDRV: Order of continuity by V provided by square PATJAC (from -1 to 2) */
7282 /* PATJAC: Table of coeff. of the approximation square with */
7283 /* constraints of order IORDRU by U and IORDRV by V. */
7284
7285 /* OUTPUT ARGUMENTS : */
7286 /* ------------------- */
7287 /* ERRMOY: Average error committed by preserving only the coeff of */
7288 /* PATJAC 2*(IORDRU+1) in MINDGU by U and 2*(IORDRV+1) in MINDGV by V. */
7289
7290 /* COMMONS USED : */
7291 /* ---------------- */
7292
7293 /* REFERENCES CALLED : */
7294 /* --------------------- */
7295
7296 /* DESCRIPTION/NOTES/LIMITATIONS : */
7297 /* ----------------------------------- */
7298 /* Table PATJAC stores the coeff. Cij of */
7299 /* approximation square F(U,V). Indexes i and j show the degree by */
7300 /* U and by V of the base polynoms. These base polynoms are in the form: */
7301
7302 /* ((1 - U*U)**(IORDRU+1)).J(i-2*(IORDRU+1)(U), where */
7303
7304 /* polynom J(i-2*(IORDU+1)(U) is the Jacobi polynom of order */
7305 /* IORDRU+1 (the same by V by replacing U by V in the above expression). */
7306
7307 /* The contribution to the average error of term Cij when */
7308 /* it is removed from PATJAC is Cij*Cij. */
7309
7310 /* > */
7311 /* ***********************************************************************
7312 */
7313 /* Name of the routine */
7314
7315
7316 /* ----------------------------- Initialisations ------------------------
7317 */
7318
7319 /* Parameter adjustments */
7320 patjac_dim1 = *ndgumx + 1;
7321 patjac_dim2 = *ndgvmx + 1;
7322 patjac_offset = patjac_dim1 * patjac_dim2;
7323 patjac -= patjac_offset;
7324
7325 /* Function Body */
7326 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
7327 if (ldbg) {
7328 AdvApp2Var_SysBase::mgenmsg_("MMA2MOY", 7L);
7329 }
7330
7331 idebu = (*iordru + 1) << 1;
7332 idebv = (*iordrv + 1) << 1;
7333 minu = advapp_max(idebu,*mindgu);
7334 minv = advapp_max(idebv,*mindgv);
7335 bid0 = 0.;
7336 *errmoy = 0.;
7337
7338 /* ------------------ Calculation of the upper bound of the average error ------------ */
7339 /* -------------------- when the coeff. of indexes from MINDGU to MAXDGU ------ */
7340 /* ---------------- by U and of indexes from MINDGV to MAXDGV by V are removed -------------- */
7341
7342 i__1 = *ndimen;
7343 for (nd = 1; nd <= i__1; ++nd) {
7344 i__2 = *maxdgv;
7345 for (jj = minv; jj <= i__2; ++jj) {
7346 i__3 = *maxdgu;
7347 for (ii = idebu; ii <= i__3; ++ii) {
7348 bid1 = patjac[ii + (jj + nd * patjac_dim2) * patjac_dim1];
7349 bid0 += bid1 * bid1;
7350 /* L300: */
7351 }
7352 /* L200: */
7353 }
7354 /* L100: */
7355 }
7356
7357 i__1 = *ndimen;
7358 for (nd = 1; nd <= i__1; ++nd) {
7359 i__2 = minv - 1;
7360 for (jj = idebv; jj <= i__2; ++jj) {
7361 i__3 = *maxdgu;
7362 for (ii = minu; ii <= i__3; ++ii) {
7363 bid1 = patjac[ii + (jj + nd * patjac_dim2) * patjac_dim1];
7364 bid0 += bid1 * bid1;
7365 /* L600: */
7366 }
7367 /* L500: */
7368 }
7369 /* L400: */
7370 }
7371
7372 /* ----------------------- Calculation of the average error -------------
7373 */
7374
7375 bid0 /= 4;
7376 *errmoy = sqrt(bid0);
7377
7378 /* ------------------------- The end ------------------------------------
7379 */
7380
7381 if (ldbg) {
7382 AdvApp2Var_SysBase::mgsomsg_("MMA2MOY", 7L);
7383 }
7384 return 0;
7385 } /* mma2moy_ */
7386
7387 //=======================================================================
7388 //function : mma2roo_
7389 //purpose :
7390 //=======================================================================
mma2roo_(integer * nbpntu,integer * nbpntv,doublereal * urootl,doublereal * vrootl)7391 int AdvApp2Var_ApproxF2var::mma2roo_(integer *nbpntu,
7392 integer *nbpntv,
7393 doublereal *urootl,
7394 doublereal *vrootl)
7395 {
7396 /* System generated locals */
7397 integer i__1;
7398
7399 /* Local variables */
7400 integer ii, ibb;
7401
7402 /* **********************************************************************
7403 */
7404
7405 /* FUNCTION : */
7406 /* ---------- */
7407 /* Return roots of Legendre for discretisations. */
7408
7409 /* KEYWORDS : */
7410 /* ----------- */
7411 /* TOUS, AB_SPECIFI::CONTRAINTE&, DISCRETISATION, &POINT */
7412
7413 /* INPUT ARGUMENTS : */
7414 /* ------------------ */
7415 /* NBPNTU: Nb of INTERNAL parameters of discretization BY U. */
7416 /* This is also the nb of root of the Legendre polynom where the discretization is done. */
7417 /* NBPNTV: Nb of INTERNAL parameters of discretization BY V. */
7418 /* This is also the nb of root of the Legendre polynom where the discretization is done. */
7419
7420 /* OUTPUT ARGUMENTS : */
7421 /* ------------------- */
7422 /* UROOTL: Table of parameters of discretisation ON (-1,1) BY U.
7423 */
7424 /* VROOTL: Table of parameters of discretisation ON (-1,1) BY V.
7425 */
7426
7427 /* COMMONS USED : */
7428 /* ---------------- */
7429
7430 /* REFERENCES CALLED : */
7431 /* --------------------- */
7432
7433 /* DESCRIPTION/NOTES/LIMITATIONS : */
7434 /* ----------------------------------- */
7435
7436 /* > */
7437 /* **********************************************************************
7438 */
7439
7440 /* Name of the routine */
7441
7442
7443 /* Parameter adjustments */
7444 --urootl;
7445 --vrootl;
7446
7447 /* Function Body */
7448 ibb = AdvApp2Var_SysBase::mnfndeb_();
7449 if (ibb >= 3) {
7450 AdvApp2Var_SysBase::mgenmsg_("MMA2ROO", 7L);
7451 }
7452
7453 /* ---------------- Return the POSITIVE roots on U ------------------
7454 */
7455
7456 AdvApp2Var_MathBase::mmrtptt_(nbpntu, &urootl[(*nbpntu + 1) / 2 + 1]);
7457 i__1 = *nbpntu / 2;
7458 for (ii = 1; ii <= i__1; ++ii) {
7459 urootl[ii] = -urootl[*nbpntu - ii + 1];
7460 /* L100: */
7461 }
7462 if (*nbpntu % 2 == 1) {
7463 urootl[*nbpntu / 2 + 1] = 0.;
7464 }
7465
7466 /* ---------------- Return the POSITIVE roots on V ------------------
7467 */
7468
7469 AdvApp2Var_MathBase::mmrtptt_(nbpntv, &vrootl[(*nbpntv + 1) / 2 + 1]);
7470 i__1 = *nbpntv / 2;
7471 for (ii = 1; ii <= i__1; ++ii) {
7472 vrootl[ii] = -vrootl[*nbpntv - ii + 1];
7473 /* L110: */
7474 }
7475 if (*nbpntv % 2 == 1) {
7476 vrootl[*nbpntv / 2 + 1] = 0.;
7477 }
7478
7479 /* ------------------------------ The End -------------------------------
7480 */
7481
7482 if (ibb >= 3) {
7483 AdvApp2Var_SysBase::mgsomsg_("MMA2ROO", 7L);
7484 }
7485 return 0;
7486 } /* mma2roo_ */
7487 //=======================================================================
7488 //function : mmmapcoe_
7489 //purpose :
7490 //=======================================================================
mmmapcoe_(integer * ndim,integer * ndgjac,integer * iordre,integer * nbpnts,doublereal * somtab,doublereal * diftab,doublereal * gsstab,doublereal * crvjac)7491 int mmmapcoe_(integer *ndim,
7492 integer *ndgjac,
7493 integer *iordre,
7494 integer *nbpnts,
7495 doublereal *somtab,
7496 doublereal *diftab,
7497 doublereal *gsstab,
7498 doublereal *crvjac)
7499
7500 {
7501 /* System generated locals */
7502 integer somtab_dim1, somtab_offset, diftab_dim1, diftab_offset,
7503 crvjac_dim1, crvjac_offset, gsstab_dim1, i__1, i__2, i__3;
7504
7505 /* Local variables */
7506 integer igss, ikdeb;
7507 doublereal bidon;
7508 integer nd, ik, ir, nbroot, ibb;
7509
7510 /* **********************************************************************
7511 */
7512
7513 /* FUNCTION : */
7514 /* ---------- */
7515 /* Calculate the coefficients of polinomial approximation curve */
7516 /* of degree NDGJAC by the method of smallest squares starting from */
7517 /* the discretization of function on the roots of Legendre polynom */
7518 /* of degree NBPNTS. */
7519
7520 /* KEYWORDS : */
7521 /* ----------- */
7522 /* FONCTION,APPROXIMATION,COEFFICIENT,POLYNOME */
7523
7524 /* INPUT ARGUMENTS : */
7525 /* ------------------ */
7526 /* NDIM : Dimension of the space. */
7527 /* NDGJAC : Max Degree of the polynom of approximation. */
7528 /* The representation in the orthogonal base starts from degree */
7529 /* 0 to degree NDGJAC-2*(JORDRE+1). The polynomial base */
7530 /* is the base of Jacobi of order -1 (Legendre), 0, 1 and 2 */
7531 /* IORDRE : Order of the base of Jacobi (-1,0,1 or 2). Corresponds */
7532 /* to step of constraints, C0,C1 or C2. */
7533 /* NBPNTS : Degree of the polynom of Legendre on the roots which of */
7534 /* are calculated the coefficients of integration by */
7535 /* Gauss method. It is required to set NBPNTS=30,40,50 or 61 */
7536 /* and NDGJAC < NBPNTS. */
7537 /* SOMTAB : Table of F(ti)+F(-ti) with ti in ROOTAB. */
7538 /* DIFTAB : Table of F(ti)-F(-ti) with ti in ROOTAB. */
7539 /* GSSTAB(i,k) : Table of coefficients of integration by the Gauss method : */
7540 /* i varies from 0 to NBPNTS and */
7541 /* k varies from 0 to NDGJAC-2*(JORDRE+1). */
7542
7543 /* OUTPUT ARGUMENTSE : */
7544 /* ------------------- */
7545 /* CRVJAC : Curve of approximation of FONCNP with eventually */
7546 /* taking into account of constraints at the extremities. */
7547 /* This curve is of degree NDGJAC. */
7548
7549 /* COMMONS USED : */
7550 /* ---------------- */
7551
7552 /* REFERENCES CALLED : */
7553 /* --------------------- */
7554
7555 /* DESCRIPTION/NOTES/LIMITATIONS : */
7556 /* ------------------------------- */
7557 /* > */
7558 /* **********************************************************************
7559 */
7560
7561 /* Name of the routine */
7562
7563 /* Parameter adjustments */
7564 crvjac_dim1 = *ndgjac + 1;
7565 crvjac_offset = crvjac_dim1;
7566 crvjac -= crvjac_offset;
7567 gsstab_dim1 = *nbpnts / 2 + 1;
7568 diftab_dim1 = *nbpnts / 2 + 1;
7569 diftab_offset = diftab_dim1;
7570 diftab -= diftab_offset;
7571 somtab_dim1 = *nbpnts / 2 + 1;
7572 somtab_offset = somtab_dim1;
7573 somtab -= somtab_offset;
7574
7575 /* Function Body */
7576 ibb = AdvApp2Var_SysBase::mnfndeb_();
7577 if (ibb >= 2) {
7578 AdvApp2Var_SysBase::mgenmsg_("MMMAPCO", 7L);
7579 }
7580 ikdeb = (*iordre + 1) << 1;
7581 nbroot = *nbpnts / 2;
7582
7583 i__1 = *ndim;
7584 for (nd = 1; nd <= i__1; ++nd) {
7585
7586 /* ----------------- Calculate the coefficients of even degree ----------
7587 ---- */
7588
7589 i__2 = *ndgjac;
7590 for (ik = ikdeb; ik <= i__2; ik += 2) {
7591 igss = ik - ikdeb;
7592 bidon = 0.;
7593 i__3 = nbroot;
7594 for (ir = 1; ir <= i__3; ++ir) {
7595 bidon += somtab[ir + nd * somtab_dim1] * gsstab[ir + igss *
7596 gsstab_dim1];
7597 /* L300: */
7598 }
7599 crvjac[ik + nd * crvjac_dim1] = bidon;
7600 /* L200: */
7601 }
7602
7603 /* --------------- Calculate the coefficients of uneven degree ----------
7604 ---- */
7605
7606 i__2 = *ndgjac;
7607 for (ik = ikdeb + 1; ik <= i__2; ik += 2) {
7608 igss = ik - ikdeb;
7609 bidon = 0.;
7610 i__3 = nbroot;
7611 for (ir = 1; ir <= i__3; ++ir) {
7612 bidon += diftab[ir + nd * diftab_dim1] * gsstab[ir + igss *
7613 gsstab_dim1];
7614 /* L500: */
7615 }
7616 crvjac[ik + nd * crvjac_dim1] = bidon;
7617 /* L400: */
7618 }
7619
7620 /* L100: */
7621 }
7622
7623 /* ------- Add terms connected to the supplementary root (0.D0) ------ */
7624 /* ----------- of Legendre polynom of uneven degree NBPNTS -----------
7625 */
7626
7627 if (*nbpnts % 2 == 0) {
7628 goto L9999;
7629 }
7630 i__1 = *ndim;
7631 for (nd = 1; nd <= i__1; ++nd) {
7632 i__2 = *ndgjac;
7633 for (ik = ikdeb; ik <= i__2; ik += 2) {
7634 igss = ik - ikdeb;
7635 crvjac[ik + nd * crvjac_dim1] += somtab[nd * somtab_dim1] *
7636 gsstab[igss * gsstab_dim1];
7637 /* L700: */
7638 }
7639 /* L600: */
7640 }
7641
7642 /* ------------------------------ The end -------------------------------
7643 */
7644
7645 L9999:
7646 if (ibb >= 2) {
7647 AdvApp2Var_SysBase::mgsomsg_("MMMAPCO", 7L);
7648 }
7649 return 0;
7650 } /* mmmapcoe_ */
7651 //=======================================================================
7652 //function : mmaperm_
7653 //purpose :
7654 //=======================================================================
mmaperm_(integer * ncofmx,integer * ndim,integer * ncoeff,integer * iordre,doublereal * crvjac,integer * ncfnew,doublereal * errmoy)7655 int mmaperm_(integer *ncofmx,
7656 integer *ndim,
7657 integer *ncoeff,
7658 integer *iordre,
7659 doublereal *crvjac,
7660 integer *ncfnew,
7661 doublereal *errmoy)
7662 {
7663 /* System generated locals */
7664 integer crvjac_dim1, crvjac_offset, i__1, i__2;
7665
7666 /* Local variables */
7667 doublereal bidj;
7668 integer i__, ia, nd, ncfcut, ibb;
7669 doublereal bid;
7670
7671 /* **********************************************************************
7672 */
7673
7674 /* FUNCTION : */
7675 /* ---------- */
7676 /* Calculate the square root of the average quadratic error */
7677 /* of approximation done when only the */
7678 /* first NCFNEW coefficients of a curve of degree NCOEFF-1 */
7679 /* written in NORMALIZED Jacobi base of order 2*(IORDRE+1) are preserved. */
7680
7681 /* KEYWORDS : */
7682 /* ----------- */
7683 /* LEGENDRE,POLYGONE,APPROXIMATION,ERREUR. */
7684
7685 /* INPUT ARGUMENTS : */
7686 /* ------------------ */
7687 /* NCOFMX : Maximum degree of the curve. */
7688 /* NDIM : Dimension of the space. */
7689 /* NCOEFF : Degree +1 of the curve. */
7690 /* IORDRE : Order of constraint of continuity at the extremities. */
7691 /* CRVJAC : The curve the degree which of will be lowered. */
7692 /* NCFNEW : Degree +1 of the resulting polynom. */
7693
7694 /* OUTPUT ARGUMENTS : */
7695 /* ------------------- */
7696 /* ERRMOY : Average precision of approximation. */
7697
7698 /* COMMONS USED : */
7699 /* ---------------- */
7700
7701 /* REFERENCES CALLED : */
7702 /* ----------------------- */
7703
7704 /* DESCRIPTION/NOTES/LIMITATIONS : */
7705 /* ----------------------------------- */
7706 /* > */
7707 /* ***********************************************************************
7708 */
7709
7710 /* Name of the routine */
7711
7712 /* Parameter adjustments */
7713 crvjac_dim1 = *ncofmx;
7714 crvjac_offset = crvjac_dim1 + 1;
7715 crvjac -= crvjac_offset;
7716
7717 /* Function Body */
7718 ibb = AdvApp2Var_SysBase::mnfndeb_();
7719 if (ibb >= 2) {
7720 AdvApp2Var_SysBase::mgenmsg_("MMAPERM", 7L);
7721 }
7722
7723 /* --------- Minimum degree that can be reached : Stop at 1 or IA -------
7724 */
7725
7726 ia = (*iordre + 1) << 1;
7727 ncfcut = ia + 1;
7728 if (*ncfnew + 1 > ncfcut) {
7729 ncfcut = *ncfnew + 1;
7730 }
7731
7732 /* -------------- Elimination of coefficients of high degree ------------ */
7733 /* ----------- Loop on the series of Jacobi :NCFCUT --> NCOEFF --------- */
7734
7735 *errmoy = 0.;
7736 bid = 0.;
7737 i__1 = *ndim;
7738 for (nd = 1; nd <= i__1; ++nd) {
7739 i__2 = *ncoeff;
7740 for (i__ = ncfcut; i__ <= i__2; ++i__) {
7741 bidj = crvjac[i__ + nd * crvjac_dim1];
7742 bid += bidj * bidj;
7743 /* L200: */
7744 }
7745 /* L100: */
7746 }
7747
7748 /* ----------- Square Root of average quadratic error e -----------
7749 */
7750
7751 bid /= 2.;
7752 *errmoy = sqrt(bid);
7753
7754 /* ------------------------------- The end ------------------------------
7755 */
7756
7757 if (ibb >= 2) {
7758 AdvApp2Var_SysBase::mgsomsg_("MMAPERM", 7L);
7759 }
7760 return 0;
7761 } /* mmaperm_ */
7762 //=======================================================================
7763 //function : mmapptt_
7764 //purpose :
7765 //=======================================================================
mmapptt_(const integer * ndgjac,const integer * nbpnts,const integer * jordre,doublereal * cgauss,integer * iercod)7766 int AdvApp2Var_ApproxF2var::mmapptt_(const integer *ndgjac,
7767 const integer *nbpnts,
7768 const integer *jordre,
7769 doublereal *cgauss,
7770 integer *iercod)
7771 {
7772 /* System generated locals */
7773 integer cgauss_dim1, i__1;
7774
7775 /* Local variables */
7776 integer kjac, iptt, ipdb0, infdg, iptdb, mxjac, ilong, ibb;
7777
7778 /* **********************************************************************
7779 */
7780
7781 /* FUNCTION : */
7782 /* ---------- */
7783 /* Load the elements required for integration by */
7784 /* Gauss method to obtain the coefficients in the base of */
7785 /* Legendre of the approximation by the least squares of a */
7786 /* function. The elements are stored in commons MMAPGSS */
7787 /* (case without constraint), MMAPGS0 (constraints C0), MMAPGS1 */
7788 /* (constraints C1) and MMAPGS2 (constraints C2). */
7789
7790 /* KEYWORDS : */
7791 /* ----------- */
7792 /* INTEGRATION,GAUSS,JACOBI */
7793
7794 /* INPUT ARGUMENTS : */
7795 /* ------------------ */
7796 /* NDGJAC : Max degree of the polynom of approximation. */
7797 /* The representation in orthogonal base goes from degree */
7798 /* 0 to degree NDGJAC-2*(JORDRE+1). The polynomial base */
7799 /* is the base of Jacobi of order -1 (Legendre), 0, 1 and 2 */
7800 /* NBPNTS : Degree of the polynom of Legendre on the roots which of */
7801 /* are calculated the coefficients of integration by the */
7802 /* method of Gauss. It is required that NBPNTS=8,10,15,20,25, */
7803 /* 30,40,50 or 61 and NDGJAC < NBPNTS. */
7804 /* JORDRE : Order of the base of Jacobi (-1,0,1 or 2). Corresponds */
7805 /* to step of constraints C0,C1 or C2. */
7806
7807 /* OUTPUT ARGUMENTS : */
7808 /* ------------------- */
7809 /* CGAUSS(i,k) : Table of coefficients of integration by */
7810 /* Gauss method : i varies from 0 to the integer part */
7811 /* of NBPNTS/2 and k varies from 0 to NDGJAC-2*(JORDRE+1). */
7812 /* These are the coeff. of integration associated to */
7813 /* positive roots of the polynom of Legendre of degree */
7814 /* NBPNTS. CGAUSS(0,k) contains coeff. */
7815 /* of integration associated to root t = 0 when */
7816 /* NBPNTS is uneven. */
7817 /* IERCOD : Error code. */
7818 /* = 0 OK, */
7819 /* = 11 NBPNTS is not 8,10,15,20,25,30,40,50 or 61. */
7820 /* = 21 JORDRE is not -1,0,1 or 2. */
7821 /* = 31 NDGJAC is too great or too small. */
7822
7823 /* COMMONS USED : */
7824 /* ---------------- */
7825 /* MMAPGSS,MMAPGS0,MMAPGS1,MMAPGS2. */
7826 /* ***********************************************************************
7827 */
7828 /* Parameter adjustments */
7829 cgauss_dim1 = *nbpnts / 2 + 1;
7830
7831 /* Function Body */
7832 ibb = AdvApp2Var_SysBase::mnfndeb_();
7833 if (ibb >= 2) {
7834 AdvApp2Var_SysBase::mgenmsg_("MMAPPTT", 7L);
7835 }
7836 *iercod = 0;
7837
7838 /* ------------------- Tests on the validity of inputs ----------------
7839 */
7840
7841 infdg = (*jordre + 1) << 1;
7842 if (*nbpnts != 8 && *nbpnts != 10 && *nbpnts != 15 && *nbpnts != 20 && *
7843 nbpnts != 25 && *nbpnts != 30 && *nbpnts != 40 && *nbpnts != 50 &&
7844 *nbpnts != 61) {
7845 goto L9100;
7846 }
7847
7848 if (*jordre < -1 || *jordre > 2) {
7849 goto L9200;
7850 }
7851
7852 if (*ndgjac >= *nbpnts || *ndgjac < infdg) {
7853 goto L9300;
7854 }
7855
7856 /* --------------- Calculation of the start pointer following NBPNTS -----------
7857 */
7858
7859 iptdb = 0;
7860 if (*nbpnts > 8) {
7861 iptdb += (8 - infdg) << 2;
7862 }
7863 if (*nbpnts > 10) {
7864 iptdb += (10 - infdg) * 5;
7865 }
7866 if (*nbpnts > 15) {
7867 iptdb += (15 - infdg) * 7;
7868 }
7869 if (*nbpnts > 20) {
7870 iptdb += (20 - infdg) * 10;
7871 }
7872 if (*nbpnts > 25) {
7873 iptdb += (25 - infdg) * 12;
7874 }
7875 if (*nbpnts > 30) {
7876 iptdb += (30 - infdg) * 15;
7877 }
7878 if (*nbpnts > 40) {
7879 iptdb += (40 - infdg) * 20;
7880 }
7881 if (*nbpnts > 50) {
7882 iptdb += (50 - infdg) * 25;
7883 }
7884
7885 ipdb0 = 1;
7886 if (*nbpnts > 15) {
7887 ipdb0 = ipdb0 + (14 - infdg) / 2 + 1;
7888 }
7889 if (*nbpnts > 25) {
7890 ipdb0 = ipdb0 + (24 - infdg) / 2 + 1;
7891 }
7892
7893 /* ------------------ Choice of the common depending on JORDRE -------------
7894 */
7895
7896 if (*jordre == -1) {
7897 goto L1000;
7898 }
7899 if (*jordre == 0) {
7900 goto L2000;
7901 }
7902 if (*jordre == 1) {
7903 goto L3000;
7904 }
7905 if (*jordre == 2) {
7906 goto L4000;
7907 }
7908
7909 /* ---------------- Common MMAPGSS (case without constraints) ----------------
7910 */
7911
7912 L1000:
7913 ilong = *nbpnts / 2 << 3;
7914 i__1 = *ndgjac;
7915 for (kjac = 0; kjac <= i__1; ++kjac) {
7916 iptt = iptdb + kjac * (*nbpnts / 2) + 1;
7917 AdvApp2Var_SysBase::mcrfill_(&ilong,
7918 &mmapgss_.gslxjs[iptt - 1],
7919 &cgauss[kjac * cgauss_dim1 + 1]);
7920 /* L100: */
7921 }
7922 /* --> Case when the number of points is uneven. */
7923 if (*nbpnts % 2 == 1) {
7924 iptt = ipdb0;
7925 i__1 = *ndgjac;
7926 for (kjac = 0; kjac <= i__1; kjac += 2) {
7927 cgauss[kjac * cgauss_dim1] = mmapgss_.gsl0js[iptt - 1];
7928 ++iptt;
7929 /* L150: */
7930 }
7931 i__1 = *ndgjac;
7932 for (kjac = 1; kjac <= i__1; kjac += 2) {
7933 cgauss[kjac * cgauss_dim1] = 0.;
7934 /* L160: */
7935 }
7936 }
7937 goto L9999;
7938
7939 /* ---------------- Common MMAPGS0 (case with constraints C0) -------------
7940 */
7941
7942 L2000:
7943 mxjac = *ndgjac - infdg;
7944 ilong = *nbpnts / 2 << 3;
7945 i__1 = mxjac;
7946 for (kjac = 0; kjac <= i__1; ++kjac) {
7947 iptt = iptdb + kjac * (*nbpnts / 2) + 1;
7948 AdvApp2Var_SysBase::mcrfill_(&ilong,
7949 &mmapgs0_.gslxj0[iptt - 1],
7950 &cgauss[kjac * cgauss_dim1 + 1]);
7951 /* L200: */
7952 }
7953 /* --> Case when the number of points is uneven. */
7954 if (*nbpnts % 2 == 1) {
7955 iptt = ipdb0;
7956 i__1 = mxjac;
7957 for (kjac = 0; kjac <= i__1; kjac += 2) {
7958 cgauss[kjac * cgauss_dim1] = mmapgs0_.gsl0j0[iptt - 1];
7959 ++iptt;
7960 /* L250: */
7961 }
7962 i__1 = mxjac;
7963 for (kjac = 1; kjac <= i__1; kjac += 2) {
7964 cgauss[kjac * cgauss_dim1] = 0.;
7965 /* L260: */
7966 }
7967 }
7968 goto L9999;
7969
7970 /* ---------------- Common MMAPGS1 (case with constraints C1) -------------
7971 */
7972
7973 L3000:
7974 mxjac = *ndgjac - infdg;
7975 ilong = *nbpnts / 2 << 3;
7976 i__1 = mxjac;
7977 for (kjac = 0; kjac <= i__1; ++kjac) {
7978 iptt = iptdb + kjac * (*nbpnts / 2) + 1;
7979 AdvApp2Var_SysBase::mcrfill_(&ilong,
7980 &mmapgs1_.gslxj1[iptt - 1],
7981 &cgauss[kjac * cgauss_dim1 + 1]);
7982 /* L300: */
7983 }
7984 /* --> Case when the number of points is uneven. */
7985 if (*nbpnts % 2 == 1) {
7986 iptt = ipdb0;
7987 i__1 = mxjac;
7988 for (kjac = 0; kjac <= i__1; kjac += 2) {
7989 cgauss[kjac * cgauss_dim1] = mmapgs1_.gsl0j1[iptt - 1];
7990 ++iptt;
7991 /* L350: */
7992 }
7993 i__1 = mxjac;
7994 for (kjac = 1; kjac <= i__1; kjac += 2) {
7995 cgauss[kjac * cgauss_dim1] = 0.;
7996 /* L360: */
7997 }
7998 }
7999 goto L9999;
8000
8001 /* ---------------- Common MMAPGS2 (case with constraints C2) -------------
8002 */
8003
8004 L4000:
8005 mxjac = *ndgjac - infdg;
8006 ilong = *nbpnts / 2 << 3;
8007 i__1 = mxjac;
8008 for (kjac = 0; kjac <= i__1; ++kjac) {
8009 iptt = iptdb + kjac * (*nbpnts / 2) + 1;
8010 AdvApp2Var_SysBase::mcrfill_(&ilong,
8011 &mmapgs2_.gslxj2[iptt - 1],
8012 &cgauss[kjac * cgauss_dim1 + 1]);
8013 /* L400: */
8014 }
8015 /* --> Cas of uneven number of points. */
8016 if (*nbpnts % 2 == 1) {
8017 iptt = ipdb0;
8018 i__1 = mxjac;
8019 for (kjac = 0; kjac <= i__1; kjac += 2) {
8020 cgauss[kjac * cgauss_dim1] = mmapgs2_.gsl0j2[iptt - 1];
8021 ++iptt;
8022 /* L450: */
8023 }
8024 i__1 = mxjac;
8025 for (kjac = 1; kjac <= i__1; kjac += 2) {
8026 cgauss[kjac * cgauss_dim1] = 0.;
8027 /* L460: */
8028 }
8029 }
8030 goto L9999;
8031
8032 /* ------------------------- Return the error code --------------
8033 */
8034 /* --> NBPNTS is not OK */
8035 L9100:
8036 *iercod = 11;
8037 goto L9999;
8038 /* --> JORDRE is not OK */
8039 L9200:
8040 *iercod = 21;
8041 goto L9999;
8042 /* --> NDGJAC is not OK */
8043 L9300:
8044 *iercod = 31;
8045 goto L9999;
8046
8047 /* -------------------------------- The end -----------------------------
8048 */
8049
8050 L9999:
8051 if (*iercod > 0) {
8052 AdvApp2Var_SysBase::maermsg_("MMAPPTT", iercod, 7L);
8053 }
8054 if (ibb >= 2) {
8055 AdvApp2Var_SysBase::mgsomsg_("MMAPPTT", 7L);
8056 }
8057
8058 return 0 ;
8059 } /* mmapptt_ */
8060
8061 //=======================================================================
8062 //function : mmjacpt_
8063 //purpose :
8064 //=======================================================================
mmjacpt_(const integer * ndimen,const integer * ncoefu,const integer * ncoefv,const integer * iordru,const integer * iordrv,const doublereal * ptclgd,doublereal * ptcaux,doublereal * ptccan)8065 int mmjacpt_(const integer *ndimen,
8066 const integer *ncoefu,
8067 const integer *ncoefv,
8068 const integer *iordru,
8069 const integer *iordrv,
8070 const doublereal *ptclgd,
8071 doublereal *ptcaux,
8072 doublereal *ptccan)
8073 {
8074 /* System generated locals */
8075 integer ptccan_dim1, ptccan_dim2, ptccan_offset, ptclgd_dim1, ptclgd_dim2,
8076 ptclgd_offset, ptcaux_dim1, ptcaux_dim2, ptcaux_dim3,
8077 ptcaux_offset, i__1, i__2, i__3;
8078
8079 /* Local variables */
8080 integer kdim, nd, ii, jj, ibb;
8081
8082 /* ***********************************************************************
8083 */
8084
8085 /* FONCTION : */
8086 /* ---------- */
8087 /* Passage from canonical to Jacobi base for a */
8088 /* "square" in a space of arbitrary dimension. */
8089
8090 /* MOTS CLES : */
8091 /* ----------- */
8092 /* SMOOTHING,BASE,LEGENDRE */
8093
8094
8095 /* INPUT ARGUMENTS : */
8096 /* ------------------ */
8097 /* NDIMEN : Dimension of the space. */
8098 /* NCOEFU : Degree+1 by U. */
8099 /* NCOEFV : Degree+1 by V. */
8100 /* IORDRU : Order of Jacobi polynoms by U. */
8101 /* IORDRV : Order of Jacobi polynoms by V. */
8102 /* PTCLGD : The square in the Jacobi base. */
8103
8104 /* OUTPUT ARGUMENTS : */
8105 /* ------------------- */
8106 /* PTCAUX : Auxilliary space. */
8107 /* PTCCAN : The square in the canonic base (-1,1) */
8108
8109 /* COMMONS USED : */
8110 /* ---------------- */
8111
8112 /* APPLIED REFERENCES : */
8113 /* ----------------------- */
8114
8115 /* DESCRIPTION/NOTES/LIMITATIONS : */
8116 /* ----------------------------------- */
8117 /* Cancels and replaces MJACPC */
8118
8119 /* *********************************************************************
8120 */
8121 /* Name of the routine */
8122
8123
8124 /* Parameter adjustments */
8125 ptccan_dim1 = *ncoefu;
8126 ptccan_dim2 = *ncoefv;
8127 ptccan_offset = ptccan_dim1 * (ptccan_dim2 + 1) + 1;
8128 ptccan -= ptccan_offset;
8129 ptcaux_dim1 = *ncoefv;
8130 ptcaux_dim2 = *ncoefu;
8131 ptcaux_dim3 = *ndimen;
8132 ptcaux_offset = ptcaux_dim1 * (ptcaux_dim2 * (ptcaux_dim3 + 1) + 1) + 1;
8133 ptcaux -= ptcaux_offset;
8134 ptclgd_dim1 = *ncoefu;
8135 ptclgd_dim2 = *ncoefv;
8136 ptclgd_offset = ptclgd_dim1 * (ptclgd_dim2 + 1) + 1;
8137 ptclgd -= ptclgd_offset;
8138
8139 /* Function Body */
8140 ibb = AdvApp2Var_SysBase::mnfndeb_();
8141 if (ibb >= 3) {
8142 AdvApp2Var_SysBase::mgenmsg_("MMJACPT", 7L);
8143 }
8144
8145 /* Passage into canonical by u. */
8146
8147 kdim = *ndimen * *ncoefv;
8148 AdvApp2Var_MathBase::mmjaccv_(ncoefu,
8149 &kdim,
8150 iordru,
8151 &ptclgd[ptclgd_offset],
8152 &ptcaux[ptcaux_offset],
8153 &ptccan[ptccan_offset]);
8154
8155 /* Swapping of u and v. */
8156
8157 i__1 = *ndimen;
8158 for (nd = 1; nd <= i__1; ++nd) {
8159 i__2 = *ncoefv;
8160 for (jj = 1; jj <= i__2; ++jj) {
8161 i__3 = *ncoefu;
8162 for (ii = 1; ii <= i__3; ++ii) {
8163 ptcaux[jj + (ii + (nd + ptcaux_dim3) * ptcaux_dim2) *
8164 ptcaux_dim1] = ptccan[ii + (jj + nd * ptccan_dim2) *
8165 ptccan_dim1];
8166 /* L320: */
8167 }
8168 /* L310: */
8169 }
8170 /* L300: */
8171 }
8172
8173 /* Passage into canonical by v. */
8174
8175 kdim = *ndimen * *ncoefu;
8176 AdvApp2Var_MathBase::mmjaccv_(ncoefv,
8177 &kdim,
8178 iordrv,
8179 &ptcaux[((ptcaux_dim3 + 1) * ptcaux_dim2 + 1) * ptcaux_dim1 + 1],
8180 &ptccan[ptccan_offset],
8181 &ptcaux[(((ptcaux_dim3 << 1) + 1) * ptcaux_dim2 + 1) * ptcaux_dim1 + 1]);
8182
8183 /* Swapping of u and v. */
8184
8185 i__1 = *ndimen;
8186 for (nd = 1; nd <= i__1; ++nd) {
8187 i__2 = *ncoefv;
8188 for (jj = 1; jj <= i__2; ++jj) {
8189 i__3 = *ncoefu;
8190 for (ii = 1; ii <= i__3; ++ii) {
8191 ptccan[ii + (jj + nd * ptccan_dim2) * ptccan_dim1] = ptcaux[
8192 jj + (ii + (nd + (ptcaux_dim3 << 1)) * ptcaux_dim2) *
8193 ptcaux_dim1];
8194 /* L420: */
8195 }
8196 /* L410: */
8197 }
8198 /* L400: */
8199 }
8200
8201 /* ---------------------------- THAT'S ALL FOLKS ------------------------
8202 */
8203
8204 if (ibb >= 3) {
8205 AdvApp2Var_SysBase::mgsomsg_("MMJACPT", 7L);
8206 }
8207 return 0;
8208 } /* mmjacpt_ */
8209