src/AdvApp2Var/AdvApp2Var_ApproxF2var.cxx

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