src/AdvApp2Var/AdvApp2Var_ApproxF2var.cxx

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