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