src/AdvApp2Var/AdvApp2Var_MathBase.cxx

   1 //
   2 // AdvApp2Var_MathBase.cxx
   3 //
   4 #include <math.h>
   5 #include <AdvApp2Var_SysBase.hxx>
   6 #include <AdvApp2Var_Data_f2c.hxx>
   7 #include <AdvApp2Var_MathBase.hxx>
   8 #include <AdvApp2Var_Data.hxx>
   9
  10 // statics
  11 static
  12 int mmchole_(integer *mxcoef,
  13              integer *dimens,
  14              doublereal *amatri,
  15              integer *aposit,
  16              integer *posuiv,
  17              doublereal *chomat,
  18              integer *iercod);
  19
  20
  21
  22
  23 static
  24 int mmrslss_(integer *mxcoef,
  25              integer *dimens,
  26              doublereal *smatri,
  27              integer *sposit,
  28              integer *posuiv,
  29              doublereal *mscnmbr,
  30              doublereal *soluti,
  31              integer *iercod);
  32
  33 static
  34 int mfac_(doublereal *f,
  35           integer *n);
  36
  37 static
  38 int mmaper0_(integer *ncofmx,
  39              integer *ndimen,
  40              integer *ncoeff,
  41              doublereal *crvlgd,
  42              integer *ncfnew,
  43              doublereal *ycvmax,
  44              doublereal *errmax);
  45 static
  46 int mmaper2_(integer *ncofmx,
  47              integer *ndimen,
  48              integer *ncoeff,
  49              doublereal *crvjac,
  50              integer *ncfnew,
  51              doublereal *ycvmax,
  52              doublereal *errmax);
  53
  54 static
  55 int mmaper4_(integer *ncofmx,
  56              integer *ndimen,
  57              integer *ncoeff,
  58              doublereal *crvjac,
  59              integer *ncfnew,
  60              doublereal *ycvmax,
  61              doublereal *errmax);
  62
  63 static
  64 int mmaper6_(integer *ncofmx,
  65              integer *ndimen,
  66              integer *ncoeff,
  67              doublereal *crvjac,
  68              integer *ncfnew,
  69              doublereal *ycvmax,
  70              doublereal *errmax);
  71
  72 static
  73 int mmarc41_(integer *ndimax,
  74              integer *ndimen,
  75              integer *ncoeff,
  76              doublereal *crvold,
  77              doublereal *upara0,
  78              doublereal *upara1,
  79              doublereal *crvnew,
  80              integer *iercod);
  81
  82 static
  83 int mmatvec_(integer *nligne,
  84              integer *ncolon,
  85              integer *gposit,
  86              integer *gnstoc,
  87              doublereal *gmatri,
  88              doublereal *vecin,
  89              integer *deblig,
  90              doublereal *vecout,
  91              integer *iercod);
  92
  93 static
  94 int mmcvstd_(integer *ncofmx,
  95              integer *ndimax,
  96              integer *ncoeff,
  97              integer *ndimen,
  98              doublereal *crvcan,
  99              doublereal *courbe);
 100
 101 static
 102 int mmdrvcb_(integer *ideriv,
 103              integer *ndim,
 104              integer *ncoeff,
 105              doublereal *courbe,
 106              doublereal *tparam,
 107              doublereal *tabpnt,
 108              integer *iercod);
 109
 110 static
 111 int mmexthi_(integer *ndegre,
 112              doublereal *hwgaus);
 113
 114 static
 115 int mmextrl_(integer *ndegre,
 116              doublereal *rootlg);
 117
 118
 119
 120 static
 121 int mmherm0_(doublereal *debfin,
 122              integer *iercod);
 123
 124 static
 125 int mmherm1_(doublereal *debfin,
 126              integer *ordrmx,
 127              integer *iordre,
 128              doublereal *hermit,
 129              integer *iercod);
 130 static
 131 int mmloncv_(integer *ndimax,
 132              integer *ndimen,
 133              integer *ncoeff,
 134              doublereal *courbe,
 135              doublereal *tdebut,
 136              doublereal *tfinal,
 137              doublereal *xlongc,
 138              integer *iercod);
 139 static
 140 int mmpojac_(doublereal *tparam,
 141              integer *iordre,
 142              integer *ncoeff,
 143              integer *nderiv,
 144              doublereal *valjac,
 145              integer *iercod);
 146
 147 static
 148 int mmrslw_(integer *normax,
 149             integer *nordre,
 150             integer *ndimen,
 151             doublereal *epspiv,
 152             doublereal *abmatr,
 153             doublereal *xmatri,
 154             integer *iercod);
 155 static
 156 int mmtmave_(integer *nligne,
 157              integer *ncolon,
 158              integer *gposit,
 159              integer *gnstoc,
 160              doublereal *gmatri,
 161              doublereal *vecin,
 162              doublereal *vecout,
 163              integer *iercod);
 164 static
 165 int mmtrpj0_(integer *ncofmx,
 166              integer *ndimen,
 167              integer *ncoeff,
 168              doublereal *epsi3d,
 169              doublereal *crvlgd,
 170              doublereal *ycvmax,
 171              doublereal *epstrc,
 172              integer *ncfnew);
 173 static
 174 int mmtrpj2_(integer *ncofmx,
 175              integer *ndimen,
 176              integer *ncoeff,
 177              doublereal *epsi3d,
 178              doublereal *crvlgd,
 179              doublereal *ycvmax,
 180              doublereal *epstrc,
 181              integer *ncfnew);
 182
 183 static
 184 int mmtrpj4_(integer *ncofmx,
 185              integer *ndimen,
 186              integer *ncoeff,
 187              doublereal *epsi3d,
 188              doublereal *crvlgd,
 189              doublereal *ycvmax,
 190              doublereal *epstrc,
 191              integer *ncfnew);
 192 static
 193 int mmtrpj6_(integer *ncofmx,
 194              integer *ndimen,
 195              integer *ncoeff,
 196              doublereal *epsi3d,
 197              doublereal *crvlgd,
 198              doublereal *ycvmax,
 199              doublereal *epstrc,
 200              integer *ncfnew);
 201 static
 202 integer  pow__ii(integer *x,
 203                  integer *n);
 204
 205 static
 206 int mvcvin2_(integer *ncoeff,
 207              doublereal *crvold,
 208              doublereal *crvnew,
 209              integer *iercod);
 210
 211 static
 212 int mvcvinv_(integer *ncoeff,
 213              doublereal *crvold,
 214              doublereal *crvnew,
 215              integer *iercod);
 216
 217 static
 218 int mvgaus0_(integer *kindic,
 219              doublereal *urootl,
 220              doublereal *hiltab,
 221              integer *nbrval,
 222              integer *iercod);
 223 static
 224 int mvpscr2_(integer *ncoeff,
 225              doublereal *curve2,
 226              doublereal *tparam,
 227              doublereal *pntcrb);
 228
 229 static
 230 int mvpscr3_(integer *ncoeff,
 231              doublereal *curve2,
 232              doublereal *tparam,
 233              doublereal *pntcrb);
 234
 235 static struct {
 236     doublereal eps1, eps2, eps3, eps4;
 237     integer niterm, niterr;
 238 } mmprcsn_;
 239
 240 static struct {
 241     doublereal tdebut, tfinal, verifi, cmherm[576];
 242 } mmcmher_;
 243
 244 //=======================================================================
 245 //function : AdvApp2Var_MathBase::mdsptpt_
 246 //purpose  :
 247 //=======================================================================
 248 int AdvApp2Var_MathBase::mdsptpt_(integer *ndimen,
 249                                   doublereal *point1,
 250                                   doublereal *point2,
 251                                   doublereal *distan)
 252
 253 {
 254   static integer c__8 = 8;
 255   /* System generated locals */
 256   integer i__1;
 257   doublereal d__1;
 258
 259   /* Local variables */
 260   static integer i__;
 261   static doublereal differ[100];
 262   static integer  ier;
 263   long int iofset, j;
 264
 265 /* **********************************************************************
 266 */
 267
 268 /*     FUNCTION : */
 269 /*     ---------- */
 270 /*        CALCULATE DISTANCE BETWEEN TWO POINTS */
 271
 272 /*     KEYWORDS : */
 273 /*     ----------- */
 274 /*        DISTANCE,POINT. */
 275
 276 /*     INPUT ARGUMENTS : */
 277 /*     ------------------ */
 278 /*        NDIMEN: Space Dimension. */
 279 /*        POINT1: Table of coordinates of the 1st point. */
 280 /*        POINT2: Table of coordinates of the 2nd point. */
 281
 282 /*     OUTPUT ARGUMENTS : */
 283 /*     ------------------- */
 284 /*        DISTAN: Distance between 2 points. */
 285
 286 /*     COMMONS USED   : */
 287 /*     ---------------- */
 288
 289 /*     REFERENCES CALLED   : */
 290 /*     ----------------------- */
 291
 292 /*     DESCRIPTION/NOTES/LIMITATIONS : */
 293 /*     ----------------------------------- */
 294 /* > */
 295 /* **********************************************************************
 296 */
 297
 298
 299 /* ***********************************************************************
 300  */
 301 /*                      INITIALISATION */
 302 /* ***********************************************************************
 303  */
 304
 305     /* Parameter adjustment */
 306     --point2;
 307     --point1;
 308
 309     /* Function Body */
 310     iofset = 0;
 311     ier = 0;
 312
 313 /* ***********************************************************************
 314  */
 315 /*                     TRAITEMENT */
 316 /* ***********************************************************************
 317  */
 318
 319     if (*ndimen > 100) {
 320         AdvApp2Var_SysBase::mcrrqst_(&c__8, ndimen, differ, &iofset, &ier);
 321     }
 322
 323 /* --- If allocation is refused, the trivial method is applied. */
 324
 325     if (ier > 0) {
 326
 327         *distan = 0.;
 328         i__1 = *ndimen;
 329         for (i__ = 1; i__ <= i__1; ++i__) {
 330 /* Computing 2nd power */
 331             d__1 = point1[i__] - point2[i__];
 332             *distan += d__1 * d__1;
 333         }
 334         *distan = sqrt(*distan);
 335
 336 /* --- Otherwise MZSNORM is used to minimize the risks of overflow
 337 */
 338
 339     } else {
 340         i__1 = *ndimen;
 341         for (i__ = 1; i__ <= i__1; ++i__) {
 342             j=iofset + i__ - 1;
 343             differ[j] = point2[i__] - point1[i__];
 344         }
 345
 346         *distan = AdvApp2Var_MathBase::mzsnorm_(ndimen, &differ[iofset]);
 347
 348     }
 349
 350 /* ***********************************************************************
 351  */
 352 /*                   RETURN CALLING PROGRAM */
 353 /* ***********************************************************************
 354  */
 355
 356 /* --- Dynamic Desallocation */
 357
 358     if (iofset != 0) {
 359         AdvApp2Var_SysBase::mcrdelt_(&c__8, ndimen, differ, &iofset, &ier);
 360     }
 361
 362  return 0 ;
 363 } /* mdsptpt_ */
 364
 365 //=======================================================================
 366 //function : mfac_
 367 //purpose  :
 368 //=======================================================================
 369 int mfac_(doublereal *f,
 370           integer *n)
 371
 372 {
 373     /* System generated locals */
 374     integer i__1;
 375
 376     /* Local variables */
 377     static integer i__;
 378
 379 /*    FORTRAN CONFORME AU TEXT */
 380 /*     CALCUL DE MFACTORIEL N */
 381     /* Parameter adjustments */
 382     --f;
 383
 384     /* Function Body */
 385     f[1] = (float)1.;
 386     i__1 = *n;
 387     for (i__ = 2; i__ <= i__1; ++i__) {
 388 /* L10: */
 389         f[i__] = i__ * f[i__ - 1];
 390     }
 391     return 0;
 392 } /* mfac_ */
 393
 394 //=======================================================================
 395 //function : AdvApp2Var_MathBase::mmapcmp_
 396 //purpose  :
 397 //=======================================================================
 398 int AdvApp2Var_MathBase::mmapcmp_(integer *ndim,
 399                                   integer *ncofmx,
 400                                   integer *ncoeff,
 401                                   doublereal *crvold,
 402                                   doublereal *crvnew)
 403
 404 {
 405   /* System generated locals */
 406   integer crvold_dim1, crvold_offset, crvnew_dim1, crvnew_offset, i__1,
 407   i__2;
 408
 409   /* Local variables */
 410   static integer ipair, nd, ndegre, impair, ibb, idg;
 411   //extern  int  mgsomsg_();//mgenmsg_(),
 412
 413
 414
 415 /* **********************************************************************
 416 */
 417
 418 /*     FUNCTION : */
 419 /*     ---------- */
 420 /*        Compression of curve CRVOLD in a table of  */
 421 /*        coeff. of even : CRVNEW(*,0,*) */
 422 /*        and uneven range : CRVNEW(*,1,*). */
 423
 424 /*     KEYWORDS : */
 425 /*     ----------- */
 426 /*        COMPRESSION,CURVE. */
 427
 428 /*     INPUT ARGUMENTS : */
 429 /*     ------------------ */
 430 /*     NDIM   : Space Dimension. */
 431 /*     NCOFMX : Max nb of coeff. of the curve to compress. */
 432 /*     NCOEFF : Max nb of coeff. of the compressed curve. */
 433 /*     CRVOLD : The curve (0:NCOFMX-1,NDIM) to compress. */
 434
 435 /*     OUTPUT ARGUMENTS : */
 436 /*     ------------------- */
 437 /*     CRVNEW : Curve compacted in (0:(NCOEFF-1)/2,0,NDIM) (containing
 438 */
 439 /*              even terms) and in (0:(NCOEFF-1)/2,1,NDIM) */
 440 /*              (containing uneven terms). */
 441
 442 /*     COMMONS USED   : */
 443 /*     ---------------- */
 444
 445 /*     REFERENCES CALLED   : */
 446 /*     ----------------------- */
 447
 448 /*     DESCRIPTION/NOTES/LIMITATIONS : */
 449 /*     ----------------------------------- */
 450 /*     This routine is useful to prepare coefficients of a */
 451 /*     curve in an orthogonal base (Legendre or Jacobi) before */
 452 /*     calculating the coefficients in the canonical; base [-1,1] by */
 453 /*     MMJACAN. */
 454 /* ***********************************************************************
 455  */
 456
 457 /*   Name of the routine */
 458
 459     /* Parameter adjustments */
 460     crvold_dim1 = *ncofmx;
 461     crvold_offset = crvold_dim1;
 462     crvold -= crvold_offset;
 463     crvnew_dim1 = (*ncoeff - 1) / 2 + 1;
 464     crvnew_offset = crvnew_dim1 << 1;
 465     crvnew -= crvnew_offset;
 466
 467     /* Function Body */
 468     ibb = AdvApp2Var_SysBase::mnfndeb_();
 469     if (ibb >= 3) {
 470         AdvApp2Var_SysBase::mgenmsg_("MMAPCMP", 7L);
 471     }
 472
 473     ndegre = *ncoeff - 1;
 474     i__1 = *ndim;
 475     for (nd = 1; nd <= i__1; ++nd) {
 476         ipair = 0;
 477         i__2 = ndegre / 2;
 478         for (idg = 0; idg <= i__2; ++idg) {
 479             crvnew[idg + (nd << 1) * crvnew_dim1] = crvold[ipair + nd *
 480                     crvold_dim1];
 481             ipair += 2;
 482 /* L200: */
 483         }
 484         if (ndegre < 1) {
 485             goto L400;
 486         }
 487         impair = 1;
 488         i__2 = (ndegre - 1) / 2;
 489         for (idg = 0; idg <= i__2; ++idg) {
 490             crvnew[idg + ((nd << 1) + 1) * crvnew_dim1] = crvold[impair + nd *
 491                      crvold_dim1];
 492             impair += 2;
 493 /* L300: */
 494         }
 495
 496 L400:
 497 /* L100: */
 498         ;
 499     }
 500
 501 /* ---------------------------------- The end ---------------------------
 502 */
 503
 504     if (ibb >= 3) {
 505         AdvApp2Var_SysBase::mgsomsg_("MMAPCMP", 7L);
 506     }
 507     return 0;
 508 } /* mmapcmp_ */
 509
 510 //=======================================================================
 511 //function : mmaper0_
 512 //purpose  :
 513 //=======================================================================
 514 int mmaper0_(integer *ncofmx,
 515              integer *ndimen,
 516              integer *ncoeff,
 517              doublereal *crvlgd,
 518              integer *ncfnew,
 519              doublereal *ycvmax,
 520              doublereal *errmax)
 521
 522 {
 523   /* System generated locals */
 524   integer crvlgd_dim1, crvlgd_offset, i__1, i__2;
 525   doublereal d__1;
 526
 527   /* Local variables */
 528   static integer ncut;
 529     static doublereal bidon;
 530   static integer ii, nd;
 531
 532
 533 /* ***********************************************************************
 534  */
 535
 536 /*     FUNCTION : */
 537 /*     ---------- */
 538 /*        Calculate the max error of approximation done when */
 539 /*        only the first NCFNEW coefficients of a curve are preserved.
 540 */
 541 /*        Degree NCOEFF-1 written in the base of Legendre (Jacobi */
 542 /*        of  order 0). */
 543
 544 /*     KEYWORDS : */
 545 /*     ----------- */
 546 /*        LEGENDRE,POLYGON,APPROXIMATION,ERROR. */
 547
 548 /*     INPUT ARGUMENTS : */
 549 /*     ------------------ */
 550 /*        NCOFMX : Max. degree of the curve. */
 551 /*        NDIMEN : Space dimension. */
 552 /*        NCOEFF : Degree +1 of the curve. */
 553 /*        CRVLGD : Curve the degree which of should be lowered. */
 554 /*        NCFNEW : Degree +1 of the resulting polynom. */
 555
 556 /*     OUTPUT ARGUMENTS : */
 557 /*     ------------------- */
 558 /*        YCVMAX : Auxiliary Table (max error on each dimension).
 559 */
 560 /*        ERRMAX : Precision of the approximation. */
 561
 562 /*     COMMONS USED   : */
 563 /*     ---------------- */
 564
 565 /*     REFERENCES CALLED   : */
 566 /*     ----------------------- */
 567
 568 /*     DESCRIPTION/NOTES/LIMITATIONS : */
 569 /*     ----------------------------------- */
 570 /* ***********************************************************************
 571  */
 572
 573
 574 /* ------------------- Init to calculate an error -----------------------
 575 */
 576
 577     /* Parameter adjustments */
 578     --ycvmax;
 579     crvlgd_dim1 = *ncofmx;
 580     crvlgd_offset = crvlgd_dim1 + 1;
 581     crvlgd -= crvlgd_offset;
 582
 583     /* Function Body */
 584     i__1 = *ndimen;
 585     for (ii = 1; ii <= i__1; ++ii) {
 586         ycvmax[ii] = 0.;
 587 /* L100: */
 588     }
 589
 590 /* ------ Minimum that can be reached : Stop at 1 or NCFNEW ------
 591 */
 592
 593     ncut = 1;
 594     if (*ncfnew + 1 > ncut) {
 595         ncut = *ncfnew + 1;
 596     }
 597
 598 /* -------------- Elimination of high degree coefficients-----------
 599 */
 600 /* ----------- Loop on the series of Legendre: NCUT --> NCOEFF --------
 601 */
 602
 603     i__1 = *ncoeff;
 604     for (ii = ncut; ii <= i__1; ++ii) {
 605 /*   Factor of renormalization (Maximum of Li(t)). */
 606         bidon = ((ii - 1) * 2. + 1.) / 2.;
 607         bidon = sqrt(bidon);
 608
 609         i__2 = *ndimen;
 610         for (nd = 1; nd <= i__2; ++nd) {
 611             ycvmax[nd] += (d__1 = crvlgd[ii + nd * crvlgd_dim1], abs(d__1)) *
 612                     bidon;
 613 /* L310: */
 614         }
 615 /* L300: */
 616     }
 617
 618 /* -------------- The error is the norm of the vector error ---------------
 619 */
 620
 621     *errmax = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
 622
 623 /* --------------------------------- Fin --------------------------------
 624 */
 625
 626     return 0;
 627 } /* mmaper0_ */
 628
 629 //=======================================================================
 630 //function : mmaper2_
 631 //purpose  :
 632 //=======================================================================
 633 int mmaper2_(integer *ncofmx,
 634              integer *ndimen,
 635              integer *ncoeff,
 636              doublereal *crvjac,
 637              integer *ncfnew,
 638              doublereal *ycvmax,
 639              doublereal *errmax)
 640
 641 {
 642   /* Initialized data */
 643
 644     static doublereal xmaxj[57] = { .9682458365518542212948163499456,
 645             .986013297183269340427888048593603,
 646             1.07810420343739860362585159028115,
 647             1.17325804490920057010925920756025,
 648             1.26476561266905634732910520370741,
 649             1.35169950227289626684434056681946,
 650             1.43424378958284137759129885012494,
 651             1.51281316274895465689402798226634,
 652             1.5878364329591908800533936587012,
 653             1.65970112228228167018443636171226,
 654             1.72874345388622461848433443013543,
 655             1.7952515611463877544077632304216,
 656             1.85947199025328260370244491818047,
 657             1.92161634324190018916351663207101,
 658             1.98186713586472025397859895825157,
 659             2.04038269834980146276967984252188,
 660             2.09730119173852573441223706382076,
 661             2.15274387655763462685970799663412,
 662             2.20681777186342079455059961912859,
 663             2.25961782459354604684402726624239,
 664             2.31122868752403808176824020121524,
 665             2.36172618435386566570998793688131,
 666             2.41117852396114589446497298177554,
 667             2.45964731268663657873849811095449,
 668             2.50718840313973523778244737914028,
 669             2.55385260994795361951813645784034,
 670             2.59968631659221867834697883938297,
 671             2.64473199258285846332860663371298,
 672             2.68902863641518586789566216064557,
 673             2.73261215675199397407027673053895,
 674             2.77551570192374483822124304745691,
 675             2.8177699459714315371037628127545,
 676             2.85940333797200948896046563785957,
 677             2.90044232019793636101516293333324,
 678             2.94091151970640874812265419871976,
 679             2.98083391718088702956696303389061,
 680             3.02023099621926980436221568258656,
 681             3.05912287574998661724731962377847,
 682             3.09752842783622025614245706196447,
 683             3.13546538278134559341444834866301,
 684             3.17295042316122606504398054547289,
 685             3.2099992681699613513775259670214,
 686             3.24662674946606137764916854570219,
 687             3.28284687953866689817670991319787,
 688             3.31867291347259485044591136879087,
 689             3.35411740487202127264475726990106,
 690             3.38919225660177218727305224515862,
 691             3.42390876691942143189170489271753,
 692             3.45827767149820230182596660024454,
 693             3.49230918177808483937957161007792,
 694             3.5260130200285724149540352829756,
 695             3.55939845146044235497103883695448,
 696             3.59247431368364585025958062194665,
 697             3.62524904377393592090180712976368,
 698             3.65773070318071087226169680450936,
 699             3.68992700068237648299565823810245,
 700             3.72184531357268220291630708234186 };
 701
 702     /* System generated locals */
 703     integer crvjac_dim1, crvjac_offset, i__1, i__2;
 704     doublereal d__1;
 705
 706     /* Local variables */
 707     static integer idec, ncut;
 708     static doublereal bidon;
 709     static integer ii, nd;
 710
 711
 712
 713 /* ***********************************************************************
 714  */
 715
 716 /*     FONCTION : */
 717 /*     ---------- */
 718 /*        Calculate max approximation error i faite lorsque l' on */
 719 /*        ne conserve que les premiers NCFNEW coefficients d' une courbe
 720 */
 721 /*        de degre NCOEFF-1 ecrite dans la base de Jacobi d' ordre 2. */
 722
 723 /*     KEYWORDS : */
 724 /*     ----------- */
 725 /*        JACOBI, POLYGON, APPROXIMATION, ERROR. */
 726 /*
 727 /*  INPUT ARGUMENTS : */
 728 /*     ------------------ */
 729 /*        NCOFMX : Max. degree of the curve. */
 730 /*        NDIMEN : Space dimension. */
 731 /*        NCOEFF : Degree +1 of the curve. */
 732 /*        CRVLGD : Curve the degree which of should be lowered. */
 733 /*        NCFNEW : Degree +1 of the resulting polynom. */
 734
 735 /*     OUTPUT ARGUMENTS : */
 736 /*     ------------------- */
 737 /*        YCVMAX : Auxiliary Table (max error on each dimension).
 738 */
 739 /*        ERRMAX : Precision of the approximation. */
 740
 741 /*     COMMONS USED   : */
 742 /*     ---------------- */
 743
 744 /*     REFERENCES CALLED   : */
 745 /*     ----------------------- */
 746 /*     DESCRIPTION/NOTES/LIMITATIONS : */
 747 /*     ----------------------------------- */
 748
 749
 750
 751 /* ------------------ Table of maximums of (1-t2)*Ji(t) ----------------
 752 */
 753
 754     /* Parameter adjustments */
 755     --ycvmax;
 756     crvjac_dim1 = *ncofmx;
 757     crvjac_offset = crvjac_dim1 + 1;
 758     crvjac -= crvjac_offset;
 759
 760     /* Function Body */
 761
 762
 763
 764 /* ------------------- Init for error  calculation -----------------------
 765 */
 766
 767     i__1 = *ndimen;
 768     for (ii = 1; ii <= i__1; ++ii) {
 769         ycvmax[ii] = 0.;
 770 /* L100: */
 771     }
 772
 773 /* ------ Min. Degree that can be attained : Stop at 3 or NCFNEW ------
 774 */
 775
 776     idec = 3;
 777 /* Computing MAX */
 778     i__1 = idec, i__2 = *ncfnew + 1;
 779     ncut = max(i__1,i__2);
 780
 781 /* -------------- Removal of coefficients of high degree -----------
 782 */
 783 /* ----------- Loop on the series of Jacobi :NCUT --> NCOEFF ----------
 784 */
 785
 786     i__1 = *ncoeff;
 787     for (ii = ncut; ii <= i__1; ++ii) {
 788 /*   Factor of renormalization. */
 789         bidon = xmaxj[ii - idec];
 790         i__2 = *ndimen;
 791         for (nd = 1; nd <= i__2; ++nd) {
 792             ycvmax[nd] += (d__1 = crvjac[ii + nd * crvjac_dim1], abs(d__1)) *
 793                     bidon;
 794 /* L310: */
 795         }
 796 /* L300: */
 797     }
 798
 799 /* -------------- The error is the norm of the vector error ---------------
 800 */
 801
 802     *errmax = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
 803
 804 /* --------------------------------- Fin --------------------------------
 805 */
 806
 807     return 0;
 808 } /* mmaper2_ */
 809
 810 /* MAPER4.f -- translated by f2c (version 19960827).
 811    You must link the resulting object file with the libraries:
 812         -lf2c -lm   (in that order)
 813 */
 814
 815 /* Subroutine */
 816 //=======================================================================
 817 //function : mmaper4_
 818 //purpose  :
 819 //=======================================================================
 820 int mmaper4_(integer *ncofmx,
 821              integer *ndimen,
 822              integer *ncoeff,
 823              doublereal *crvjac,
 824              integer *ncfnew,
 825              doublereal *ycvmax,
 826              doublereal *errmax)
 827 {
 828     /* Initialized data */
 829
 830     static doublereal xmaxj[55] = { 1.1092649593311780079813740546678,
 831             1.05299572648705464724876659688996,
 832             1.0949715351434178709281698645813,
 833             1.15078388379719068145021100764647,
 834             1.2094863084718701596278219811869,
 835             1.26806623151369531323304177532868,
 836             1.32549784426476978866302826176202,
 837             1.38142537365039019558329304432581,
 838             1.43575531950773585146867625840552,
 839             1.48850442653629641402403231015299,
 840             1.53973611681876234549146350844736,
 841             1.58953193485272191557448229046492,
 842             1.63797820416306624705258190017418,
 843             1.68515974143594899185621942934906,
 844             1.73115699602477936547107755854868,
 845             1.77604489805513552087086912113251,
 846             1.81989256661534438347398400420601,
 847             1.86276344480103110090865609776681,
 848             1.90471563564740808542244678597105,
 849             1.94580231994751044968731427898046,
 850             1.98607219357764450634552790950067,
 851             2.02556989246317857340333585562678,
 852             2.06433638992049685189059517340452,
 853             2.10240936014742726236706004607473,
 854             2.13982350649113222745523925190532,
 855             2.17661085564771614285379929798896,
 856             2.21280102016879766322589373557048,
 857             2.2484214321456956597803794333791,
 858             2.28349755104077956674135810027654,
 859             2.31805304852593774867640120860446,
 860             2.35210997297725685169643559615022,
 861             2.38568889602346315560143377261814,
 862             2.41880904328694215730192284109322,
 863             2.45148841120796359750021227795539,
 864             2.48374387161372199992570528025315,
 865             2.5155912654873773953959098501893,
 866             2.54704548720896557684101746505398,
 867             2.57812056037881628390134077704127,
 868             2.60882970619319538196517982945269,
 869             2.63918540521920497868347679257107,
 870             2.66919945330942891495458446613851,
 871             2.69888301230439621709803756505788,
 872             2.72824665609081486737132853370048,
 873             2.75730041251405791603760003778285,
 874             2.78605380158311346185098508516203,
 875             2.81451587035387403267676338931454,
 876             2.84269522483114290814009184272637,
 877             2.87060005919012917988363332454033,
 878             2.89823818258367657739520912946934,
 879             2.92561704377132528239806135133273,
 880             2.95274375377994262301217318010209,
 881             2.97962510678256471794289060402033,
 882             3.00626759936182712291041810228171,
 883             3.03267744830655121818899164295959,
 884             3.05886060707437081434964933864149 };
 885
 886     /* System generated locals */
 887     integer crvjac_dim1, crvjac_offset, i__1, i__2;
 888     doublereal d__1;
 889
 890     /* Local variables */
 891     static integer idec, ncut;
 892     static doublereal bidon;
 893     static integer ii, nd;
 894
 895
 896
 897 /* ***********************************************************************
 898  */
 899
 900 /*     FUNCTION : */
 901 /*     ---------- */
 902 /*        Calculate the max. error of approximation made when  */
 903 /*        only first NCFNEW coefficients of a curve are preserved
 904 */
 905 /*        degree NCOEFF-1 is written in the base of Jacobi of order 4. */
 906 /*        KEYWORDS : */
 907 /*     ----------- */
 908 /*        LEGENDRE,POLYGON,APPROXIMATION,ERROR. */
 909
 910 /*     INPUT ARGUMENTS : */
 911 /*     ------------------ */
 912 /*        NCOFMX : Max. degree of the curve. */
 913 /*        NDIMEN : Space dimension. */
 914 /*        NCOEFF : Degree +1 of the curve. */
 915 /*        CRVJAC : Curve the degree which of should be lowered. */
 916 /*        NCFNEW : Degree +1 of the resulting polynom. */
 917
 918 /*     OUTPUT ARGUMENTS : */
 919 /*     ------------------- */
 920 /*        YCVMAX : Auxiliary Table (max error on each dimension).
 921 */
 922 /*        ERRMAX : Precision of the approximation. */
 923
 924 /*     COMMONS USED   : */
 925 /*     ---------------- */
 926
 927 /*     REFERENCES CALLED   : */
 928 /*     ----------------------- */
 929
 930 /*     DESCRIPTION/NOTES/LIMITATIONS : */
 931
 932
 933 /* ***********************************************************************
 934  */
 935
 936
 937 /* ---------------- Table of maximums of ((1-t2)2)*Ji(t) ---------------
 938 */
 939
 940     /* Parameter adjustments */
 941     --ycvmax;
 942     crvjac_dim1 = *ncofmx;
 943     crvjac_offset = crvjac_dim1 + 1;
 944     crvjac -= crvjac_offset;
 945
 946     /* Function Body */
 947
 948
 949
 950 /* ------------------- Init for error calculation -----------------------
 951 */
 952
 953     i__1 = *ndimen;
 954     for (ii = 1; ii <= i__1; ++ii) {
 955         ycvmax[ii] = 0.;
 956 /* L100: */
 957     }
 958
 959 /* ------ Min. Degree that can be attained : Stop at 5 or NCFNEW ------
 960 */
 961
 962     idec = 5;
 963 /* Computing MAX */
 964     i__1 = idec, i__2 = *ncfnew + 1;
 965     ncut = max(i__1,i__2);
 966
 967 /* -------------- Removal of high degree coefficients -----------
 968 */
 969 /* ----------- Loop on the series of Jacobi :NCUT --> NCOEFF ----------
 970 */
 971
 972     i__1 = *ncoeff;
 973     for (ii = ncut; ii <= i__1; ++ii) {
 974 /*   Factor of renormalisation. */
 975         bidon = xmaxj[ii - idec];
 976         i__2 = *ndimen;
 977         for (nd = 1; nd <= i__2; ++nd) {
 978             ycvmax[nd] += (d__1 = crvjac[ii + nd * crvjac_dim1], abs(d__1)) *
 979                     bidon;
 980 /* L310: */
 981         }
 982 /* L300: */
 983     }
 984
 985 /* -------------- The error is the norm of the error vector ---------------
 986 */
 987
 988     *errmax = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
 989
 990 /* --------------------------------- End --------------------------------
 991 */
 992
 993     return 0;
 994 } /* mmaper4_ */
 995
 996 //=======================================================================
 997 //function : mmaper6_
 998 //purpose  :
 999 //=======================================================================
1000 int mmaper6_(integer *ncofmx,
1001              integer *ndimen,
1002              integer *ncoeff,
1003              doublereal *crvjac,
1004              integer *ncfnew,
1005              doublereal *ycvmax,
1006              doublereal *errmax)
1007
1008 {
1009     /* Initialized data */
1010
1011     static doublereal xmaxj[53] = { 1.21091229812484768570102219548814,
1012             1.11626917091567929907256116528817,
1013             1.1327140810290884106278510474203,
1014             1.1679452722668028753522098022171,
1015             1.20910611986279066645602153641334,
1016             1.25228283758701572089625983127043,
1017             1.29591971597287895911380446311508,
1018             1.3393138157481884258308028584917,
1019             1.3821288728999671920677617491385,
1020             1.42420414683357356104823573391816,
1021             1.46546895108549501306970087318319,
1022             1.50590085198398789708599726315869,
1023             1.54550385142820987194251585145013,
1024             1.58429644271680300005206185490937,
1025             1.62230484071440103826322971668038,
1026             1.65955905239130512405565733793667,
1027             1.69609056468292429853775667485212,
1028             1.73193098017228915881592458573809,
1029             1.7671112206990325429863426635397,
1030             1.80166107681586964987277458875667,
1031             1.83560897003644959204940535551721,
1032             1.86898184653271388435058371983316,
1033             1.90180515174518670797686768515502,
1034             1.93410285411785808749237200054739,
1035             1.96589749778987993293150856865539,
1036             1.99721027139062501070081653790635,
1037             2.02806108474738744005306947877164,
1038             2.05846864831762572089033752595401,
1039             2.08845055210580131460156962214748,
1040             2.11802334209486194329576724042253,
1041             2.14720259305166593214642386780469,
1042             2.17600297710595096918495785742803,
1043             2.20443832785205516555772788192013,
1044             2.2325216999457379530416998244706,
1045             2.2602654243075083168599953074345,
1046             2.28768115912702794202525264301585,
1047             2.3147799369092684021274946755348,
1048             2.34157220782483457076721300512406,
1049             2.36806787963276257263034969490066,
1050             2.39427635443992520016789041085844,
1051             2.42020656255081863955040620243062,
1052             2.44586699364757383088888037359254,
1053             2.47126572552427660024678584642791,
1054             2.49641045058324178349347438430311,
1055             2.52130850028451113942299097584818,
1056             2.54596686772399937214920135190177,
1057             2.5703922285006754089328998222275,
1058             2.59459096001908861492582631591134,
1059             2.61856915936049852435394597597773,
1060             2.64233265984385295286445444361827,
1061             2.66588704638685848486056711408168,
1062             2.68923766976735295746679957665724,
1063             2.71238965987606292679677228666411 };
1064
1065     /* System generated locals */
1066     integer crvjac_dim1, crvjac_offset, i__1, i__2;
1067     doublereal d__1;
1068
1069     /* Local variables */
1070     static integer idec, ncut;
1071     static doublereal bidon;
1072     static integer ii, nd;
1073
1074
1075
1076 /* ***********************************************************************
1077  */
1078 /*     FUNCTION : */
1079 /*     ---------- */
1080 /*        Calculate the max. error of approximation made when  */
1081 /*        only first NCFNEW coefficients of a curve are preserved
1082 */
1083 /*        degree NCOEFF-1 is written in the base of Jacobi of order 6. */
1084 /*        KEYWORDS : */
1085 /*     ----------- */
1086 /*        JACOBI,POLYGON,APPROXIMATION,ERROR. */
1087
1088 /*     INPUT ARGUMENTS : */
1089 /*     ------------------ */
1090 /*        NCOFMX : Max. degree of the curve. */
1091 /*        NDIMEN : Space dimension. */
1092 /*        NCOEFF : Degree +1 of the curve. */
1093 /*        CRVJAC : Curve the degree which of should be lowered. */
1094 /*        NCFNEW : Degree +1 of the resulting polynom. */
1095
1096 /*     OUTPUT ARGUMENTS : */
1097 /*     ------------------- */
1098 /*        YCVMAX : Auxiliary Table (max error on each dimension).
1099 */
1100 /*        ERRMAX : Precision of the approximation. */
1101
1102 /*     COMMONS USED   : */
1103 /*     ---------------- */
1104
1105 /*     REFERENCES CALLED   : */
1106 /*     ----------------------- */
1107
1108 /*     DESCRIPTION/NOTES/LIMITATIONS : */
1109 /* > */
1110 /* ***********************************************************************
1111  */
1112
1113
1114 /* ---------------- Table of maximums of ((1-t2)3)*Ji(t) ---------------
1115 */
1116
1117     /* Parameter adjustments */
1118     --ycvmax;
1119     crvjac_dim1 = *ncofmx;
1120     crvjac_offset = crvjac_dim1 + 1;
1121     crvjac -= crvjac_offset;
1122
1123     /* Function Body */
1124
1125
1126
1127 /* ------------------- Init for error calculation -----------------------
1128 */
1129
1130     i__1 = *ndimen;
1131     for (ii = 1; ii <= i__1; ++ii) {
1132         ycvmax[ii] = 0.;
1133 /* L100: */
1134     }
1135
1136 /* ------ Min Degree that can be attained : Stop at 3 or NCFNEW ------
1137 */
1138
1139     idec = 7;
1140 /* Computing MAX */
1141     i__1 = idec, i__2 = *ncfnew + 1;
1142     ncut = max(i__1,i__2);
1143
1144 /* -------------- Removal of high degree coefficients -----------
1145 */
1146 /* ----------- Loop on the series of Jacobi :NCUT --> NCOEFF ----------
1147 */
1148
1149     i__1 = *ncoeff;
1150     for (ii = ncut; ii <= i__1; ++ii) {
1151 /*   Factor of renormalization. */
1152         bidon = xmaxj[ii - idec];
1153         i__2 = *ndimen;
1154         for (nd = 1; nd <= i__2; ++nd) {
1155             ycvmax[nd] += (d__1 = crvjac[ii + nd * crvjac_dim1], abs(d__1)) *
1156                     bidon;
1157 /* L310: */
1158         }
1159 /* L300: */
1160     }
1161
1162 /* -------------- The error is the norm of the vector error ---------------
1163 */
1164
1165     *errmax = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
1166
1167 /* --------------------------------- END --------------------------------
1168 */
1169
1170     return 0;
1171 } /* mmaper6_ */
1172
1173 //=======================================================================
1174 //function : AdvApp2Var_MathBase::mmaperx_
1175 //purpose  :
1176 //=======================================================================
1177 int AdvApp2Var_MathBase::mmaperx_(integer *ncofmx,
1178                                   integer *ndimen,
1179                                   integer *ncoeff,
1180                                   integer *iordre,
1181                                   doublereal *crvjac,
1182                                   integer *ncfnew,
1183                                   doublereal *ycvmax,
1184                                   doublereal *errmax,
1185                                   integer *iercod)
1186
1187 {
1188   /* System generated locals */
1189   integer crvjac_dim1, crvjac_offset;
1190
1191   /* Local variables */
1192   static integer jord;
1193
1194
1195 /* **********************************************************************
1196 */
1197 /*     FUNCTION : */
1198 /*     ---------- */
1199 /*        Calculate the max. error of approximation made when  */
1200 /*        only first NCFNEW coefficients of a curve are preserved
1201 */
1202 /*        degree NCOEFF-1 is written in the base of Jacobi of order IORDRE. */
1203 /*        KEYWORDS : */
1204 /*     ----------- */
1205 /*        JACOBI,LEGENDRE,POLYGON,APPROXIMATION,ERROR. */
1206
1207 /*     INPUT ARGUMENTS : */
1208 /*     ------------------ */
1209 /*        NCOFMX : Max. degree of the curve. */
1210 /*        NDIMEN : Space dimension. */
1211 /*        NCOEFF : Degree +1 of the curve. */
1212 /*        IORDRE : Order of continuity at the extremities. */
1213 /*        CRVJAC : Curve the degree which of should be lowered. */
1214 /*        NCFNEW : Degree +1 of the resulting polynom. */
1215
1216 /*     OUTPUT ARGUMENTS : */
1217 /*     ------------------- */
1218 /*        YCVMAX : Auxiliary Table (max error on each dimension).
1219 */
1220 /*        ERRMAX : Precision of the approximation. */
1221 /*        IERCOD = 0, OK */
1222 /*               = 1, order of constraints (IORDRE) is not within the */
1223 /*                    autorized values. */
1224 /*     COMMONS USED   : */
1225 /*     ---------------- */
1226
1227 /*     REFERENCES CALLED   : */
1228 /*     ----------------------- */
1229
1230 /*     DESCRIPTION/NOTES/LIMITATIONS : */
1231 /*     ----------------------------------- */
1232 /*     Canceled and replaced MMAPERR. */
1233 /* ***********************************************************************
1234  */
1235
1236
1237     /* Parameter adjustments */
1238     --ycvmax;
1239     crvjac_dim1 = *ncofmx;
1240     crvjac_offset = crvjac_dim1 + 1;
1241     crvjac -= crvjac_offset;
1242
1243     /* Function Body */
1244     *iercod = 0;
1245 /* --> Order of Jacobi polynoms */
1246     jord = ( *iordre + 1) << 1;
1247
1248     if (jord == 0) {
1249         mmaper0_(ncofmx, ndimen, ncoeff, &crvjac[crvjac_offset], ncfnew, &
1250                 ycvmax[1], errmax);
1251     } else if (jord == 2) {
1252         mmaper2_(ncofmx, ndimen, ncoeff, &crvjac[crvjac_offset], ncfnew, &
1253                 ycvmax[1], errmax);
1254     } else if (jord == 4) {
1255         mmaper4_(ncofmx, ndimen, ncoeff, &crvjac[crvjac_offset], ncfnew, &
1256                 ycvmax[1], errmax);
1257     } else if (jord == 6) {
1258         mmaper6_(ncofmx, ndimen, ncoeff, &crvjac[crvjac_offset], ncfnew, &
1259                 ycvmax[1], errmax);
1260     } else {
1261         *iercod = 1;
1262     }
1263
1264 /* ----------------------------------- Fin ------------------------------
1265 */
1266
1267     return 0;
1268 } /* mmaperx_ */
1269
1270 //=======================================================================
1271 //function : mmarc41_
1272 //purpose  :
1273 //=======================================================================
1274  int mmarc41_(integer *ndimax,
1275               integer *ndimen,
1276               integer *ncoeff,
1277               doublereal *crvold,
1278               doublereal *upara0,
1279               doublereal *upara1,
1280               doublereal *crvnew,
1281               integer *iercod)
1282
1283 {
1284   /* System generated locals */
1285     integer crvold_dim1, crvold_offset, crvnew_dim1, crvnew_offset, i__1,
1286     i__2, i__3;
1287
1288     /* Local variables */
1289     static integer nboct;
1290     static doublereal tbaux[61];
1291     static integer nd;
1292     static doublereal bid;
1293     static integer ncf, ncj;
1294
1295
1296 /*      IMPLICIT DOUBLE PRECISION(A-H,O-Z) */
1297 /*      IMPLICIT INTEGER (I-N) */
1298
1299 /* ***********************************************************************
1300  */
1301
1302 /*     FUNCTION : */
1303 /*     ---------- */
1304 /*     Creation of curve C2(v) defined on (0,1) identic to */
1305 /*     curve C1(u) defined on (U0,U1) (change of parameter */
1306 /*     of a curve). */
1307
1308 /*     KEYWORDS : */
1309 /*     ----------- */
1310 /*        LIMITATION, RESTRICTION, CURVE */
1311
1312 /*     INPUT ARGUMENTS : */
1313 /*     ------------------ */
1314 /*   NDIMAX : Space Dimensioning. */
1315 /*   NDIMEN : Curve Dimension. */
1316 /*   NCOEFF : Nb of coefficients of the curve. */
1317 /*   CRVOLD : Curve to be limited. */
1318 /*   UPARA0     : Min limit of the interval limiting the curve.
1319 */
1320 /*   UPARA1     : Max limit of the interval limiting the curve.
1321 */
1322
1323 /*     OUTPUT ARGUMENTS : */
1324 /*     ------------------- */
1325 /*   CRVNEW : Relimited curve, defined on (0,1) and equal to */
1326 /*            CRVOLD defined on (U0,U1). */
1327 /*   IERCOD : = 0, OK */
1328 /*            =10, Nb of coeff. <1 or > 61. */
1329
1330 /*     COMMONS USED   : */
1331 /*     ---------------- */
1332 /*     REFERENCES CALLED   : */
1333 /*     ---------------------- */
1334 /*     Type  Name */
1335 /*           MAERMSG              MCRFILL              MVCVIN2 */
1336 /*           MVCVINV */
1337
1338 /*     DESCRIPTION/NOTES/LIMITATIONS : */
1339 /*     ----------------------------------- */
1340 /* ---> Algorithm used in this general case is based on the */
1341 /*     following principle  : */
1342 /*        Let S(t) = a0 + a1*t + a2*t**2 + ... of degree NCOEFF-1, and */
1343 /*               U(t) = b0 + b1*t, then the coeff. of */
1344 /*        S(U(t)) are calculated step by step with help of table TBAUX. */
1345 /*        At each step number N (N=2 to NCOEFF), TBAUX(n) contains */
1346 /*        the n-th coefficient of U(t)**N for n=1 to N. (RBD) */
1347 /* ---> Reference : KNUTH, 'The Art of Computer Programming', */
1348 /*                        Vol. 2/'Seminumerical Algorithms', */
1349 /*                        Ex. 11 p:451 et solution p:562. (RBD) */
1350
1351 /* ---> Removal of the input argument CRVOLD by CRVNEW is */
1352 /*     possible, which means that the call : */
1353 /*       CALL MMARC41(NDIMAX,NDIMEN,NCOEFF,CURVE,UPARA0,UPARA1 */
1354 /*                  ,CURVE,IERCOD) */
1355 /*     is absolutely LEGAL. (RBD) */
1356
1357 /* > */
1358 /* **********************************************************************
1359 */
1360
1361 /*   Name of the routine */
1362
1363 /*   Auxiliary table of coefficients of (UPARA1-UPARA0)T+UPARA0  */
1364 /*   with power N=1 to NCOEFF-1. */
1365
1366
1367     /* Parameter adjustments */
1368     crvnew_dim1 = *ndimax;
1369     crvnew_offset = crvnew_dim1 + 1;
1370     crvnew -= crvnew_offset;
1371     crvold_dim1 = *ndimax;
1372     crvold_offset = crvold_dim1 + 1;
1373     crvold -= crvold_offset;
1374
1375     /* Function Body */
1376     *iercod = 0;
1377 /* **********************************************************************
1378 */
1379 /*                CASE WHEN PROCESSING CAN'T BE DONE */
1380 /* **********************************************************************
1381 */
1382     if (*ncoeff > 61 || *ncoeff < 1) {
1383         *iercod = 10;
1384         goto L9999;
1385     }
1386 /* **********************************************************************
1387 */
1388 /*                         IF NO CHANGES */
1389 /* **********************************************************************
1390 */
1391     if (*ndimen == *ndimax && *upara0 == 0. && *upara1 == 1.) {
1392         nboct = (*ndimax << 3) * *ncoeff;
1393         AdvApp2Var_SysBase::mcrfill_((integer *)&nboct,
1394                  (char *)&crvold[crvold_offset],
1395                  (char *)&crvnew[crvnew_offset]);
1396         goto L9999;
1397     }
1398 /* **********************************************************************
1399 */
1400 /*                    INVERSION 3D : FAST PROCESSING */
1401 /* **********************************************************************
1402 */
1403     if (*upara0 == 1. && *upara1 == 0.) {
1404         if (*ndimen == 3 && *ndimax == 3 && *ncoeff <= 21) {
1405             mvcvinv_(ncoeff, &crvold[crvold_offset], &crvnew[crvnew_offset],
1406                     iercod);
1407             goto L9999;
1408         }
1409 /* ******************************************************************
1410 **** */
1411 /*                    INVERSION 2D : FAST PROCESSING */
1412 /* ******************************************************************
1413 **** */
1414         if (*ndimen == 2 && *ndimax == 2 && *ncoeff <= 21) {
1415             mvcvin2_(ncoeff, &crvold[crvold_offset], &crvnew[crvnew_offset],
1416                     iercod);
1417             goto L9999;
1418         }
1419     }
1420 /* **********************************************************************
1421 */
1422 /*                          GENERAL PROCESSING */
1423 /* **********************************************************************
1424 */
1425 /* -------------------------- Initializations ---------------------------
1426 */
1427
1428     i__1 = *ndimen;
1429     for (nd = 1; nd <= i__1; ++nd) {
1430         crvnew[nd + crvnew_dim1] = crvold[nd + crvold_dim1];
1431 /* L100: */
1432     }
1433     if (*ncoeff == 1) {
1434         goto L9999;
1435     }
1436     tbaux[0] = *upara0;
1437     tbaux[1] = *upara1 - *upara0;
1438
1439 /* ----------------------- Calculation of coeff. of CRVNEW ------------------
1440 */
1441
1442     i__1 = *ncoeff - 1;
1443     for (ncf = 2; ncf <= i__1; ++ncf) {
1444
1445 /* ------------ Take into account NCF-th coeff. of CRVOLD --------
1446 ---- */
1447
1448         i__2 = ncf - 1;
1449         for (ncj = 1; ncj <= i__2; ++ncj) {
1450             bid = tbaux[ncj - 1];
1451             i__3 = *ndimen;
1452             for (nd = 1; nd <= i__3; ++nd) {
1453                 crvnew[nd + ncj * crvnew_dim1] += crvold[nd + ncf *
1454                         crvold_dim1] * bid;
1455 /* L400: */
1456             }
1457 /* L300: */
1458         }
1459
1460         bid = tbaux[ncf - 1];
1461         i__2 = *ndimen;
1462         for (nd = 1; nd <= i__2; ++nd) {
1463             crvnew[nd + ncf * crvnew_dim1] = crvold[nd + ncf * crvold_dim1] *
1464                     bid;
1465 /* L500: */
1466         }
1467
1468 /* --------- Calculate (NCF+1) coeff. of ((U1-U0)*t + U0)**(NCF) ---
1469 ---- */
1470
1471         bid = *upara1 - *upara0;
1472         tbaux[ncf] = tbaux[ncf - 1] * bid;
1473         for (ncj = ncf; ncj >= 2; --ncj) {
1474             tbaux[ncj - 1] = tbaux[ncj - 1] * *upara0 + tbaux[ncj - 2] * bid;
1475 /* L600: */
1476         }
1477         tbaux[0] *= *upara0;
1478
1479 /* L200: */
1480     }
1481
1482 /* -------------- Take into account the last coeff. of CRVOLD -----------
1483 */
1484
1485     i__1 = *ncoeff - 1;
1486     for (ncj = 1; ncj <= i__1; ++ncj) {
1487         bid = tbaux[ncj - 1];
1488         i__2 = *ndimen;
1489         for (nd = 1; nd <= i__2; ++nd) {
1490             crvnew[nd + ncj * crvnew_dim1] += crvold[nd + *ncoeff *
1491                     crvold_dim1] * bid;
1492 /* L800: */
1493         }
1494 /* L700: */
1495     }
1496     i__1 = *ndimen;
1497     for (nd = 1; nd <= i__1; ++nd) {
1498         crvnew[nd + *ncoeff * crvnew_dim1] = crvold[nd + *ncoeff *
1499                 crvold_dim1] * tbaux[*ncoeff - 1];
1500 /* L900: */
1501     }
1502
1503 /* ---------------------------- The end ---------------------------------
1504 */
1505
1506 L9999:
1507     if (*iercod != 0) {
1508         AdvApp2Var_SysBase::maermsg_("MMARC41", iercod, 7L);
1509     }
1510
1511  return 0 ;
1512 } /* mmarc41_ */
1513
1514 //=======================================================================
1515 //function : AdvApp2Var_MathBase::mmarcin_
1516 //purpose  :
1517 //=======================================================================
1518 int AdvApp2Var_MathBase::mmarcin_(integer *ndimax,
1519                                   integer *ndim,
1520                                   integer *ncoeff,
1521                                   doublereal *crvold,
1522                                   doublereal *u0,
1523                                   doublereal *u1,
1524                                   doublereal *crvnew,
1525                                   integer *iercod)
1526
1527 {
1528   /* System generated locals */
1529   integer crvold_dim1, crvold_offset, crvnew_dim1, crvnew_offset, i__1,
1530   i__2, i__3;
1531   doublereal d__1;
1532
1533   /* Local variables */
1534   static doublereal x0, x1;
1535   static integer nd;
1536   static doublereal tabaux[61];
1537   static integer ibb;
1538   static doublereal bid;
1539   static integer ncf;
1540   static integer ncj;
1541   static doublereal eps3;
1542
1543
1544
1545 /* **********************************************************************
1546 *//*     FUNCTION : */
1547 /*     ---------- */
1548 /*     Creation of curve C2(v) defined on [U0,U1] identic to */
1549 /*     curve C1(u) defined on [-1,1] (change of parameter */
1550 /*     of a curve) with INVERSION of indices of the resulting table. */
1551
1552 /*     KEYWORDS : */
1553 /*     ----------- */
1554 /*        GENERALIZED LIMITATION, RESTRICTION, INVERSION, CURVE */
1555
1556 /*     INPUT ARGUMENTS : */
1557 /*     ------------------ */
1558 /*   NDIMAX : Maximum Space Dimensioning. */
1559 /*   NDIMEN : Curve Dimension. */
1560 /*   NCOEFF : Nb of coefficients of the curve. */
1561 /*   CRVOLD : Curve to be limited. */
1562 /*   U0     : Min limit of the interval limiting the curve.
1563 */
1564 /*   U1     : Max limit of the interval limiting the curve.
1565 */
1566
1567 /*     OUTPUT ARGUMENTS : */
1568 /*     ------------------- */
1569 /*   CRVNEW : Relimited curve, defined on  [U0,U1] and equal to */
1570 /*            CRVOLD defined on [-1,1]. */
1571 /*   IERCOD : = 0, OK */
1572 /*            =10, Nb of coeff. <1 or > 61. */
1573 /*            =13, the requested interval of variation is null. */
1574 /*     COMMONS USED   : */
1575 /*     ---------------- */
1576 /*     REFERENCES CALLED   : */
1577 /*     ---------------------- */
1578 /*     DESCRIPTION/NOTES/LIMITATIONS : */
1579 /*     ----------------------------------- */
1580 /* > */
1581 /* **********************************************************************
1582 */
1583
1584 /*   Name of the routine */
1585
1586 /*   Auxiliary table of coefficients of X1*T+X0 */
1587 /*   with power N=1 to NCOEFF-1. */
1588
1589
1590     /* Parameter adjustments */
1591     crvnew_dim1 = *ndimax;
1592     crvnew_offset = crvnew_dim1 + 1;
1593     crvnew -= crvnew_offset;
1594     crvold_dim1 = *ncoeff;
1595     crvold_offset = crvold_dim1 + 1;
1596     crvold -= crvold_offset;
1597
1598     /* Function Body */
1599     ibb = AdvApp2Var_SysBase::mnfndeb_();
1600     if (ibb >= 2) {
1601         AdvApp2Var_SysBase::mgenmsg_("MMARCIN", 7L);
1602     }
1603
1604 /* At zero machine it is tested if the output interval is not null */
1605
1606     AdvApp2Var_MathBase::mmveps3_(&eps3);
1607     if ((d__1 = *u1 - *u0, abs(d__1)) < eps3) {
1608         *iercod = 13;
1609         goto L9999;
1610     }
1611     *iercod = 0;
1612
1613 /* **********************************************************************
1614 */
1615 /*                CASE WHEN THE PROCESSING IS IMPOSSIBLE */
1616 /* **********************************************************************
1617 */
1618     if (*ncoeff > 61 || *ncoeff < 1) {
1619         *iercod = 10;
1620         goto L9999;
1621     }
1622 /* **********************************************************************
1623 */
1624 /*          IF NO CHANGE OF THE INTERVAL OF DEFINITION */
1625 /*          (ONLY INVERSION OF INDICES OF TABLE CRVOLD) */
1626 /* **********************************************************************
1627 */
1628     if (*ndim == *ndimax && *u0 == -1. && *u1 == 1.) {
1629         AdvApp2Var_MathBase::mmcvinv_(ndim, ncoeff, ndim, &crvold[crvold_offset], &crvnew[
1630                 crvnew_offset]);
1631         goto L9999;
1632     }
1633 /* **********************************************************************
1634 */
1635 /*          CASE WHEN THE NEW INTERVAL OF DEFINITION IS [0,1] */
1636 /* **********************************************************************
1637 */
1638     if (*u0 == 0. && *u1 == 1.) {
1639         mmcvstd_(ncoeff, ndimax, ncoeff, ndim, &crvold[crvold_offset], &
1640                 crvnew[crvnew_offset]);
1641         goto L9999;
1642     }
1643 /* **********************************************************************
1644 */
1645 /*                          GENERAL PROCESSING */
1646 /* **********************************************************************
1647 */
1648 /* -------------------------- Initialization ---------------------------
1649 */
1650
1651     x0 = -(*u1 + *u0) / (*u1 - *u0);
1652     x1 = 2. / (*u1 - *u0);
1653     i__1 = *ndim;
1654     for (nd = 1; nd <= i__1; ++nd) {
1655         crvnew[nd + crvnew_dim1] = crvold[nd * crvold_dim1 + 1];
1656 /* L100: */
1657     }
1658     if (*ncoeff == 1) {
1659         goto L9999;
1660     }
1661     tabaux[0] = x0;
1662     tabaux[1] = x1;
1663
1664 /* ----------------------- Calculation of coeff. of CRVNEW ------------------
1665 */
1666
1667     i__1 = *ncoeff - 1;
1668     for (ncf = 2; ncf <= i__1; ++ncf) {
1669
1670 /* ------------ Take into account the NCF-th coeff. of CRVOLD --------
1671 ---- */
1672
1673         i__2 = ncf - 1;
1674         for (ncj = 1; ncj <= i__2; ++ncj) {
1675             bid = tabaux[ncj - 1];
1676             i__3 = *ndim;
1677             for (nd = 1; nd <= i__3; ++nd) {
1678                 crvnew[nd + ncj * crvnew_dim1] += crvold[ncf + nd *
1679                         crvold_dim1] * bid;
1680 /* L400: */
1681             }
1682 /* L300: */
1683         }
1684
1685         bid = tabaux[ncf - 1];
1686         i__2 = *ndim;
1687         for (nd = 1; nd <= i__2; ++nd) {
1688             crvnew[nd + ncf * crvnew_dim1] = crvold[ncf + nd * crvold_dim1] *
1689                     bid;
1690 /* L500: */
1691         }
1692
1693 /* --------- Calculation of (NCF+1) coeff. of [X1*t + X0]**(NCF) --------
1694 ---- */
1695
1696         tabaux[ncf] = tabaux[ncf - 1] * x1;
1697         for (ncj = ncf; ncj >= 2; --ncj) {
1698             tabaux[ncj - 1] = tabaux[ncj - 1] * x0 + tabaux[ncj - 2] * x1;
1699 /* L600: */
1700         }
1701         tabaux[0] *= x0;
1702
1703 /* L200: */
1704     }
1705
1706 /* -------------- Take into account the last coeff. of CRVOLD -----------
1707 */
1708
1709     i__1 = *ncoeff - 1;
1710     for (ncj = 1; ncj <= i__1; ++ncj) {
1711         bid = tabaux[ncj - 1];
1712         i__2 = *ndim;
1713         for (nd = 1; nd <= i__2; ++nd) {
1714             crvnew[nd + ncj * crvnew_dim1] += crvold[*ncoeff + nd *
1715                     crvold_dim1] * bid;
1716 /* L800: */
1717         }
1718 /* L700: */
1719     }
1720     i__1 = *ndim;
1721     for (nd = 1; nd <= i__1; ++nd) {
1722         crvnew[nd + *ncoeff * crvnew_dim1] = crvold[*ncoeff + nd *
1723                 crvold_dim1] * tabaux[*ncoeff - 1];
1724 /* L900: */
1725     }
1726
1727 /* ---------------------------- The end ---------------------------------
1728 */
1729
1730 L9999:
1731     if (*iercod > 0) {
1732         AdvApp2Var_SysBase::maermsg_("MMARCIN", iercod, 7L);
1733     }
1734     if (ibb >= 2) {
1735         AdvApp2Var_SysBase::mgsomsg_("MMARCIN", 7L);
1736     }
1737     return 0;
1738 } /* mmarcin_ */
1739
1740 //=======================================================================
1741 //function : mmatvec_
1742 //purpose  :
1743 //=======================================================================
1744 int mmatvec_(integer *nligne,
1745              integer *,//ncolon,
1746              integer *gposit,
1747              integer *,//gnstoc,
1748              doublereal *gmatri,
1749              doublereal *vecin,
1750              integer *deblig,
1751              doublereal *vecout,
1752              integer *iercod)
1753
1754 {
1755   /* System generated locals */
1756   integer i__1, i__2;
1757
1758   /* Local variables */
1759     static logical ldbg;
1760   static integer jmin, jmax, i__, j, k;
1761   static doublereal somme;
1762   static integer aux;
1763
1764
1765 /* ***********************************************************************
1766  */
1767
1768 /*     FUNCTION : */
1769 /*     ---------- */
1770 /*      Produce vector matrix in form of profile */
1771
1772
1773 /*     MOTS CLES : */
1774 /*     ----------- */
1775 /*      RESERVE, MATRIX, PRODUCT, VECTOR, PROFILE */
1776
1777 /*     INPUT ARGUMENTS : */
1778 /*     -------------------- */
1779 /*       NLIGNE : Line number of the matrix of constraints */
1780 /*       NCOLON : Number of column of the matrix of constraints */
1781 /*       GNSTOC: Number of coefficients in the profile of matrix GMATRI */
1782
1783 /*       GPOSIT: Table of positioning of terms of storage */
1784 /*               GPOSIT(1,I) contains the number of terms-1 on the line I
1785 /*               in the profile of the matrix. */
1786 /*              GPOSIT(2,I) contains the index of storage of diagonal term*/
1787 /*               of line I */
1788 /*               GPOSIT(3,I) contains the index of column of the first term of */
1789 /*                           profile of line I */
1790 /*       GNSTOC: Number of coefficients in the profile of matrix */
1791 /*               GMATRI */
1792 /*       GMATRI : Matrix of constraints in form of profile */
1793 /*       VECIN  : Input vector */
1794 /*       DEBLIG : Line indexusing which the vector matrix is calculated */
1795 /*
1796 /*     OUTPUT ARGUMENTS */
1797 /*     --------------------- */
1798 /*       VECOUT : VECTOR PRODUCT */
1799
1800 /*       IERCOD : ERROR CODE */
1801
1802
1803 /*     COMMONS USED : */
1804 /*     ------------------ */
1805
1806
1807 /*     REFERENCES CALLED : */
1808 /*     --------------------- */
1809
1810
1811 /*     DESCRIPTION/NOTES/LIMITATIONS : */
1812 /*     ----------------------------------- */
1813
1814 /* ***********************************************************************
1815  */
1816 /*                            DECLARATIONS */
1817 /* ***********************************************************************
1818  */
1819
1820
1821
1822 /* ***********************************************************************
1823  */
1824 /*                      INITIALISATIONS */
1825 /* ***********************************************************************
1826  */
1827
1828     /* Parameter adjustments */
1829     --vecout;
1830     gposit -= 4;
1831     --vecin;
1832     --gmatri;
1833
1834     /* Function Body */
1835     ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 2;
1836     if (ldbg) {
1837         AdvApp2Var_SysBase::mgenmsg_("MMATVEC", 7L);
1838     }
1839     *iercod = 0;
1840
1841 /* ***********************************************************************
1842  */
1843 /*                    Processing */
1844 /* ***********************************************************************
1845  */
1846     AdvApp2Var_SysBase::mvriraz_((integer *)nligne,
1847              (char *)&vecout[1]);
1848     i__1 = *nligne;
1849     for (i__ = *deblig; i__ <= i__1; ++i__) {
1850         somme = 0.;
1851         jmin = gposit[i__ * 3 + 3];
1852         jmax = gposit[i__ * 3 + 1] + gposit[i__ * 3 + 3] - 1;
1853         aux = gposit[i__ * 3 + 2] - gposit[i__ * 3 + 1] - jmin + 1;
1854         i__2 = jmax;
1855         for (j = jmin; j <= i__2; ++j) {
1856             k = j + aux;
1857             somme += gmatri[k] * vecin[j];
1858         }
1859         vecout[i__] = somme;
1860     }
1861
1862
1863
1864
1865
1866     goto L9999;
1867
1868 /* ***********************************************************************
1869  */
1870 /*                   ERROR PROCESSING */
1871 /* ***********************************************************************
1872  */
1873
1874
1875
1876
1877 /* ***********************************************************************
1878  */
1879 /*                   RETURN CALLING PROGRAM */
1880 /* ***********************************************************************
1881  */
1882
1883 L9999:
1884
1885 /* ___ DESALLOCATION, ... */
1886
1887     AdvApp2Var_SysBase::maermsg_("MMATVEC", iercod, 7L);
1888     if (ldbg) {
1889         AdvApp2Var_SysBase::mgsomsg_("MMATVEC", 7L);
1890     }
1891
1892  return 0 ;
1893 } /* mmatvec_ */
1894
1895 //=======================================================================
1896 //function : mmbulld_
1897 //purpose  :
1898 //=======================================================================
1899 int AdvApp2Var_MathBase::mmbulld_(integer *nbcoln,
1900                                   integer *nblign,
1901                                   doublereal *dtabtr,
1902                                   integer *numcle)
1903
1904 {
1905   /* System generated locals */
1906   integer dtabtr_dim1, dtabtr_offset, i__1, i__2;
1907
1908   /* Local variables */
1909   static logical ldbg;
1910   static doublereal daux;
1911   static integer nite1, nite2, nchan, i1, i2;
1912
1913 /* ***********************************************************************
1914  */
1915
1916 /*     FUNCTION : */
1917 /*     ---------- */
1918 /*        Parsing of columns of a table of integers in increasing order */
1919 /*     KEYWORDS : */
1920 /*     ----------- */
1921 /*     POINT-ENTRY, PARSING */
1922 /*     INPUT ARGUMENTS : */
1923 /*     -------------------- */
1924 /*       - NBCOLN : Number of columns in the table */
1925 /*       - NBLIGN : Number of lines in the table */
1926 /*       - DTABTR : Table of integers to be parsed */
1927 /*       - NUMCLE : Position of the key on the column */
1928
1929 /*     OUTPUT ARGUMENTS : */
1930 /*     --------------------- */
1931 /*       - DTABTR : Parsed table */
1932
1933 /*     COMMONS USED : */
1934 /*     ------------------ */
1935
1936
1937 /*     REFERENCES CALLED : */
1938 /*     --------------------- */
1939
1940
1941 /*     DESCRIPTION/NOTES/LIMITATIONS : */
1942 /*     ----------------------------------- */
1943 /*     Particularly performant if the table is almost parsed */
1944 /*     In the opposite case it is better to use MVSHELD */
1945 /* ***********************************************************************
1946  */
1947
1948     /* Parameter adjustments */
1949     dtabtr_dim1 = *nblign;
1950     dtabtr_offset = dtabtr_dim1 + 1;
1951     dtabtr -= dtabtr_offset;
1952
1953     /* Function Body */
1954     ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 2;
1955     if (ldbg) {
1956         AdvApp2Var_SysBase::mgenmsg_("MMBULLD", 7L);
1957     }
1958     nchan = 1;
1959     nite1 = *nbcoln;
1960     nite2 = 2;
1961
1962 /* ***********************************************************************
1963  */
1964 /*                     PROCESSING */
1965 /* ***********************************************************************
1966  */
1967
1968 /* ---->ALGORITHM in N^2 / 2 additional iteration */
1969
1970     while(nchan != 0) {
1971
1972 /* ----> Parsing from left to the right */
1973
1974         nchan = 0;
1975         i__1 = nite1;
1976         for (i1 = nite2; i1 <= i__1; ++i1) {
1977             if (dtabtr[*numcle + i1 * dtabtr_dim1] < dtabtr[*numcle + (i1 - 1)
1978                      * dtabtr_dim1]) {
1979                 i__2 = *nblign;
1980                 for (i2 = 1; i2 <= i__2; ++i2) {
1981                     daux = dtabtr[i2 + (i1 - 1) * dtabtr_dim1];
1982                     dtabtr[i2 + (i1 - 1) * dtabtr_dim1] = dtabtr[i2 + i1 *
1983                             dtabtr_dim1];
1984                     dtabtr[i2 + i1 * dtabtr_dim1] = daux;
1985                 }
1986                 if (nchan == 0) {
1987                     nchan = 1;
1988                 }
1989             }
1990         }
1991         --nite1;
1992
1993 /* ----> Parsing from right to the left */
1994
1995         if (nchan != 0) {
1996             nchan = 0;
1997             i__1 = nite2;
1998             for (i1 = nite1; i1 >= i__1; --i1) {
1999                 if (dtabtr[*numcle + i1 * dtabtr_dim1] < dtabtr[*numcle + (i1
2000                         - 1) * dtabtr_dim1]) {
2001                     i__2 = *nblign;
2002                     for (i2 = 1; i2 <= i__2; ++i2) {
2003                         daux = dtabtr[i2 + (i1 - 1) * dtabtr_dim1];
2004                         dtabtr[i2 + (i1 - 1) * dtabtr_dim1] = dtabtr[i2 + i1 *
2005                                  dtabtr_dim1];
2006                         dtabtr[i2 + i1 * dtabtr_dim1] = daux;
2007                     }
2008                     if (nchan == 0) {
2009                         nchan = 1;
2010                     }
2011                 }
2012             }
2013             ++nite2;
2014         }
2015     }
2016
2017
2018     goto L9999;
2019
2020 /* ***********************************************************************
2021  */
2022 /*                   ERROR PROCESSING */
2023 /* ***********************************************************************
2024  */
2025
2026 /* ----> No errors at calling functions, only tests and loops. */
2027
2028 /* ***********************************************************************
2029  */
2030 /*                   RETURN CALLING PROGRAM */
2031 /* ***********************************************************************
2032  */
2033
2034 L9999:
2035
2036     if (ldbg) {
2037         AdvApp2Var_SysBase::mgsomsg_("MMBULLD", 7L);
2038     }
2039
2040  return 0 ;
2041 } /* mmbulld_ */
2042
2043
2044 //=======================================================================
2045 //function : AdvApp2Var_MathBase::mmcdriv_
2046 //purpose  :
2047 //=======================================================================
2048 int AdvApp2Var_MathBase::mmcdriv_(integer *ndimen,
2049                                   integer *ncoeff,
2050                                   doublereal *courbe,
2051                                   integer *ideriv,
2052                                   integer *ncofdv,
2053                                   doublereal *crvdrv)
2054
2055
2056 {
2057   /* System generated locals */
2058   integer courbe_dim1, courbe_offset, crvdrv_dim1, crvdrv_offset, i__1,
2059   i__2;
2060
2061   /* Local variables */
2062   static integer i__, j, k;
2063   static doublereal mfactk, bid;
2064
2065
2066 /* ***********************************************************************
2067  */
2068
2069 /*     FUNCTION : */
2070 /*     ---------- */
2071 /*     Calculate matrix of a derivate curve of order IDERIV. */
2072 /*     with input parameters other than output parameters. */
2073
2074
2075 /*     KEYWORDS : */
2076 /*     ----------- */
2077 /*     COEFFICIENTS,CURVE,DERIVATE I-EME. */
2078
2079 /*     INPUT ARGUMENTS : */
2080 /*     ------------------ */
2081 /*   NDIMEN  : Space dimension (2 or 3 in general) */
2082 /*   NCOEFF  : Degree +1 of the curve. */
2083 /*   COURBE  : Table of coefficients of the curve. */
2084 /*   IDERIV  : Required order of derivation : 1=1st derivate, etc... */
2085
2086 /*     OUTPUT ARGUMENTS : */
2087 /*     ------------------- */
2088 /*   NCOFDV  : Degree +1 of the derivative of order IDERIV of the curve. */
2089 /*   CRVDRV  : Table of coefficients of the derivative of order IDERIV */
2090 /*            of the curve. */
2091
2092 /*     COMMONS USED   : */
2093 /*     ---------------- */
2094
2095 /*     REFERENCES CALLED   : */
2096 /*     ----------------------- */
2097
2098 /*     DESCRIPTION/NOTES/LIMITATIONS : */
2099 /*     ----------------------------------- */
2100
2101 /* ---> It is possible to take as output argument the curve */
2102 /*     and the number of coeff passed at input by making : */
2103 /*        CALL MMCDRIV(NDIMEN,NCOEFF,COURBE,IDERIV,NCOEFF,COURBE). */
2104 /*     After this call, NCOEFF does the number of coeff of the derived */
2105 /*     curve the coefficients which of are stored in CURVE. */
2106 /*     Attention to the coefficients of CURVE of rank superior to */
2107 /*     NCOEFF : they are not set to zero. */
2108
2109 /* ---> Algorithm : */
2110 /*     The code below was written basing on the following algorithm:
2111 */
2112
2113 /*     Let P(t) = a1 + a2*t + ... an*t**n. Derivate of order k of P */
2114 /*     (containing n-k coefficients) is calculated as follows : */
2115
2116 /*       Pk(t) = a(k+1)*CNP(k,k)*k! */
2117 /*             + a(k+2)*CNP(k+1,k)*k! * t */
2118 /*             . */
2119 /*             . */
2120 /*             . */
2121 /*             + a(n)*CNP(n-1,k)*k! * t**(n-k-1). */
2122 /* ***********************************************************************
2123  */
2124
2125
2126 /* -------------- Case when the order of derivative is  -------------------
2127 */
2128 /* ---------------- greater than the degree of the curve ---------------------
2129 */
2130
2131 /* **********************************************************************
2132 */
2133
2134 /*     FUNCTION : */
2135 /*     ---------- */
2136 /*      Serves to provide the coefficients of binome (Pascal's triangle). */
2137
2138 /*     KEYWORDS : */
2139 /*     ----------- */
2140 /*      Binomial coeff from 0 to 60. read only . init par block data */
2141
2142 /*     DEMSCRIPTION/NOTES/LIMITATIONS : */
2143 /*     ----------------------------------- */
2144 /*     Binomial coefficients form a triangular matrix. */
2145 /*     This matrix is completed in table CNP by its transposition. */
2146 /*     So: CNP(I,J) = CNP(J,I) for I and J = 0, ..., 60. */
2147
2148 /*     Initialization is done by block-data MMLLL09.RES, */
2149 /*     created by program MQINICNP.FOR). */
2150 /* **********************************************************************
2151 */
2152
2153
2154
2155 /* ***********************************************************************
2156  */
2157
2158     /* Parameter adjustments */
2159     crvdrv_dim1 = *ndimen;
2160     crvdrv_offset = crvdrv_dim1 + 1;
2161     crvdrv -= crvdrv_offset;
2162     courbe_dim1 = *ndimen;
2163     courbe_offset = courbe_dim1 + 1;
2164     courbe -= courbe_offset;
2165
2166     /* Function Body */
2167     if (*ideriv >= *ncoeff) {
2168         i__1 = *ndimen;
2169         for (i__ = 1; i__ <= i__1; ++i__) {
2170             crvdrv[i__ + crvdrv_dim1] = 0.;
2171 /* L10: */
2172         }
2173         *ncofdv = 1;
2174         goto L9999;
2175     }
2176 /* **********************************************************************
2177 */
2178 /*                        General processing */
2179 /* **********************************************************************
2180 */
2181 /* --------------------- Calculation of Factorial(IDERIV) ------------------
2182 */
2183
2184     k = *ideriv;
2185     mfactk = 1.;
2186     i__1 = k;
2187     for (i__ = 2; i__ <= i__1; ++i__) {
2188         mfactk *= i__;
2189 /* L50: */
2190     }
2191
2192 /* ------------ Calculation of coeff of the derived of order IDERIV ----------
2193 */
2194 /* ---> Attention :  coefficient binomial C(n,m) is represented in */
2195 /*                 MCCNP by CNP(N+1,M+1). */
2196
2197     i__1 = *ncoeff;
2198     for (j = k + 1; j <= i__1; ++j) {
2199         bid = mmcmcnp_.cnp[j - 1 + k * 61] * mfactk;
2200         i__2 = *ndimen;
2201         for (i__ = 1; i__ <= i__2; ++i__) {
2202             crvdrv[i__ + (j - k) * crvdrv_dim1] = bid * courbe[i__ + j *
2203                     courbe_dim1];
2204 /* L200: */
2205         }
2206 /* L100: */
2207     }
2208
2209     *ncofdv = *ncoeff - *ideriv;
2210
2211 /* -------------------------------- The end -----------------------------
2212 */
2213
2214 L9999:
2215     return 0;
2216 } /* mmcdriv_ */
2217
2218 //=======================================================================
2219 //function : AdvApp2Var_MathBase::mmcglc1_
2220 //purpose  :
2221 //=======================================================================
2222 int AdvApp2Var_MathBase::mmcglc1_(integer *ndimax,
2223                                   integer *ndimen,
2224                                   integer *ncoeff,
2225                                   doublereal *courbe,
2226                                   doublereal *tdebut,
2227                                   doublereal *tfinal,
2228                                   doublereal *epsiln,
2229                                   doublereal *xlongc,
2230                                   doublereal *erreur,
2231                                   integer *iercod)
2232
2233
2234 {
2235   /* System generated locals */
2236   integer courbe_dim1, courbe_offset, i__1;
2237   doublereal d__1;
2238
2239   /* Local variables */
2240   static integer ndec;
2241   static doublereal tdeb, tfin;
2242   static integer iter;
2243   static doublereal oldso;
2244   static integer itmax;
2245   static doublereal sottc;
2246   static integer kk, ibb;
2247   static doublereal dif, pas;
2248   static doublereal som;
2249
2250
2251 /* ***********************************************************************
2252  */
2253
2254 /*     FUNCTION : */
2255 /*     ---------- */
2256 /*      Allows calculating the length of an arc of curve POLYNOMIAL */
2257 /*      on an interval [A,B]. */
2258
2259 /*     KEYWORDS : */
2260 /*     ----------- */
2261 /*        LENGTH,CURVE,GAUSS,PRIVATE. */
2262
2263 /*     INPUT ARGUMENTS : */
2264 /*     ------------------ */
2265 /*      NDIMAX : Max. number of lines of tables */
2266 /*               (i.e. max. nb of polynoms). */
2267 /*      NDIMEN : Dimension of the space (nb of polynoms). */
2268 /*      NCOEFF : Nb of coefficients of the polynom. This is degree + 1.
2269 */
2270 /*      COURBE(NDIMAX,NCOEFF) : Coefficients of the curve. */
2271 /*      TDEBUT : Lower limit of the interval of integration for  */
2272 /*               length calculation. */
2273 /*      TFINAL : Upper limit of the interval of integration for */
2274 /*               length calculation. */
2275 /*      EPSILN : REQIRED precision for length calculation. */
2276
2277 /*     OUTPUT ARGUMENTS : */
2278 /*     ------------------- */
2279 /*      XLONGC : Length of the arc of curve */
2280 /*      ERREUR : Precision OBTAINED for the length calculation. */
2281 /*      IERCOD : Error code, 0 OK, >0 Serious error. */
2282 /*               = 1 Too much iterations, the best calculated resultat */
2283 /*                   (is almost ERROR) */
2284 /*               = 2 Pb MMLONCV (no result) */
2285 /*               = 3 NDIM or NCOEFF invalid (no result) */
2286
2287 /*     COMMONS USED : */
2288 /*     ---------------- */
2289
2290 /*     REFERENCES CALLED : */
2291 /*     ----------------------- */
2292
2293 /*     DESCRIPTION/NOTES/LIMITATIONS : */
2294 /*     ----------------------------------- */
2295 /*      The polynom is actually a set of polynoms with */
2296 /*      coefficients arranged in a table of 2 indices, */
2297 /*      each line relative to the polynom. */
2298 /*      The polynom is defined by these coefficients ordered */
2299 /*      by increasing power of the variable. */
2300 /*      All polynoms have the same number of coefficients (the */
2301 /*      same degree). */
2302
2303 /*      This program cancels and replaces LENGCV, MLONGC and MLENCV. */
2304
2305 /*      ATTENTION : if TDEBUT > TFINAL, the length is NEGATIVE. */
2306
2307 /* > */
2308 /* ***********************************************************************
2309  */
2310
2311 /*   Name of the routine */
2312
2313
2314 /* ------------------------ General Initialization ---------------------
2315 */
2316
2317     /* Parameter adjustments */
2318     courbe_dim1 = *ndimax;
2319     courbe_offset = courbe_dim1 + 1;
2320     courbe -= courbe_offset;
2321
2322     /* Function Body */
2323     ibb = AdvApp2Var_SysBase::mnfndeb_();
2324     if (ibb >= 2) {
2325         AdvApp2Var_SysBase::mgenmsg_("MMCGLC1", 7L);
2326     }
2327
2328     *iercod = 0;
2329     *xlongc = 0.;
2330     *erreur = 0.;
2331
2332 /* ------ Test of equity of limits */
2333
2334     if (*tdebut == *tfinal) {
2335         *iercod = 0;
2336         goto L9999;
2337     }
2338
2339 /* ------ Test of the dimension and the number of coefficients */
2340
2341     if (*ndimen <= 0 || *ncoeff <= 0) {
2342         goto L9003;
2343     }
2344
2345 /* ----- Nb of current cutting, nb of iteration, */
2346 /*       max nb of iterations */
2347
2348     ndec = 1;
2349     iter = 1;
2350
2351     itmax = 13;
2352
2353 /* ------ Variation of the nb of intervals */
2354 /*       Multiplied by 2 at each iteration */
2355
2356 L5000:
2357     pas = (*tfinal - *tdebut) / ndec;
2358     sottc = 0.;
2359
2360 /* ------ Loop on all current NDEC intervals */
2361
2362     i__1 = ndec;
2363     for (kk = 1; kk <= i__1; ++kk) {
2364
2365 /* ------ Limits of the current integration interval */
2366
2367         tdeb = *tdebut + (kk - 1) * pas;
2368         tfin = tdeb + pas;
2369         mmloncv_(ndimax, ndimen, ncoeff, &courbe[courbe_offset], &tdeb, &tfin,
2370                  &som, iercod);
2371         if (*iercod > 0) {
2372             goto L9002;
2373         }
2374
2375         sottc += som;
2376
2377 /* L100: */
2378     }
2379
2380
2381 /* ----------------- Test of the maximum number of iterations ------------
2382 */
2383
2384 /*  Test if passes at least once ** */
2385
2386     if (iter == 1) {
2387         oldso = sottc;
2388         ndec <<= 1;
2389         ++iter;
2390         goto L5000;
2391     } else {
2392
2393 /* ------ Take into account DIF - Test of convergence */
2394
2395         ++iter;
2396         dif = (d__1 = sottc - oldso, abs(d__1));
2397
2398 /* ------ If DIF is OK, leave..., otherwise: */
2399
2400         if (dif > *epsiln) {
2401
2402 /* ------ If nb iteration exceeded, leave */
2403
2404             if (iter > itmax) {
2405                 *iercod = 1;
2406                 goto L9000;
2407             } else {
2408
2409 /* ------ Otherwise continue by cutting the initial interval.
2410  */
2411
2412                 oldso = sottc;
2413                 ndec <<= 1;
2414                 goto L5000;
2415             }
2416         }
2417     }
2418
2419 /* ------------------------------ THE END -------------------------------
2420 */
2421
2422 L9000:
2423     *xlongc = sottc;
2424     *erreur = dif;
2425     goto L9999;
2426
2427 /* ---> PB in MMLONCV */
2428
2429 L9002:
2430     *iercod = 2;
2431     goto L9999;
2432
2433 /* ---> NCOEFF or NDIM invalid. */
2434
2435 L9003:
2436     *iercod = 3;
2437     goto L9999;
2438
2439 L9999:
2440     if (*iercod > 0) {
2441         AdvApp2Var_SysBase::maermsg_("MMCGLC1", iercod, 7L);
2442     }
2443     if (ibb >= 2) {
2444         AdvApp2Var_SysBase::mgsomsg_("MMCGLC1", 7L);
2445     }
2446     return 0;
2447 } /* mmcglc1_ */
2448
2449 //=======================================================================
2450 //function : mmchole_
2451 //purpose  :
2452 //=======================================================================
2453 int mmchole_(integer *,//mxcoef,
2454              integer *dimens,
2455              doublereal *amatri,
2456              integer *aposit,
2457              integer *posuiv,
2458              doublereal *chomat,
2459              integer *iercod)
2460
2461 {
2462   /* System generated locals */
2463   integer i__1, i__2, i__3;
2464   doublereal d__1;
2465
2466   /* Builtin functions */
2467   //double sqrt();
2468
2469     /* Local variables */
2470   static logical ldbg;
2471   static integer kmin, i__, j, k;
2472   static doublereal somme;
2473   static integer ptini, ptcou;
2474
2475
2476 /* ***********************************************************************
2477  */
2478
2479 /*     FUNCTION : */
2480 /*     ----------                                                  T */
2481 /*     Produce decomposition of choleski of matrix A in S.S */
2482 /*     Calculate inferior triangular matrix S. */
2483
2484 /*     KEYWORDS : */
2485 /*     ----------- */
2486 /*     RESOLUTION, MFACTORISATION, MATRIX_PROFILE, CHOLESKI */
2487
2488 /*     INPUT ARGUMENTS : */
2489 /*     -------------------- */
2490 /*     MXCOEF : Max number of terms in the hessian profile */
2491 /*     DIMENS : Dimension of the problem */
2492 /*     AMATRI(MXCOEF) : Coefficients of the matrix profile */
2493 /*        APOSIT(1,*) : Distance diagonal-left extremity of the line
2494 */
2495 /*        APOSIT(2,*) : Position of diagonal terms in HESSIE */
2496 /*     POSUIV(MXCOEF) :  first line inferior not out of profile */
2497
2498 /*     OUTPUT ARGUMENTS : */
2499 /*     --------------------- */
2500 /*      CHOMAT(MXCOEF) : Inferior triangular matrix preserving the */
2501 /*                       profile of AMATRI. */
2502 /*      IERCOD : error code */
2503 /*               = 0 : ok */
2504 /*               = 1 : non-defined positive matrix */
2505
2506 /*     COMMONS USED : */
2507 /*     ------------------ */
2508
2509 /*      .Neant. */
2510
2511 /*     REFERENCES CALLED   : */
2512 /*     ---------------------- */
2513
2514 /*     DESCRIPTION/NOTES/LIMITATIONS : */
2515 /*     ----------------------------------- */
2516 /*     DEBUG LEVEL = 4 */
2517 /* ***********************************************************************
2518  */
2519 /*                            DECLARATIONS */
2520 /* ***********************************************************************
2521  */
2522
2523
2524
2525 /* ***********************************************************************
2526  */
2527 /*                      INITIALISATIONS */
2528 /* ***********************************************************************
2529  */
2530
2531     /* Parameter adjustments */
2532     --chomat;
2533     --posuiv;
2534     --amatri;
2535     aposit -= 3;
2536
2537     /* Function Body */
2538     ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 4;
2539     if (ldbg) {
2540         AdvApp2Var_SysBase::mgenmsg_("MMCHOLE", 7L);
2541     }
2542     *iercod = 0;
2543
2544 /* ***********************************************************************
2545  */
2546 /*                    PROCESSING */
2547 /* ***********************************************************************
2548  */
2549
2550     i__1 = *dimens;
2551     for (j = 1; j <= i__1; ++j) {
2552
2553         ptini = aposit[(j << 1) + 2];
2554
2555         somme = 0.;
2556         i__2 = ptini - 1;
2557         for (k = ptini - aposit[(j << 1) + 1]; k <= i__2; ++k) {
2558 /* Computing 2nd power */
2559             d__1 = chomat[k];
2560             somme += d__1 * d__1;
2561         }
2562
2563         if (amatri[ptini] - somme < 1e-32) {
2564             goto L9101;
2565         }
2566         chomat[ptini] = sqrt(amatri[ptini] - somme);
2567
2568         ptcou = ptini;
2569
2570         while(posuiv[ptcou] > 0) {
2571
2572             i__ = posuiv[ptcou];
2573             ptcou = aposit[(i__ << 1) + 2] - (i__ - j);
2574
2575 /*           Calculate the sum of S  .S   for k =1 a j-1 */
2576 /*                               ik  jk */
2577             somme = 0.;
2578 /* Computing MAX */
2579             i__2 = i__ - aposit[(i__ << 1) + 1], i__3 = j - aposit[(j << 1) +
2580                     1];
2581             kmin = max(i__2,i__3);
2582             i__2 = j - 1;
2583             for (k = kmin; k <= i__2; ++k) {
2584                 somme += chomat[aposit[(i__ << 1) + 2] - (i__ - k)] * chomat[
2585                         aposit[(j << 1) + 2] - (j - k)];
2586             }
2587
2588             chomat[ptcou] = (amatri[ptcou] - somme) / chomat[ptini];
2589         }
2590     }
2591
2592     goto L9999;
2593
2594 /* ***********************************************************************
2595  */
2596 /*                   ERROR PROCESSING */
2597 /* ***********************************************************************
2598  */
2599
2600 L9101:
2601     *iercod = 1;
2602     goto L9999;
2603
2604 /* ***********************************************************************
2605  */
2606 /*                  RETURN CALLING PROGRAM */
2607 /* ***********************************************************************
2608  */
2609
2610 L9999:
2611
2612     AdvApp2Var_SysBase::maermsg_("MMCHOLE", iercod, 7L);
2613     if (ldbg) {
2614         AdvApp2Var_SysBase::mgsomsg_("MMCHOLE", 7L);
2615     }
2616
2617  return 0 ;
2618 } /* mmchole_ */
2619
2620 //=======================================================================
2621 //function : AdvApp2Var_MathBase::mmcvctx_
2622 //purpose  :
2623 //=======================================================================
2624 int AdvApp2Var_MathBase::mmcvctx_(integer *ndimen,
2625                                   integer *ncofmx,
2626                                   integer *nderiv,
2627                                   doublereal *ctrtes,
2628                                   doublereal *crvres,
2629                                   doublereal *tabaux,
2630                                   doublereal *xmatri,
2631                                   integer *iercod)
2632
2633 {
2634   /* System generated locals */
2635   integer ctrtes_dim1, ctrtes_offset, crvres_dim1, crvres_offset,
2636   xmatri_dim1, xmatri_offset, tabaux_dim1, tabaux_offset, i__1,
2637   i__2;
2638
2639   /* Local variables */
2640   static integer moup1, nordr;
2641   static integer nd;
2642   static integer ibb, ncf, ndv;
2643   static doublereal eps1;
2644
2645
2646 /* ***********************************************************************
2647  */
2648
2649 /*     FUNCTION : */
2650 /*     ---------- */
2651 /*        Calculate a polynomial curve checking the  */
2652 /*        passage constraints (interpolation) */
2653 /*        from first derivatives, etc... to extremities. */
2654 /*        Parameters at the extremities are supposed to be -1 and 1. */
2655
2656 /*     KEYWORDS : */
2657 /*     ----------- */
2658 /*     ALL, AB_SPECIFI::CONSTRAINTS&,INTERPOLATION,&CURVE */
2659
2660 /*     INPUT ARGUMENTS : */
2661 /*     ------------------ */
2662 /*     NDIMEN : Space Dimension. */
2663 /*     NCOFMX : Nb of coeff. of curve CRVRES on each */
2664 /*              dimension. */
2665 /*     NDERIV : Order of constraint with derivatives : */
2666 /*              0 --> interpolation simple. */
2667 /*              1 --> interpolation+constraints with 1st. */
2668 /*              2 --> cas (0)+ (1) +   "         "   2nd derivatives. */
2669 /*                 etc... */
2670 /*     CTRTES : Table of constraints. */
2671 /*              CTRTES(*,1,*) = contraints at -1. */
2672 /*              CTRTES(*,2,*) = contraints at  1. */
2673
2674 /*     OUTPUT ARGUMENTS : */
2675 /*     ------------------- */
2676 /*     CRVRES : Resulting curve defined on (-1,1). */
2677 /*     TABAUX : Auxilliary matrix. */
2678 /*     XMATRI : Auxilliary matrix. */
2679
2680 /*     COMMONS UTILISES   : */
2681 /*     ---------------- */
2682
2683 /*      .Neant. */
2684
2685 /*     REFERENCES CALLED   : */
2686 /*     ---------------------- */
2687 /*     Type  Name */
2688 /*           MAERMSG         R*8  DFLOAT              MGENMSG */
2689 /*           MGSOMSG              MMEPS1               MMRSLW */
2690 /*      I*4  MNFNDEB */
2691
2692 /*     DESCRIPTION/NOTES/LIMITATIONS : */
2693 /*     ----------------------------------- */
2694 /*        The polynom (or the curve) is calculated by solving a */
2695 /*        system of linear equations. If the imposed degree is great */
2696 /*        it is preferable to call a routine based on */
2697 /*        Lagrange or Hermite interpolation depending on the case. */
2698 /*        (for a high degree the matrix of the system can be badly */
2699 /*        conditionned). */
2700 /*        This routine returns a curve defined in (-1,1). */
2701 /*        In general case, it is necessary to use MCVCTG. */
2702 /* > */
2703 /* ***********************************************************************
2704  */
2705
2706 /*   Name of the routine */
2707
2708
2709     /* Parameter adjustments */
2710     crvres_dim1 = *ncofmx;
2711     crvres_offset = crvres_dim1 + 1;
2712     crvres -= crvres_offset;
2713     xmatri_dim1 = *nderiv + 1;
2714     xmatri_offset = xmatri_dim1 + 1;
2715     xmatri -= xmatri_offset;
2716     tabaux_dim1 = *nderiv + 1 + *ndimen;
2717     tabaux_offset = tabaux_dim1 + 1;
2718     tabaux -= tabaux_offset;
2719     ctrtes_dim1 = *ndimen;
2720     ctrtes_offset = ctrtes_dim1 * 3 + 1;
2721     ctrtes -= ctrtes_offset;
2722
2723     /* Function Body */
2724     ibb = AdvApp2Var_SysBase::mnfndeb_();
2725     if (ibb >= 3) {
2726         AdvApp2Var_SysBase::mgenmsg_("MMCVCTX", 7L);
2727     }
2728 /*   Precision. */
2729     AdvApp2Var_MathBase::mmeps1_(&eps1);
2730
2731 /* ****************** CALCULATION OF EVEN COEFFICIENTS *********************
2732 */
2733 /* ------------------------- Initialization -----------------------------
2734 */
2735
2736     nordr = *nderiv + 1;
2737     i__1 = nordr;
2738     for (ncf = 1; ncf <= i__1; ++ncf) {
2739         tabaux[ncf + tabaux_dim1] = 1.;
2740 /* L100: */
2741     }
2742
2743 /* ---------------- Calculation of terms corresponding to derivatives -------
2744 */
2745
2746     i__1 = nordr;
2747     for (ndv = 2; ndv <= i__1; ++ndv) {
2748         i__2 = nordr;
2749         for (ncf = 1; ncf <= i__2; ++ncf) {
2750             tabaux[ncf + ndv * tabaux_dim1] = tabaux[ncf + (ndv - 1) *
2751                     tabaux_dim1] * (doublereal) ((ncf << 1) - ndv);
2752 /* L300: */
2753         }
2754 /* L200: */
2755     }
2756
2757 /* ------------------ Writing the second member -----------------------
2758 */
2759
2760     moup1 = 1;
2761     i__1 = nordr;
2762     for (ndv = 1; ndv <= i__1; ++ndv) {
2763         i__2 = *ndimen;
2764         for (nd = 1; nd <= i__2; ++nd) {
2765             tabaux[nordr + nd + ndv * tabaux_dim1] = (ctrtes[nd + ((ndv << 1)
2766                     + 2) * ctrtes_dim1] + moup1 * ctrtes[nd + ((ndv << 1) + 1)
2767                      * ctrtes_dim1]) / 2.;
2768 /* L500: */
2769         }
2770         moup1 = -moup1;
2771 /* L400: */
2772     }
2773
2774 /* -------------------- Resolution of the system ---------------------------
2775 */
2776
2777     mmrslw_(&nordr, &nordr, ndimen, &eps1, &tabaux[tabaux_offset], &xmatri[
2778             xmatri_offset], iercod);
2779     if (*iercod > 0) {
2780         goto L9999;
2781     }
2782     i__1 = *ndimen;
2783     for (nd = 1; nd <= i__1; ++nd) {
2784         i__2 = nordr;
2785         for (ncf = 1; ncf <= i__2; ++ncf) {
2786             crvres[(ncf << 1) - 1 + nd * crvres_dim1] = xmatri[ncf + nd *
2787                     xmatri_dim1];
2788 /* L700: */
2789         }
2790 /* L600: */
2791     }
2792
2793 /* ***************** CALCULATION OF UNEVEN COEFFICIENTS ********************
2794 */
2795 /* ------------------------- Initialization -----------------------------
2796 */
2797
2798
2799     i__1 = nordr;
2800     for (ncf = 1; ncf <= i__1; ++ncf) {
2801         tabaux[ncf + tabaux_dim1] = 1.;
2802 /* L1100: */
2803     }
2804
2805 /* ---------------- Calculation of terms corresponding to derivatives -------
2806 */
2807
2808     i__1 = nordr;
2809     for (ndv = 2; ndv <= i__1; ++ndv) {
2810         i__2 = nordr;
2811         for (ncf = 1; ncf <= i__2; ++ncf) {
2812             tabaux[ncf + ndv * tabaux_dim1] = tabaux[ncf + (ndv - 1) *
2813                     tabaux_dim1] * (doublereal) ((ncf << 1) - ndv + 1);
2814 /* L1300: */
2815         }
2816 /* L1200: */
2817     }
2818
2819 /* ------------------ Writing of the second member -----------------------
2820 */
2821
2822     moup1 = -1;
2823     i__1 = nordr;
2824     for (ndv = 1; ndv <= i__1; ++ndv) {
2825         i__2 = *ndimen;
2826         for (nd = 1; nd <= i__2; ++nd) {
2827             tabaux[nordr + nd + ndv * tabaux_dim1] = (ctrtes[nd + ((ndv << 1)
2828                     + 2) * ctrtes_dim1] + moup1 * ctrtes[nd + ((ndv << 1) + 1)
2829                      * ctrtes_dim1]) / 2.;
2830 /* L1500: */
2831         }
2832         moup1 = -moup1;
2833 /* L1400: */
2834     }
2835
2836 /* -------------------- Solution of the system ---------------------------
2837 */
2838
2839     mmrslw_(&nordr, &nordr, ndimen, &eps1, &tabaux[tabaux_offset], &xmatri[
2840             xmatri_offset], iercod);
2841     if (*iercod > 0) {
2842         goto L9999;
2843     }
2844     i__1 = *ndimen;
2845     for (nd = 1; nd <= i__1; ++nd) {
2846         i__2 = nordr;
2847         for (ncf = 1; ncf <= i__2; ++ncf) {
2848             crvres[(ncf << 1) + nd * crvres_dim1] = xmatri[ncf + nd *
2849                     xmatri_dim1];
2850 /* L1700: */
2851         }
2852 /* L1600: */
2853     }
2854
2855 /* --------------------------- The end ----------------------------------
2856 */
2857
2858 L9999:
2859     if (*iercod != 0) {
2860         AdvApp2Var_SysBase::maermsg_("MMCVCTX", iercod, 7L);
2861     }
2862     if (ibb >= 3) {
2863         AdvApp2Var_SysBase::mgsomsg_("MMCVCTX", 7L);
2864     }
2865
2866  return 0 ;
2867 } /* mmcvctx_ */
2868
2869 //=======================================================================
2870 //function : AdvApp2Var_MathBase::mmcvinv_
2871 //purpose  :
2872 //=======================================================================
2873  int AdvApp2Var_MathBase::mmcvinv_(integer *ndimax,
2874                             integer *ncoef,
2875                             integer *ndim,
2876                             doublereal *curveo,
2877                             doublereal *curve)
2878
2879 {
2880   /* Initialized data */
2881
2882   static char nomprg[8+1] = "MMCVINV ";
2883
2884   /* System generated locals */
2885   integer curve_dim1, curve_offset, curveo_dim1, curveo_offset, i__1, i__2;
2886
2887   /* Local variables */
2888   static integer i__, nd, ibb;
2889
2890
2891 /* ***********************************************************************
2892  */
2893
2894 /*     FUNCTION : */
2895 /*     ---------- */
2896 /*        Inversion of arguments of the final curve. */
2897
2898 /*     KEYWORDS : */
2899 /*     ----------- */
2900 /*        SMOOTHING,CURVE */
2901
2902
2903 /*     INPUT ARGUMENTS : */
2904 /*     ------------------ */
2905
2906 /*        NDIM: Space Dimension. */
2907 /*        NCOEF: Degree of the polynom. */
2908 /*        CURVEO: The curve before inversion. */
2909
2910 /*     OUTPUT ARGUMENTS : */
2911 /*     ------------------- */
2912 /*        CURVE: The curve after inversion. */
2913
2914 /*     COMMONS USED : */
2915 /*     ---------------- */
2916 /*     REFERENCES APPELEES   : */
2917 /*     ----------------------- */
2918 /*     DESCRIPTION/NOTES/LIMITATIONS : */
2919 /*     ----------------------------------- */
2920 /* ***********************************************************************
2921  */
2922
2923 /*   The name of the routine */
2924     /* Parameter adjustments */
2925     curve_dim1 = *ndimax;
2926     curve_offset = curve_dim1 + 1;
2927     curve -= curve_offset;
2928     curveo_dim1 = *ncoef;
2929     curveo_offset = curveo_dim1 + 1;
2930     curveo -= curveo_offset;
2931
2932     /* Function Body */
2933
2934     ibb = AdvApp2Var_SysBase::mnfndeb_();
2935     if (ibb >= 2) {
2936         AdvApp2Var_SysBase::mgenmsg_(nomprg, 6L);
2937     }
2938
2939     i__1 = *ncoef;
2940     for (i__ = 1; i__ <= i__1; ++i__) {
2941         i__2 = *ndim;
2942         for (nd = 1; nd <= i__2; ++nd) {
2943             curve[nd + i__ * curve_dim1] = curveo[i__ + nd * curveo_dim1];
2944 /* L300: */
2945         }
2946     }
2947
2948 /* L9999: */
2949     return 0;
2950 } /* mmcvinv_ */
2951
2952 //=======================================================================
2953 //function : mmcvstd_
2954 //purpose  :
2955 //=======================================================================
2956 int mmcvstd_(integer *ncofmx,
2957              integer *ndimax,
2958              integer *ncoeff,
2959              integer *ndimen,
2960              doublereal *crvcan,
2961              doublereal *courbe)
2962
2963 {
2964   /* System generated locals */
2965   integer courbe_dim1, crvcan_dim1, crvcan_offset, i__1, i__2, i__3;
2966
2967   /* Local variables */
2968   static integer ndeg, i__, j, j1, nd, ibb;
2969   static doublereal bid;
2970
2971
2972 /* ***********************************************************************
2973  */
2974
2975 /*     FUNCTION : */
2976 /*     ---------- */
2977 /*        Transform curve defined between [-1,1] into [0,1]. */
2978
2979 /*     KEYWORDS : */
2980 /*     ----------- */
2981 /*        LIMITATION,RESTRICTION,CURVE */
2982
2983 /*     INPUT ARGUMENTS : */
2984 /*     ------------------ */
2985 /*        NDIMAX : Dimension of the space. */
2986 /*        NDIMEN : Dimension of the curve. */
2987 /*        NCOEFF : Degree of the curve. */
2988 /*        CRVCAN(NCOFMX,NDIMEN): The curve is defined at the interval [-1,1]. */
2989
2990 /*     OUTPUT ARGUMENTS : */
2991 /*     ------------------- */
2992 /*        CURVE(NDIMAX,NCOEFF): Curve defined at the interval [0,1]. */
2993
2994 /*     COMMONS USED   : */
2995 /*     ---------------- */
2996
2997 /*     REFERENCES CALLED   : */
2998 /*     ----------------------- */
2999
3000 /*     DESCRIPTION/NOTES/LIMITATIONS : */
3001 /*     ----------------------------------- */
3002 /* > */
3003 /* ***********************************************************************
3004  */
3005
3006 /*   Name of the program. */
3007
3008
3009 /* **********************************************************************
3010 */
3011
3012 /*     FUNCTION : */
3013 /*     ---------- */
3014 /*      Provides binomial coefficients (Pascal triangle). */
3015
3016 /*     KEYWORDS : */
3017 /*     ----------- */
3018 /*      Binomial coefficient from 0 to 60. read only . init by block data */
3019
3020 /*     DEMSCRIPTION/NOTES/LIMITATIONS : */
3021 /*     ----------------------------------- */
3022 /*     Binomial coefficients form a triangular matrix. */
3023 /*     This matrix is completed in table CNP by its transposition. */
3024 /*     So: CNP(I,J) = CNP(J,I) for I and J = 0, ..., 60. */
3025
3026 /*     Initialization is done with block-data MMLLL09.RES, */
3027 /*     created by the program MQINICNP.FOR. */
3028 /* > */
3029 /* **********************************************************************
3030 */
3031
3032
3033
3034 /* ***********************************************************************
3035  */
3036
3037     /* Parameter adjustments */
3038     courbe_dim1 = *ndimax;
3039     --courbe;
3040     crvcan_dim1 = *ncofmx;
3041     crvcan_offset = crvcan_dim1;
3042     crvcan -= crvcan_offset;
3043
3044     /* Function Body */
3045     ibb = AdvApp2Var_SysBase::mnfndeb_();
3046     if (ibb >= 3) {
3047         AdvApp2Var_SysBase::mgenmsg_("MMCVSTD", 7L);
3048     }
3049     ndeg = *ncoeff - 1;
3050
3051 /* ------------------ Construction of the resulting curve ----------------
3052 */
3053
3054     i__1 = *ndimen;
3055     for (nd = 1; nd <= i__1; ++nd) {
3056         i__2 = ndeg;
3057         for (j = 0; j <= i__2; ++j) {
3058             bid = 0.;
3059             i__3 = ndeg;
3060             for (i__ = j; i__ <= i__3; i__ += 2) {
3061                 bid += crvcan[i__ + nd * crvcan_dim1] * mmcmcnp_.cnp[i__ + j
3062                         * 61];
3063 /* L410: */
3064             }
3065             courbe[nd + j * courbe_dim1] = bid;
3066
3067             bid = 0.;
3068             j1 = j + 1;
3069             i__3 = ndeg;
3070             for (i__ = j1; i__ <= i__3; i__ += 2) {
3071                 bid += crvcan[i__ + nd * crvcan_dim1] * mmcmcnp_.cnp[i__ + j
3072                         * 61];
3073 /* L420: */
3074             }
3075             courbe[nd + j * courbe_dim1] -= bid;
3076 /* L400: */
3077         }
3078 /* L300: */
3079     }
3080
3081 /* ------------------- Renormalization of the CURVE -------------------------
3082  */
3083
3084     bid = 1.;
3085     i__1 = ndeg;
3086     for (i__ = 0; i__ <= i__1; ++i__) {
3087         i__2 = *ndimen;
3088         for (nd = 1; nd <= i__2; ++nd) {
3089             courbe[nd + i__ * courbe_dim1] *= bid;
3090 /* L510: */
3091         }
3092         bid *= 2.;
3093 /* L500: */
3094     }
3095
3096 /* ----------------------------- The end --------------------------------
3097 */
3098
3099     if (ibb >= 3) {
3100         AdvApp2Var_SysBase::mgsomsg_("MMCVSTD", 7L);
3101     }
3102     return 0;
3103 } /* mmcvstd_ */
3104
3105 //=======================================================================
3106 //function : AdvApp2Var_MathBase::mmdrc11_
3107 //purpose  :
3108 //=======================================================================
3109 int AdvApp2Var_MathBase::mmdrc11_(integer *iordre,
3110                                   integer *ndimen,
3111                                   integer *ncoeff,
3112                                   doublereal *courbe,
3113                                   doublereal *points,
3114                                   doublereal *mfactab)
3115
3116 {
3117   /* System generated locals */
3118   integer courbe_dim1, courbe_offset, points_dim2, points_offset, i__1,
3119   i__2;
3120
3121   /* Local variables */
3122
3123   static integer ndeg, i__, j, ndgcb, nd, ibb;
3124
3125
3126 /* **********************************************************************
3127 */
3128
3129 /*     FUNCTION : */
3130 /*     ---------- */
3131 /*        Calculation of successive derivatives of equation CURVE with */
3132 /*        parameters -1, 1 from order 0 to order IORDRE */
3133 /*        included. The calculation is produced without knowing the coefficients of */
3134 /*        derivatives of the curve. */
3135
3136 /*     KEYWORDS : */
3137 /*     ----------- */
3138 /*        POSITIONING,EXTREMITIES,CURVE,DERIVATIVE. */
3139
3140 /*     INPUT ARGUMENTS : */
3141 /*     ------------------ */
3142 /*        IORDRE  : Maximum order of calculation of derivatives. */
3143 /*        NDIMEN  : Dimension of the space. */
3144 /*        NCOEFF  : Number of coefficients of the curve (degree+1). */
3145 /*        COURBE  : Table of coefficients of the curve. */
3146
3147 /*     OUTPUT ARGUMENTS : */
3148 /*     ------------------- */
3149 /*        POINTS    : Table of values of consecutive derivatives */
3150 /*                 of parameters -1.D0 and 1.D0. */
3151 /*        MFACTAB : Auxiliary table for calculation of factorial(I).
3152 */
3153
3154 /*     COMMONS USED   : */
3155 /*     ---------------- */
3156 /*        None. */
3157
3158 /*     REFERENCES CALLED   : */
3159 /*     ----------------------- */
3160
3161 /*     DESCRIPTION/NOTES/LIMITATIONS : */
3162 /*     ----------------------------------- */
3163
3164 /* ---> ATTENTION, the coefficients of the curve are  */
3165 /*     in a reverse order. */
3166
3167 /* ---> The algorithm of calculation of derivatives is based on */
3168 /*     generalization of Horner scheme : */
3169 /*                          k             2 */
3170 /*          Let C(t) = uk.t  + ... + u2.t  + u1.t + u0 . */
3171
3172
3173 /*      a0 = uk, b0 = 0, c0 = 0 and for 1<=j<=k, it is calculated : */
3174
3175 /*          aj = a(j-1).x + u(k-j) */
3176 /*          bj = b(j-1).x + a(j-1) */
3177 /*          cj = c(j-1).x + b(j-1) */
3178
3179 /*     So : C(x) = ak, C'(x) = bk, C"(x) = 2.ck  . */
3180
3181 /*     The algorithm is generalized easily for calculation of */
3182
3183 /*               (n) */
3184 /*              C  (x)   . */
3185 /*             --------- */
3186 /*                n! */
3187
3188 /*      Reference : D. KNUTH, "The Art of Computer Programming" */
3189 /*      ---------              Vol. 2/Seminumerical Algorithms */
3190 /*                             Addison-Wesley Pub. Co. (1969) */
3191 /*                             pages 423-425. */
3192 /* > */
3193 /* **********************************************************************
3194 */
3195
3196 /*   Name of the routine */
3197
3198     /* Parameter adjustments */
3199     points_dim2 = *iordre + 1;
3200     points_offset = (points_dim2 << 1) + 1;
3201     points -= points_offset;
3202     courbe_dim1 = *ncoeff;
3203     courbe_offset = courbe_dim1;
3204     courbe -= courbe_offset;
3205
3206     /* Function Body */
3207     ibb = AdvApp2Var_SysBase::mnfndeb_();
3208     if (ibb >= 2) {
3209         AdvApp2Var_SysBase::mgenmsg_("MMDRC11", 7L);
3210     }
3211
3212     if (*iordre < 0 || *ncoeff < 1) {
3213         goto L9999;
3214     }
3215
3216 /* ------------------- Initialization of table POINTS -----------------
3217 */
3218
3219     ndgcb = *ncoeff - 1;
3220     i__1 = *ndimen;
3221     for (nd = 1; nd <= i__1; ++nd) {
3222         points[(nd * points_dim2 << 1) + 1] = courbe[ndgcb + nd * courbe_dim1]
3223                 ;
3224         points[(nd * points_dim2 << 1) + 2] = courbe[ndgcb + nd * courbe_dim1]
3225                 ;
3226 /* L100: */
3227     }
3228
3229     i__1 = *ndimen;
3230     for (nd = 1; nd <= i__1; ++nd) {
3231         i__2 = *iordre;
3232         for (j = 1; j <= i__2; ++j) {
3233             points[((j + nd * points_dim2) << 1) + 1] = 0.;
3234             points[((j + nd * points_dim2) << 1) + 2] = 0.;
3235 /* L400: */
3236         }
3237 /* L300: */
3238     }
3239
3240 /*    Calculation with parameter -1 and 1 */
3241
3242     i__1 = *ndimen;
3243     for (nd = 1; nd <= i__1; ++nd) {
3244         i__2 = ndgcb;
3245         for (ndeg = 1; ndeg <= i__2; ++ndeg) {
3246             for (i__ = *iordre; i__ >= 1; --i__) {
3247                 points[((i__ + nd * points_dim2) << 1) + 1] = -points[((i__ + nd
3248                         * points_dim2) << 1) + 1] + points[((i__ - 1 + nd *
3249                         points_dim2) << 1) + 1];
3250                 points[((i__ + nd * points_dim2) << 1) + 2] += points[((i__ - 1
3251                         + nd * points_dim2) << 1) + 2];
3252 /* L800: */
3253             }
3254             points[(nd * points_dim2 << 1) + 1] = -points[(nd * points_dim2 <<
3255                      1) + 1] + courbe[ndgcb - ndeg + nd * courbe_dim1];
3256             points[(nd * points_dim2 << 1) + 2] += courbe[ndgcb - ndeg + nd *
3257                     courbe_dim1];
3258 /* L700: */
3259         }
3260 /* L600: */
3261     }
3262
3263 /* --------------------- Multiplication by factorial(I) --------------
3264 */
3265
3266     if (*iordre > 1) {
3267         mfac_(&mfactab[1], iordre);
3268
3269         i__1 = *ndimen;
3270         for (nd = 1; nd <= i__1; ++nd) {
3271             i__2 = *iordre;
3272             for (i__ = 2; i__ <= i__2; ++i__) {
3273                 points[((i__ + nd * points_dim2) << 1) + 1] = mfactab[i__] *
3274                         points[((i__ + nd * points_dim2) << 1) + 1];
3275                 points[((i__ + nd * points_dim2) << 1) + 2] = mfactab[i__] *
3276                         points[((i__ + nd * points_dim2) << 1) + 2];
3277 /* L1000: */
3278             }
3279 /* L900: */
3280         }
3281     }
3282
3283 /* ---------------------------- End -------------------------------------
3284 */
3285
3286 L9999:
3287     if (ibb >= 2) {
3288         AdvApp2Var_SysBase::mgsomsg_("MMDRC11", 7L);
3289     }
3290     return 0;
3291 } /* mmdrc11_ */
3292
3293 //=======================================================================
3294 //function : mmdrvcb_
3295 //purpose  :
3296 //=======================================================================
3297 int mmdrvcb_(integer *ideriv,
3298              integer *ndim,
3299              integer *ncoeff,
3300              doublereal *courbe,
3301              doublereal *tparam,
3302              doublereal *tabpnt,
3303              integer *iercod)
3304
3305 {
3306   /* System generated locals */
3307   integer courbe_dim1, tabpnt_dim1, i__1, i__2, i__3;
3308
3309   /* Local variables */
3310   static integer ndeg, i__, j, nd, ndgcrb, iptpnt, ibb;
3311
3312
3313 /* ***********************************************************************
3314 /*     FUNCTION : */
3315 /*     ---------- */
3316
3317 /*        Calculation of successive derivatives of equation CURVE with */
3318 /*        parameter TPARAM from order 0 to order IDERIV included. */
3319 /*        The calculation is produced without knowing the coefficients of */
3320 /*        derivatives of the CURVE. */
3321
3322 /*     KEYWORDS : */
3323 /*     ----------- */
3324 /*        POSITIONING,PARAMETER,CURVE,DERIVATIVE. */
3325
3326 /*     INPUT ARGUMENTS : */
3327 /*     ------------------ */
3328 /*        IORDRE  : Maximum order of calculation of derivatives. */
3329 /*        NDIMEN  : Dimension of the space. */
3330 /*        NCOEFF  : Number of coefficients of the curve (degree+1). */
3331 /*        COURBE  : Table of coefficients of the curve. */
3332 /*        TPARAM  : Value of the parameter where the curve should be evaluated. */
3333
3334 /*     OUTPUT ARGUMENTS : */
3335 /*     ------------------- */
3336 /*        TABPNT  : Table of values of consecutive derivatives */
3337 /*                  of parameter TPARAM. */
3338   /*        IERCOD  : 0 = OK, */
3339 /*                    1 = incoherent input. */
3340
3341 /*     COMMONS USED  : */
3342 /*     ---------------- */
3343 /*        None. */
3344
3345 /*     REFERENCES CALLED   : */
3346 /*     ----------------------- */
3347
3348 /*     DESCRIPTION/NOTES/LIMITATIONS : */
3349 /*     ----------------------------------- */
3350
3351 /*     The algorithm of  calculation of derivatives is based on */
3352 /*     generalization of the Horner scheme : */
3353 /*                          k             2 */
3354 /*          Let C(t) = uk.t  + ... + u2.t  + u1.t + u0 . */
3355
3356
3357 /*      a0 = uk, b0 = 0, c0 = 0 and for 1<=j<=k, it is calculated : */
3358
3359 /*          aj = a(j-1).x + u(k-j) */
3360 /*          bj = b(j-1).x + a(j-1) */
3361 /*          cj = c(j-1).x + b(j-1) */
3362
3363 /*     So, it is obtained : C(x) = ak, C'(x) = bk, C"(x) = 2.ck  . */
3364
3365 /*     The algorithm can be easily generalized for the calculation of */
3366
3367 /*               (n) */
3368 /*              C  (x)   . */
3369 /*             --------- */
3370 /*                n! */
3371
3372 /*      Reference : D. KNUTH, "The Art of Computer Programming" */
3373 /*      ---------              Vol. 2/Seminumerical Algorithms */
3374 /*                             Addison-Wesley Pub. Co. (1969) */
3375 /*                             pages 423-425. */
3376
3377 /* ---> To evaluare derivatives at 0 and 1, it is preferable */
3378 /*      to use routine MDRV01.FOR . */
3379 /* > */
3380 /* **********************************************************************
3381 */
3382
3383 /*   Name of the routine */
3384
3385     /* Parameter adjustments */
3386     tabpnt_dim1 = *ndim;
3387     --tabpnt;
3388     courbe_dim1 = *ndim;
3389     --courbe;
3390
3391     /* Function Body */
3392     ibb = AdvApp2Var_SysBase::mnfndeb_();
3393     if (ibb >= 2) {
3394         AdvApp2Var_SysBase::mgenmsg_("MMDRVCB", 7L);
3395     }
3396
3397     if (*ideriv < 0 || *ncoeff < 1) {
3398         *iercod = 1;
3399         goto L9999;
3400     }
3401     *iercod = 0;
3402
3403 /* ------------------- Initialization of table TABPNT -----------------
3404 */
3405
3406     ndgcrb = *ncoeff - 1;
3407     i__1 = *ndim;
3408     for (nd = 1; nd <= i__1; ++nd) {
3409         tabpnt[nd] = courbe[nd + ndgcrb * courbe_dim1];
3410 /* L100: */
3411     }
3412
3413     if (*ideriv < 1) {
3414         goto L200;
3415     }
3416     iptpnt = *ndim * *ideriv;
3417     AdvApp2Var_SysBase::mvriraz_((integer *)&iptpnt,
3418              (char *)&tabpnt[tabpnt_dim1 + 1]);
3419 L200:
3420
3421 /* ------------------------ Calculation of parameter TPARAM ------------------
3422 */
3423
3424     i__1 = ndgcrb;
3425     for (ndeg = 1; ndeg <= i__1; ++ndeg) {
3426         i__2 = *ndim;
3427         for (nd = 1; nd <= i__2; ++nd) {
3428             for (i__ = *ideriv; i__ >= 1; --i__) {
3429                 tabpnt[nd + i__ * tabpnt_dim1] = tabpnt[nd + i__ *
3430                         tabpnt_dim1] * *tparam + tabpnt[nd + (i__ - 1) *
3431                         tabpnt_dim1];
3432 /* L700: */
3433             }
3434             tabpnt[nd] = tabpnt[nd] * *tparam + courbe[nd + (ndgcrb - ndeg) *
3435                     courbe_dim1];
3436 /* L600: */
3437         }
3438 /* L500: */
3439     }
3440
3441 /* --------------------- Multiplication by factorial(I) -------------
3442 */
3443
3444     i__1 = *ideriv;
3445     for (i__ = 2; i__ <= i__1; ++i__) {
3446         i__2 = i__;
3447         for (j = 2; j <= i__2; ++j) {
3448             i__3 = *ndim;
3449             for (nd = 1; nd <= i__3; ++nd) {
3450                 tabpnt[nd + i__ * tabpnt_dim1] = (doublereal) j * tabpnt[nd +
3451                         i__ * tabpnt_dim1];
3452 /* L1200: */
3453             }
3454 /* L1100: */
3455         }
3456 /* L1000: */
3457     }
3458
3459 /* --------------------------- The end ---------------------------------
3460 */
3461
3462 L9999:
3463     if (*iercod > 0) {
3464         AdvApp2Var_SysBase::maermsg_("MMDRVCB", iercod, 7L);
3465     }
3466     return 0;
3467 } /* mmdrvcb_ */
3468
3469 //=======================================================================
3470 //function : AdvApp2Var_MathBase::mmdrvck_
3471 //purpose  :
3472 //=======================================================================
3473 int AdvApp2Var_MathBase::mmdrvck_(integer *ncoeff,
3474                                   integer *ndimen,
3475                                   doublereal *courbe,
3476                                   integer *ideriv,
3477                                   doublereal *tparam,
3478                                   doublereal *pntcrb)
3479
3480 {
3481   /* Initialized data */
3482
3483   static doublereal mmfack[21] = { 1.,2.,6.,24.,120.,720.,5040.,40320.,
3484             362880.,3628800.,39916800.,479001600.,6227020800.,87178291200.,
3485             1.307674368e12,2.0922789888e13,3.55687428096e14,6.402373705728e15,
3486             1.21645100408832e17,2.43290200817664e18,5.109094217170944e19 };
3487
3488   /* System generated locals */
3489   integer courbe_dim1, courbe_offset, i__1, i__2;
3490
3491   /* Local variables */
3492   static integer i__, j, k, nd;
3493   static doublereal mfactk, bid;
3494
3495
3496 /*      IMPLICIT INTEGER (I-N) */
3497 /*      IMPLICIT DOUBLE PRECISION(A-H,O-Z) */
3498
3499
3500 /* ***********************************************************************
3501  */
3502
3503 /*     FONCTION : */
3504 /*     ---------- */
3505 /*     Calculate the value of a derived curve of order IDERIV in */
3506 /*     a point of parameter TPARAM. */
3507
3508 /*     KEYWORDS : */
3509 /*     ----------- */
3510 /*     POSITIONING,CURVE,DERIVATIVE of ORDER K. */
3511
3512 /*     INPUT ARGUMENTS  : */
3513 /*     ------------------ */
3514 /*   NCOEFF  : Degree +1 of the curve. */
3515 /*   NDIMEN   : Dimension of the space (2 or 3 in general) */
3516 /*   COURBE  : Table of coefficients of the curve. */
3517 /*   IDERIV : Required order of derivation : 1=1st derivative, etc... */
3518 /*   TPARAM : Value of parameter of the curve. */
3519
3520 /*     OUTPUT ARGUMENTS  : */
3521 /*     ------------------- */
3522 /*   PNTCRB  : Point of parameter TPARAM on the derivative of order */
3523 /*            IDERIV of CURVE. */
3524
3525 /*     COMMONS USED   : */
3526 /*     ---------------- */
3527 /*    MMCMCNP */
3528
3529 /*     REFERENCES CALLED   : */
3530 /*     ---------------------- */
3531 /*      None. */
3532 /*     DESCRIPTION/NOTES/LIMITATIONS : */
3533 /*     ----------------------------------- */
3534
3535 /*    The code below was written basing on the following algorithm :
3536 */
3537
3538 /*    Let P(t) = a1 + a2*t + ... an*t**n. The derivative of order k of P */
3539 /*    (containing n-k coefficients) is calculated as follows : */
3540
3541 /*       Pk(t) = a(k+1)*CNP(k,k)*k! */
3542 /*             + a(k+2)*CNP(k+1,k)*k! * t */
3543 /*             . */
3544 /*             . */
3545 /*             . */
3546 /*             + a(n)*CNP(n-1,k)*k! * t**(n-k-1). */
3547
3548 /*    Evaluation is produced following the classic Horner scheme. */
3549 /* > */
3550 /* ***********************************************************************
3551  */
3552
3553
3554 /*     Factorials (1 to 21)  caculated on VAX in R*16 */
3555
3556
3557 /* **********************************************************************
3558 */
3559
3560 /*     FUNCTION : */
3561 /*     ---------- */
3562 /*      Serves to provide binomial coefficients (Pascal triangle). */
3563
3564 /*     KEYWORDS : */
3565 /*     ----------- */
3566 /*      Binomial Coeff from 0 to 60. read only . init by block data */
3567
3568 /*     DEMSCRIPTION/NOTES/LIMITATIONS : */
3569 /*     ----------------------------------- */
3570 /*     Binomial coefficients form a triangular matrix. */
3571 /*     This matrix is completed in table CNP by its transposition. */
3572 /*     So: CNP(I,J) = CNP(J,I) for I and J = 0, ..., 60. */
3573
3574 /*     Initialization is done by block-data MMLLL09.RES, */
3575 /*     created by program MQINICNP.FOR. */
3576 /* > */
3577 /* **********************************************************************
3578 */
3579
3580
3581
3582 /* ***********************************************************************
3583  */
3584
3585     /* Parameter adjustments */
3586     --pntcrb;
3587     courbe_dim1 = *ndimen;
3588     courbe_offset = courbe_dim1 + 1;
3589     courbe -= courbe_offset;
3590
3591     /* Function Body */
3592
3593 /* -------------- Case when the order of derivative is greater than -------------------
3594 */
3595 /* ---------------- the degree of the curve ---------------------
3596 */
3597
3598     if (*ideriv >= *ncoeff) {
3599         i__1 = *ndimen;
3600         for (nd = 1; nd <= i__1; ++nd) {
3601             pntcrb[nd] = 0.;
3602 /* L100: */
3603         }
3604         goto L9999;
3605     }
3606 /* **********************************************************************
3607 */
3608 /*                         General processing*/
3609 /* **********************************************************************
3610 */
3611 /* --------------------- Calculation of Factorial(IDERIV) ------------------
3612 */
3613
3614     k = *ideriv;
3615     if (*ideriv <= 21 && *ideriv > 0) {
3616         mfactk = mmfack[k - 1];
3617     } else {
3618         mfactk = 1.;
3619         i__1 = k;
3620         for (i__ = 2; i__ <= i__1; ++i__) {
3621             mfactk *= i__;
3622 /* L200: */
3623         }
3624     }
3625
3626 /* ------- Calculation of derivative of order IDERIV of CURVE in TPARAM -----
3627 */
3628 /* ---> Attention : binomial coefficient C(n,m) is represented in */
3629 /*                 MCCNP by CNP(N,M). */
3630
3631     i__1 = *ndimen;
3632     for (nd = 1; nd <= i__1; ++nd) {
3633         pntcrb[nd] = courbe[nd + *ncoeff * courbe_dim1] * mmcmcnp_.cnp[*
3634                 ncoeff - 1 + k * 61] * mfactk;
3635 /* L300: */
3636     }
3637
3638     i__1 = k + 1;
3639     for (j = *ncoeff - 1; j >= i__1; --j) {
3640         bid = mmcmcnp_.cnp[j - 1 + k * 61] * mfactk;
3641         i__2 = *ndimen;
3642         for (nd = 1; nd <= i__2; ++nd) {
3643             pntcrb[nd] = pntcrb[nd] * *tparam + courbe[nd + j * courbe_dim1] *
3644                      bid;
3645 /* L500: */
3646         }
3647 /* L400: */
3648     }
3649
3650 /* -------------------------------- The end -----------------------------
3651 */
3652
3653 L9999:
3654
3655  return 0   ;
3656
3657 } /* mmdrvck_ */
3658 //=======================================================================
3659 //function : AdvApp2Var_MathBase::mmeps1_
3660 //purpose  :
3661 //=======================================================================
3662 int AdvApp2Var_MathBase::mmeps1_(doublereal *epsilo)
3663
3664 {
3665 /* ***********************************************************************
3666  */
3667
3668 /*     FUNCTION : */
3669 /*     ---------- */
3670 /*        Extraction of EPS1 from COMMON MPRCSN. EPS1 is spatial zero  */
3671 /*     equal to 1.D-9 */
3672
3673 /*     KEYWORDS : */
3674 /*     ----------- */
3675 /*        MPRCSN,PRECISON,EPS1. */
3676
3677 /*     INPUT ARGUMENTS : */
3678 /*     ------------------ */
3679 /*        None */
3680
3681 /*     OUTPUT ARGUMENTS : */
3682 /*     ------------------- */
3683 /*        EPSILO : Value of EPS1 (spatial zero (10**-9)) */
3684
3685 /*     COMMONS USED   : */
3686 /*     ---------------- */
3687
3688 /*     REFERENCES CALLED   : */
3689 /*     ----------------------- */
3690
3691 /*     DESCRIPTION/NOTES/LIMITATIONS : */
3692 /*     ----------------------------------- */
3693 /*     EPS1 is ABSOLUTE spatial zero, so it is necessary */
3694 /*     to use it whenever it is necessary to test if a variable */
3695 /*     is null. For example, if the norm of a vector is lower than */
3696 /*     EPS1, this vector is NULL ! (when one works in */
3697 /*     REAL*8) It is absolutely not advised to test arguments  */
3698 /*     compared to EPS1**2. Taking into account the rounding errors inevitable */
3699 /*     during calculations, this causes testing compared to 0.D0. */
3700 /* > */
3701 /* ***********************************************************************
3702  */
3703
3704
3705
3706 /* ***********************************************************************
3707  */
3708
3709 /*     FUNCTION : */
3710 /*     ---------- */
3711 /*          Gives tolerances of invalidity in stream */
3712 /*          as well as limits of iterative processes */
3713
3714 /*          general context, modifiable by the user */
3715
3716 /*     KEYWORDS : */
3717 /*     ----------- */
3718 /*          PARAMETER , TOLERANCE */
3719
3720 /*     DEMSCRIPTION/NOTES/LIMITATIONS : */
3721 /*     ----------------------------------- */
3722 /*       INITIALISATION   :  profile , **VIA MPRFTX** at input in stream
3723 /*       loading of default values of the profile in MPRFTX at input */
3724 /*       in stream. They are preserved in local variables of MPRFTX */
3725
3726 /*        Reset of default values                  : MDFINT */
3727 /*        Interactive modification by the user   : MDBINT */
3728
3729 /*        ACCESS FUNCTION  :  MMEPS1   ...  EPS1 */
3730 /*                            MEPSPB  ...  EPS3,EPS4 */
3731 /*                            MEPSLN  ...  EPS2, NITERM , NITERR */
3732 /*                            MEPSNR  ...  EPS2 , NITERM */
3733 /*                            MITERR  ...  NITERR */
3734 /* > */
3735 /* ***********************************************************************
3736  */
3737
3738 /*     NITERM : max nb of iterations */
3739 /*     NITERR : nb of rapid iterations */
3740 /*     EPS1   : tolerance of 3D null distance */
3741 /*     EPS2   : tolerance of parametric null distance */
3742 /*     EPS3   : tolerance to avoid division by 0.. */
3743 /*     EPS4   : angular tolerance */
3744
3745
3746
3747 /* ***********************************************************************
3748  */
3749     *epsilo = mmprcsn_.eps1;
3750
3751  return 0 ;
3752 } /* mmeps1_ */
3753
3754 //=======================================================================
3755 //function : mmexthi_
3756 //purpose  :
3757 //=======================================================================
3758 int mmexthi_(integer *ndegre,
3759              doublereal *hwgaus)
3760
3761 {
3762   /* System generated locals */
3763   integer i__1;
3764
3765   /* Local variables */
3766   static integer iadd, ideb, ndeg2, nmod2, ii, ibb;
3767   static integer kpt;
3768
3769 /* **********************************************************************
3770 */
3771
3772 /*     FONCTION : */
3773 /*     ---------- */
3774 /*  Extract of common LDGRTL the weight of formulas of  */
3775 /*  Gauss quadrature on all roots of Legendre polynoms of degree */
3776 /*  NDEGRE defined on [-1,1]. */
3777
3778 /*     KEYWORDS : */
3779 /*     ----------- */
3780 /*     ALL, AB_SPECIFI::COMMON&, EXTRACTION, &WEIGHT, &GAUSS. */
3781
3782 /*     INPUT ARGUMENTS : */
3783 /*     ------------------ */
3784 /*   NDEGRE : Mathematic degree of Legendre polynom. It should have */
3785 /*            2 <= NDEGRE <= 61. */
3786
3787 /*     OUTPUT ARGUMENTS : */
3788 /*     ------------------- */
3789 /*   HWGAUS : The table of weights of Gauss quadrature formulas */
3790 /*            relative to NDEGRE roots of a polynome de Legendre de */
3791 /*            degre NDEGRE. */
3792
3793 /*     COMMONS UTILISES   : */
3794 /*     ---------------- */
3795 /*     MLGDRTL */
3796
3797 /*     REFERENCES CALLED   : */
3798 /*     ----------------------- */
3799
3800 /*     DESCRIPTION/NOTES/LIMITATIONS : */
3801 /*     ----------------------------------- */
3802 /*     ATTENTION: The condition on NDEGRE ( 2 <= NDEGRE <= 61) is not  */
3803 /*     tested. The caller should make the test.
3804
3805 /*   Name of the routine */
3806
3807
3808 /*   Common MLGDRTL: */
3809 /*   This common includes POSITIVE roots of Legendre polynims */
3810 /*   AND weights of Gauss quadrature formulas on all */
3811 /*   POSITIVE roots of Legendre polynoms. */
3812
3813
3814
3815 /* ***********************************************************************
3816  */
3817
3818 /*     FUNCTION : */
3819 /*     ---------- */
3820 /*   The common of Legendre roots. */
3821
3822 /*     KEYWORDS : */
3823 /*     ----------- */
3824 /*        BASE LEGENDRE */
3825
3826 /*     DESCRIPTION/NOTES/LIMITATIONS : */
3827 /*     ----------------------------------- */
3828 /* > */
3829 /* ***********************************************************************
3830  */
3831
3832
3833
3834
3835 /*   ROOTAB : Table of all roots of Legendre polynoms */
3836 /*   within the interval [0,1]. They are ranked for the degrees increasing from */
3837 /*   2 to 61. */
3838 /*   HILTAB : Table of Legendre interpolators concerning ROOTAB. */
3839 /*   The adressing is the same. */
3840 /*   HI0TAB : Table of Legendre interpolators for root x=0 */
3841 /*   of polynoms of UNEVEN degree. */
3842 /*   RTLTB0 : Table of Li(uk) where uk are the roots of */
3843 /*  Legendre polynom of EVEN degree. */
3844 /*   RTLTB1 : Table of Li(uk) where uk are the roots of */
3845 /*  Legendre polynom of UNEVEN degree. */
3846
3847
3848 /************************************************************************
3849 *****/
3850     /* Parameter adjustments */
3851     --hwgaus;
3852
3853     /* Function Body */
3854     ibb = AdvApp2Var_SysBase::mnfndeb_();
3855     if (ibb >= 3) {
3856         AdvApp2Var_SysBase::mgenmsg_("MMEXTHI", 7L);
3857     }
3858
3859     ndeg2 = *ndegre / 2;
3860     nmod2 = *ndegre % 2;
3861
3862 /*   Address of Gauss weight associated to the 1st strictly */
3863 /*   positive root of Legendre polynom of degree NDEGRE in MLGDRTL. */
3864
3865     iadd = ndeg2 * (ndeg2 - 1) / 2 + 1;
3866
3867 /*   Index of the 1st HWGAUS element associated to the 1st strictly  */
3868 /*   positive root of Legendre polynom of degree NDEGRE. */
3869
3870     ideb = (*ndegre + 1) / 2 + 1;
3871
3872 /*   Reading of weights associated to strictly positive roots. */
3873
3874     i__1 = *ndegre;
3875     for (ii = ideb; ii <= i__1; ++ii) {
3876         kpt = iadd + ii - ideb;
3877         hwgaus[ii] = mlgdrtl_.hiltab[kpt + nmod2 * 465 - 1];
3878 /* L100: */
3879     }
3880
3881 /*   For strictly negative roots, the weight is the same. */
3882 /*   i.e HW(1) = HW(NDEGRE), HW(2) = HW(NDEGRE-1), etc... */
3883
3884     i__1 = ndeg2;
3885     for (ii = 1; ii <= i__1; ++ii) {
3886         hwgaus[ii] = hwgaus[*ndegre + 1 - ii];
3887 /* L200: */
3888     }
3889
3890 /*   Case of uneven NDEGRE, 0 is root of Legendre polynom, */
3891 /*   associated Gauss weights are loaded. */
3892
3893     if (nmod2 == 1) {
3894         hwgaus[ndeg2 + 1] = mlgdrtl_.hi0tab[ndeg2];
3895     }
3896
3897 /* --------------------------- The end ----------------------------------
3898 */
3899
3900     if (ibb >= 3) {
3901         AdvApp2Var_SysBase::mgsomsg_("MMEXTHI", 7L);
3902     }
3903     return 0;
3904 } /* mmexthi_ */
3905
3906 //=======================================================================
3907 //function : mmextrl_
3908 //purpose  :
3909 //=======================================================================
3910 int mmextrl_(integer *ndegre,
3911              doublereal *rootlg)
3912 {
3913   /* System generated locals */
3914   integer i__1;
3915
3916   /* Local variables */
3917   static integer iadd, ideb, ndeg2, nmod2, ii, ibb;
3918   static integer kpt;
3919
3920
3921 /* **********************************************************************
3922 */
3923
3924 /*     FUNCTION : */
3925 /*     ---------- */
3926 /* Extract of the Common LDGRTL of Legendre polynom roots */
3927 /* of degree NDEGRE defined on [-1,1]. */
3928
3929 /*     KEYWORDS : */
3930 /*     ----------- */
3931 /*     ALL, AB_SPECIFI::COMMON&, EXTRACTION, &ROOT, &LEGENDRE. */
3932
3933 /*     INPUT ARGUMENTS : */
3934 /*     ------------------ */
3935 /*   NDEGRE : Mathematic degree of Legendre polynom.  */
3936 /*            It is required to have 2 <= NDEGRE <= 61. */
3937
3938 /*     OUTPUT ARGUMENTS : */
3939 /*     ------------------- */
3940 /*   ROOTLG : The table of roots of Legendre polynom of degree */
3941 /*            NDEGRE defined on [-1,1]. */
3942
3943 /*     COMMONS USED   : */
3944 /*     ---------------- */
3945 /*     MLGDRTL */
3946
3947 /*     REFERENCES CALLED   : */
3948 /*     ----------------------- */
3949
3950 /*     DESCRIPTION/NOTES/LIMITATIONS : */
3951 /*     ----------------------------------- */
3952 /*     ATTENTION: Condition of NDEGRE ( 2 <= NDEGRE <= 61) is not */
3953 /*     tested. The caller should make the test. */
3954 /* > */
3955 /* **********************************************************************
3956 */
3957
3958
3959 /*   Name of the routine */
3960
3961
3962 /*   Common MLGDRTL: */
3963 /*   This common includes POSITIVE roots of Legendre polynoms */
3964 /*   AND the weight of Gauss quadrature formulas on all */
3965 /*   POSITIVE roots of Legendre polynoms. */
3966
3967 /* ***********************************************************************
3968  */
3969
3970 /*     FUNCTION : */
3971 /*     ---------- */
3972 /*   The common of Legendre roots. */
3973
3974 /*     KEYWORDS : */
3975 /*     ----------- */
3976 /*        BASE LEGENDRE */
3977
3978
3979 /* ***********************************************************************
3980  */
3981
3982 /*   ROOTAB : Table of all roots of Legendre polynoms */
3983 /*   within the interval [0,1]. They are ranked for the degrees increasing from */
3984 /*   2 to 61. */
3985 /*   HILTAB : Table of Legendre interpolators concerning ROOTAB. */
3986 /*   The adressing is the same. */
3987 /*   HI0TAB : Table of Legendre interpolators for root x=0 */
3988 /*   of polynoms of UNEVEN degree. */
3989 /*   RTLTB0 : Table of Li(uk) where uk are the roots of */
3990 /*  Legendre polynom of EVEN degree. */
3991 /*   RTLTB1 : Table of Li(uk) where uk are the roots of */
3992 /*  Legendre polynom of UNEVEN degree. */
3993
3994
3995 /************************************************************************
3996 *****/
3997     /* Parameter adjustments */
3998     --rootlg;
3999
4000     /* Function Body */
4001     ibb = AdvApp2Var_SysBase::mnfndeb_();
4002     if (ibb >= 3) {
4003         AdvApp2Var_SysBase::mgenmsg_("MMEXTRL", 7L);
4004     }
4005
4006     ndeg2 = *ndegre / 2;
4007     nmod2 = *ndegre % 2;
4008
4009 /*   Address of the 1st strictly positive root of Legendre polynom */
4010 /*   of degree NDEGRE in MLGDRTL. */
4011
4012     iadd = ndeg2 * (ndeg2 - 1) / 2 + 1;
4013
4014 /*   Indice, in ROOTLG, of the 1st strictly positive root */
4015 /*   of Legendre polynom of degree NDEGRE. */
4016
4017     ideb = (*ndegre + 1) / 2 + 1;
4018
4019 /*   Reading of strictly positive roots. */
4020
4021     i__1 = *ndegre;
4022     for (ii = ideb; ii <= i__1; ++ii) {
4023         kpt = iadd + ii - ideb;
4024         rootlg[ii] = mlgdrtl_.rootab[kpt + nmod2 * 465 - 1];
4025 /* L100: */
4026     }
4027
4028 /*   Strictly negative roots are equal to positive roots
4029 */
4030 /*   to the sign i.e RT(1) = -RT(NDEGRE), RT(2) = -RT(NDEGRE-1), etc...
4031 */
4032
4033     i__1 = ndeg2;
4034     for (ii = 1; ii <= i__1; ++ii) {
4035         rootlg[ii] = -rootlg[*ndegre + 1 - ii];
4036 /* L200: */
4037     }
4038
4039 /*   Case NDEGRE uneven, 0 is root of Legendre polynom. */
4040
4041     if (nmod2 == 1) {
4042         rootlg[ndeg2 + 1] = 0.;
4043     }
4044
4045 /* -------------------------------- THE END -----------------------------
4046 */
4047
4048     if (ibb >= 3) {
4049         AdvApp2Var_SysBase::mgenmsg_("MMEXTRL", 7L);
4050     }
4051     return 0;
4052 } /* mmextrl_ */
4053
4054 //=======================================================================
4055 //function : AdvApp2Var_MathBase::mmfmca8_
4056 //purpose  :
4057 //=======================================================================
4058 int AdvApp2Var_MathBase::mmfmca8_(integer *ndimen,
4059                                   integer *ncoefu,
4060                                   integer *ncoefv,
4061                                   integer *ndimax,
4062                                   integer *ncfumx,
4063                                   integer *,//ncfvmx,
4064                                   doublereal *tabini,
4065                                   doublereal *tabres)
4066
4067 {
4068   /* System generated locals */
4069   integer tabini_dim1, tabini_dim2, tabini_offset, tabres_dim1, tabres_dim2,
4070   tabres_offset;
4071
4072   /* Local variables */
4073   static integer i__, j, k, ilong;
4074
4075
4076
4077 /* **********************************************************************
4078 */
4079
4080 /*     FUNCTION : */
4081 /*     ---------- */
4082 /*        Expansion of a table containing only most important things into a  */
4083 /*        greater data table. */
4084
4085 /*     KEYWORDS : */
4086 /*     ----------- */
4087 /*     ALL, MATH_ACCES:: CARREAU&, DECOMPRESSION, &CARREAU */
4088
4089 /*     INPUT ARGUMENTS : */
4090 /*     ------------------ */
4091 /*        NDIMEN: Dimension of the workspace. */
4092 /*        NCOEFU: Degree +1 of the table by u. */
4093 /*        NCOEFV: Degree +1 of the table by v. */
4094 /*        NDIMAX: Max dimension of the space. */
4095 /*        NCFUMX: Max Degree +1 of the table by u. */
4096 /*        NCFVMX: Max Degree +1 of the table by v. */
4097 /*        TABINI: The table to be decompressed. */
4098
4099 /*     OUTPUT ARGUMENTS : */
4100 /*     ------------------- */
4101 /*        TABRES: Decompressed table. */
4102
4103 /*     COMMONS USED   : */
4104 /*     ---------------- */
4105
4106 /*     REFERENCES CALLED   : */
4107 /*     ----------------------- */
4108
4109 /*     DESCRIPTION/NOTES/LIMITATIONS : */
4110 /*     ----------------------------------- */
4111 /*     The following call : */
4112
4113 /*  CALL MMFMCA8(NDIMEN,NCOEFU,NCOEFV,NDIMAX,NCFUMX,NCFVMX,TABINI,TABINI)
4114 */
4115
4116 /*     where TABINI is input/output argument, is possible provided */
4117 /*     that the caller has declared TABINI in (NDIMAX,NCFUMX,NCFVMX) */
4118
4119 /*     ATTENTION : it is not checked that NDIMAX >= NDIMEN, */
4120 /*                 NCOEFU >= NCFMXU and NCOEFV >= NCFMXV. */
4121 /* > */
4122 /* **********************************************************************
4123 */
4124
4125
4126     /* Parameter adjustments */
4127     tabini_dim1 = *ndimen;
4128     tabini_dim2 = *ncoefu;
4129     tabini_offset = tabini_dim1 * (tabini_dim2 + 1) + 1;
4130     tabini -= tabini_offset;
4131     tabres_dim1 = *ndimax;
4132     tabres_dim2 = *ncfumx;
4133     tabres_offset = tabres_dim1 * (tabres_dim2 + 1) + 1;
4134     tabres -= tabres_offset;
4135
4136     /* Function Body */
4137     if (*ndimax == *ndimen) {
4138         goto L1000;
4139     }
4140
4141 /* ----------------------- decompression NDIMAX<>NDIMEN -----------------
4142 */
4143
4144     for (k = *ncoefv; k >= 1; --k) {
4145         for (j = *ncoefu; j >= 1; --j) {
4146             for (i__ = *ndimen; i__ >= 1; --i__) {
4147                 tabres[i__ + (j + k * tabres_dim2) * tabres_dim1] = tabini[
4148                         i__ + (j + k * tabini_dim2) * tabini_dim1];
4149 /* L300: */
4150             }
4151 /* L200: */
4152         }
4153 /* L100: */
4154     }
4155     goto L9999;
4156
4157 /* ----------------------- decompression NDIMAX=NDIMEN ------------------
4158 */
4159
4160 L1000:
4161     if (*ncoefu == *ncfumx) {
4162         goto L2000;
4163     }
4164     ilong = (*ndimen << 3) * *ncoefu;
4165     for (k = *ncoefv; k >= 1; --k) {
4166         AdvApp2Var_SysBase::mcrfill_((integer *)&ilong,
4167                  (char *)&tabini[(k * tabini_dim2 + 1) * tabini_dim1 + 1],
4168                  (char *)&tabres[(k * tabres_dim2 + 1) * tabres_dim1 + 1]);
4169 /* L500: */
4170     }
4171     goto L9999;
4172
4173 /* ----------------- decompression NDIMAX=NDIMEN,NCOEFU=NCFUMX ----------
4174 */
4175
4176 L2000:
4177     ilong = (*ndimen << 3) * *ncoefu * *ncoefv;
4178     AdvApp2Var_SysBase::mcrfill_((integer *)&ilong,
4179              (char *)&tabini[tabini_offset],
4180              (char *)&tabres[tabres_offset]);
4181     goto L9999;
4182
4183 /* ---------------------------- The end ---------------------------------
4184 */
4185
4186 L9999:
4187     return 0;
4188 } /* mmfmca8_ */
4189
4190 //=======================================================================
4191 //function : AdvApp2Var_MathBase::mmfmca9_
4192 //purpose  :
4193 //=======================================================================
4194  int AdvApp2Var_MathBase::mmfmca9_(integer *ndimax,
4195                                    integer *ncfumx,
4196                                    integer *,//ncfvmx,
4197                                    integer *ndimen,
4198                                    integer *ncoefu,
4199                                    integer *ncoefv,
4200                                    doublereal *tabini,
4201                                    doublereal *tabres)
4202
4203 {
4204   /* System generated locals */
4205   integer tabini_dim1, tabini_dim2, tabini_offset, tabres_dim1, tabres_dim2,
4206   tabres_offset, i__1, i__2, i__3;
4207
4208     /* Local variables */
4209   static integer i__, j, k, ilong;
4210
4211
4212
4213 /* **********************************************************************
4214 */
4215
4216 /*     FUNCTION : */
4217 /*     ---------- */
4218 /*        Compression of a data table in a table */
4219 /*        containing only the main data (the input table is not removed). */
4220
4221 /*     KEYWORDS: */
4222 /*     ----------- */
4223 /*     ALL, MATH_ACCES:: CARREAU&, COMPRESSION, &CARREAU */
4224
4225 /*     INPUT ARGUMENTS : */
4226 /*     ------------------ */
4227 /*        NDIMAX: Max dimension of the space. */
4228 /*        NCFUMX: Max degree +1 of the table by u. */
4229 /*        NCFVMX: Max degree +1 of the table by v. */
4230 /*        NDIMEN: Dimension of the workspace. */
4231 /*        NCOEFU: Degree +1 of the table by u. */
4232 /*        NCOEFV: Degree +1 of the table by v. */
4233 /*        TABINI: The table to compress. */
4234
4235 /*     OUTPUT ARGUMENTS : */
4236 /*     ------------------- */
4237 /*        TABRES: The compressed table. */
4238
4239 /*     COMMONS USED   : */
4240 /*     ---------------- */
4241
4242 /*     REFERENCES CALLED   : */
4243 /*     ----------------------- */
4244
4245 /*     DESCRIPTION/NOTES/LIMITATIONS : */
4246 /*     ----------------------------------- */
4247 /*     The following call : */
4248
4249 /* CALL MMFMCA9(NDIMAX,NCFUMX,NCFVMX,NDIMEN,NCOEFU,NCOEFV,TABINI,TABINI)
4250 */
4251
4252 /*     where TABINI is input/output argument, is possible provided */
4253 /*     that the caller has checked that : */
4254
4255 /*            NDIMAX > NDIMEN, */
4256 /*         or NDIMAX = NDIMEN and NCFUMX > NCOEFU */
4257 /*         or  NDIMAX = NDIMEN, NCFUMX = NCOEFU and NCFVMX > NCOEFV */
4258
4259 /*     These conditions are not tested in the program. */
4260
4261 /* > */
4262 /* **********************************************************************
4263 */
4264
4265
4266     /* Parameter adjustments */
4267     tabini_dim1 = *ndimax;
4268     tabini_dim2 = *ncfumx;
4269     tabini_offset = tabini_dim1 * (tabini_dim2 + 1) + 1;
4270     tabini -= tabini_offset;
4271     tabres_dim1 = *ndimen;
4272     tabres_dim2 = *ncoefu;
4273     tabres_offset = tabres_dim1 * (tabres_dim2 + 1) + 1;
4274     tabres -= tabres_offset;
4275
4276     /* Function Body */
4277     if (*ndimen == *ndimax) {
4278         goto L1000;
4279     }
4280
4281 /* ----------------------- Compression NDIMEN<>NDIMAX -------------------
4282 */
4283
4284     i__1 = *ncoefv;
4285     for (k = 1; k <= i__1; ++k) {
4286         i__2 = *ncoefu;
4287         for (j = 1; j <= i__2; ++j) {
4288             i__3 = *ndimen;
4289             for (i__ = 1; i__ <= i__3; ++i__) {
4290                 tabres[i__ + (j + k * tabres_dim2) * tabres_dim1] = tabini[
4291                         i__ + (j + k * tabini_dim2) * tabini_dim1];
4292 /* L300: */
4293             }
4294 /* L200: */
4295         }
4296 /* L100: */
4297     }
4298     goto L9999;
4299
4300 /* ----------------------- Compression NDIMEN=NDIMAX --------------------
4301 */
4302
4303 L1000:
4304     if (*ncoefu == *ncfumx) {
4305         goto L2000;
4306     }
4307     ilong = (*ndimen << 3) * *ncoefu;
4308     i__1 = *ncoefv;
4309     for (k = 1; k <= i__1; ++k) {
4310         AdvApp2Var_SysBase::mcrfill_((integer *)&ilong,
4311                  (char *)&tabini[(k * tabini_dim2 + 1) * tabini_dim1 + 1],
4312                  (char *)&tabres[(k * tabres_dim2 + 1) * tabres_dim1 + 1]);
4313 /* L500: */
4314     }
4315     goto L9999;
4316
4317 /* ----------------- Compression NDIMEN=NDIMAX,NCOEFU=NCFUMX ------------
4318 */
4319
4320 L2000:
4321     ilong = (*ndimen << 3) * *ncoefu * *ncoefv;
4322     AdvApp2Var_SysBase::mcrfill_((integer *)&ilong,
4323              (char *)&tabini[tabini_offset],
4324              (char *)&tabres[tabres_offset]);
4325     goto L9999;
4326
4327 /* ---------------------------- The end ---------------------------------
4328 */
4329
4330 L9999:
4331     return 0;
4332 } /* mmfmca9_ */
4333
4334 //=======================================================================
4335 //function : AdvApp2Var_MathBase::mmfmcar_
4336 //purpose  :
4337 //=======================================================================
4338 int AdvApp2Var_MathBase::mmfmcar_(integer *ndimen,
4339                                   integer *ncofmx,
4340                                   integer *ncoefu,
4341                                   integer *ncoefv,
4342                                   doublereal *patold,
4343                                   doublereal *upara1,
4344                                   doublereal *upara2,
4345                                   doublereal *vpara1,
4346                                   doublereal *vpara2,
4347                                   doublereal *patnew,
4348                                   integer *iercod)
4349
4350 {
4351   static integer c__8 = 8;
4352   /* System generated locals */
4353     integer patold_dim1, patold_dim2, patnew_dim1, patnew_dim2,
4354             i__1, patold_offset,patnew_offset;
4355
4356     /* Local variables */
4357     static doublereal tbaux[1];
4358     static integer ksize, numax, kk;
4359     static long int iofst;
4360     static integer ibb, ier;
4361
4362 /* ***********************************************************************
4363  */
4364
4365 /*     FUNCTION : */
4366 /*     ---------- */
4367 /*       LIMITATION OF A SQUARE DEFINED ON (0,1)*(0,1) BETWEEN ISOS */
4368 /*       UPARA1 AND UPARA2 (BY U) AND VPARA1 AND VPARA2 BY V. */
4369
4370 /*     KEYWORDS : */
4371 /*     ----------- */
4372 /*       LIMITATION , SQUARE , PARAMETER */
4373
4374 /*     INPUT ARGUMENTS : */
4375 /*     ------------------ */
4376 /*     NCOFMX: MAX NUMBER OF COEFF OF THE SQUARE BY U */
4377 /*     NCOEFU: NUMBER OF COEFF OF THE SQUARE BY U */
4378 /*     NCOEFV: NUMBER OF COEFF OF THE SQUARE BY V */
4379 /*     PATOLD : THE SQUARE IS LIMITED BY UPARA1,UPARA2 AND VPARA1,VPARA2
4380 .*/
4381 /*     UPARA1    : LOWER LIMIT OF U */
4382 /*     UPARA2    : UPPER LIMIT OF U */
4383 /*     VPARA1    : LOWER LIMIT OF V */
4384 /*     VPARA2    : UPPER LIMIT OF V */
4385
4386 /*     OUTPUT ARGUMENTS : */
4387 /*     ------------------- */
4388 /*     PATNEW : RELIMITED SQUARE, DEFINED ON (0,1)**2 */
4389 /*     IERCOD : =10 COEFF NB TOO GREAT OR NULL */
4390 /*              =13 PB IN THE DYNAMIC ALLOCATION */
4391 /*              = 0 OK. */
4392
4393 /*     COMMONS USED   : */
4394 /*     ---------------- */
4395
4396 /*     DESCRIPTION/NOTES/LIMITATIONS : */
4397 /*     ----------------------------------- */
4398 /* --->    The following call : */
4399 /*   CALL MMFMCAR(NCOFMX,NCOEFU,NCOEFV,PATOLD,UPARA1,UPARA2,VPARA1,VPARA2
4400 */
4401 /*              ,PATOLD), */
4402 /*        where PATOLD is input/output argument is absolutely legal. */
4403
4404 /* --->    The max number of coeff by u and v of PATOLD is 61 */
4405
4406 /* --->    If NCOEFU < NCOFMX, the data is compressed by MMFMCA9 before
4407 /*        limitation by v to get time during the execution */
4408 /*        of MMARC41 that follows (the square is processed as a curve of
4409 */
4410 /*        dimension NDIMEN*NCOEFU possessing NCOEFV coefficients). */
4411 /* > */
4412 /* ***********************************************************************
4413  */
4414
4415 /*   Name of the routine */
4416
4417
4418     /* Parameter adjustments */
4419     patnew_dim1 = *ndimen;
4420     patnew_dim2 = *ncofmx;
4421     patnew_offset = patnew_dim1 * (patnew_dim2 + 1) + 1;
4422     patnew -= patnew_offset;
4423     patold_dim1 = *ndimen;
4424     patold_dim2 = *ncofmx;
4425     patold_offset = patold_dim1 * (patold_dim2 + 1) + 1;
4426     patold -= patold_offset;
4427
4428     /* Function Body */
4429     ibb = AdvApp2Var_SysBase::mnfndeb_();
4430     if (ibb >= 2) {
4431         AdvApp2Var_SysBase::mgenmsg_("MMFMCAR", 7L);
4432     }
4433     *iercod = 0;
4434     iofst = 0;
4435
4436 /* **********************************************************************
4437 */
4438 /*                  TEST OF COEFFICIENT NUMBERS */
4439 /* **********************************************************************
4440 */
4441
4442     if (*ncofmx < *ncoefu) {
4443         *iercod = 10;
4444         goto L9999;
4445     }
4446     if (*ncoefu < 1 || *ncoefu > 61 || *ncoefv < 1 || *ncoefv > 61) {
4447         *iercod = 10;
4448         goto L9999;
4449     }
4450
4451 /* **********************************************************************
4452 */
4453 /*                  CASE WHEN UPARA1=VPARA1=0 AND UPARA2=VPARA2=1 */
4454 /* **********************************************************************
4455 */
4456
4457     if (*upara1 == 0. && *upara2 == 1. && *vpara1 == 0. && *vpara2 == 1.) {
4458         ksize = (*ndimen << 3) * *ncofmx * *ncoefv;
4459         AdvApp2Var_SysBase::mcrfill_((integer *)&ksize,
4460                  (char *)&patold[patold_offset],
4461                  (char *)&patnew[patnew_offset]);
4462         goto L9999;
4463     }
4464
4465 /* **********************************************************************
4466 */
4467 /*                        LIMITATION BY U */
4468 /* **********************************************************************
4469 */
4470
4471     if (*upara1 == 0. && *upara2 == 1.) {
4472         goto L2000;
4473     }
4474     i__1 = *ncoefv;
4475     for (kk = 1; kk <= i__1; ++kk) {
4476         mmarc41_(ndimen, ndimen, ncoefu, &patold[(kk * patold_dim2 + 1) *
4477                 patold_dim1 + 1], upara1, upara2, &patnew[(kk * patnew_dim2 +
4478                 1) * patnew_dim1 + 1], iercod);
4479 /* L100: */
4480     }
4481
4482 /* **********************************************************************
4483 */
4484 /*                         LIMITATION BY V */
4485 /* **********************************************************************
4486 */
4487
4488 L2000:
4489     if (*vpara1 == 0. && *vpara2 == 1.) {
4490         goto L9999;
4491     }
4492
4493 /* ----------- LIMITATION BY V (WITH COMPRESSION I.E. NCOEFU<NCOFMX) ----
4494 */
4495
4496     numax = *ndimen * *ncoefu;
4497     if (*ncofmx != *ncoefu) {
4498 /* ------------------------- Dynamic allocation -------------------
4499 ---- */
4500         ksize = *ndimen * *ncoefu * *ncoefv;
4501         AdvApp2Var_SysBase::mcrrqst_(&c__8, &ksize, tbaux, &iofst, &ier);
4502         if (ier > 0) {
4503             *iercod = 13;
4504             goto L9900;
4505         }
4506 /* --------------- Compression by (NDIMEN,NCOEFU,NCOEFV) ------------
4507 ---- */
4508         if (*upara1 == 0. && *upara2 == 1.) {
4509           AdvApp2Var_MathBase::mmfmca9_(ndimen,
4510                                         ncofmx,
4511                                         ncoefv,
4512                                         ndimen,
4513                                         ncoefu,
4514                                         ncoefv,
4515                                         &patold[patold_offset],
4516                                         &tbaux[iofst]);
4517         } else {
4518           AdvApp2Var_MathBase::mmfmca9_(ndimen,
4519                                         ncofmx,
4520                                         ncoefv,
4521                                         ndimen,
4522                                         ncoefu,
4523                                         ncoefv,
4524                                         &patnew[patnew_offset],
4525                                         &tbaux[iofst]);
4526         }
4527 /* ------------------------- Limitation by v ------------------------
4528 ---- */
4529         mmarc41_(&numax, &numax, ncoefv, &tbaux[iofst], vpara1, vpara2, &
4530                 tbaux[iofst], iercod);
4531 /* --------------------- Expansion of TBAUX into PATNEW -------------
4532 --- */
4533         AdvApp2Var_MathBase::mmfmca8_(ndimen, ncoefu, ncoefv, ndimen, ncofmx, ncoefv, &tbaux[iofst]
4534                 , &patnew[patnew_offset]);
4535         goto L9900;
4536
4537 /* -------- LIMITATION BY V (WITHOUT COMPRESSION I.E. NCOEFU=NCOFMX) ---
4538 ---- */
4539
4540     } else {
4541         if (*upara1 == 0. && *upara2 == 1.) {
4542             mmarc41_(&numax, &numax, ncoefv, &patold[patold_offset], vpara1,
4543                     vpara2, &patnew[patnew_offset], iercod);
4544         } else {
4545             mmarc41_(&numax, &numax, ncoefv, &patnew[patnew_offset], vpara1,
4546                     vpara2, &patnew[patnew_offset], iercod);
4547         }
4548         goto L9999;
4549     }
4550
4551 /* **********************************************************************
4552 */
4553 /*                             DESALLOCATION */
4554 /* **********************************************************************
4555 */
4556
4557 L9900:
4558     if (iofst != 0) {
4559         AdvApp2Var_SysBase::mcrdelt_(&c__8, &ksize, tbaux, &iofst, &ier);
4560     }
4561     if (ier > 0) {
4562         *iercod = 13;
4563     }
4564
4565 /* ------------------------------ The end -------------------------------
4566 */
4567
4568 L9999:
4569     if (*iercod > 0) {
4570         AdvApp2Var_SysBase::maermsg_("MMFMCAR", iercod, 7L);
4571     }
4572     if (ibb >= 2) {
4573         AdvApp2Var_SysBase::mgsomsg_("MMFMCAR", 7L);
4574     }
4575     return 0;
4576 } /* mmfmcar_ */
4577
4578
4579 //=======================================================================
4580 //function : AdvApp2Var_MathBase::mmfmcb5_
4581 //purpose  :
4582 //=======================================================================
4583 int AdvApp2Var_MathBase::mmfmcb5_(integer *isenmsc,
4584                                   integer *ndimax,
4585                                   integer *ncf1mx,
4586                                   doublereal *courb1,
4587                                   integer *ncoeff,
4588                                   integer *ncf2mx,
4589                                   integer *ndimen,
4590                                   doublereal *courb2,
4591                                   integer *iercod)
4592
4593 {
4594   /* System generated locals */
4595   integer courb1_dim1, courb1_offset, courb2_dim1, courb2_offset, i__1,
4596   i__2;
4597
4598   /* Local variables */
4599   static integer i__, nboct, nd;
4600
4601
4602 /* **********************************************************************
4603 */
4604
4605 /*     FUNCTION : */
4606 /*     ---------- */
4607 /*       Reformating (and  eventual compression/decompression) of curve */
4608 /*       (ndim,.) by (.,ndim) and vice versa. */
4609
4610 /*     KEYWORDS : */
4611 /*     ----------- */
4612 /*      ALL , MATH_ACCES :: */
4613 /*      COURBE&, REORGANISATION,COMPRESSION,INVERSION , &COURBE */
4614
4615 /*     INPUT ARGUMENTS : */
4616 /*     -------------------- */
4617 /*        ISENMSC : required direction of the transfer : */
4618 /*           1   :  passage of (NDIMEN,.) ---> (.,NDIMEN)  direction to AB
4619 */
4620 /*          -1   :  passage of (.,NDIMEN) ---> (NDIMEN,.)  direction to TS,T
4621 V*/
4622 /*        NDIMAX : format / dimension */
4623 /*        NCF1MX : format by t of COURB1 */
4624 /*   if ISENMSC= 1 : COURB1: The curve to be processed (NDIMAX,.) */
4625 /*        NCOEFF : number of coeff of the curve */
4626 /*        NCF2MX : format by t of COURB2 */
4627 /*        NDIMEN : dimension of the curve and format of COURB2 */
4628 /*   if ISENMSC=-1 : COURB2: The curve to be processed (.,NDIMEN) */
4629
4630 /*     OUTPUT ARGUMENTS : */
4631 /*     --------------------- */
4632 /*   if ISENMSC= 1 : COURB2: The resulting curve (.,NDIMEN) */
4633 /*   if ISENMSC=-1 : COURB1: The resulting curve (NDIMAX,.) */
4634
4635 /*     COMMONS USED : */
4636 /*     ------------------ */
4637
4638 /*     REFERENCES CALLED : */
4639 /*     --------------------- */
4640
4641 /*     DESCRIPTION/NOTES/LIMITATIONS : */
4642 /*     ----------------------------------- */
4643 /*     allow to process the usual transfers as follows : */
4644 /*     | ---- ISENMSC = 1 ---- |      | ---- ISENMSC =-1 ----- | */
4645 /*    TS  (3,21) --> (21,3)  AB  ;  AB  (21,3) --> (3,21)  TS */
4646 /*    TS  (3,21) --> (NU,3)  AB  ;  AB  (NU,3) --> (3,21)  TS */
4647 /*        (3,NU) --> (21,3)  AB  ;  AB  (21,3) --> (3,NU) */
4648 /*        (3,NU) --> (NU,3)  AB  ;  AB  (NU,3) --> (3,NU) */
4649 /* > */
4650 /* ***********************************************************************
4651  */
4652
4653
4654     /* Parameter adjustments */
4655     courb1_dim1 = *ndimax;
4656     courb1_offset = courb1_dim1 + 1;
4657     courb1 -= courb1_offset;
4658     courb2_dim1 = *ncf2mx;
4659     courb2_offset = courb2_dim1 + 1;
4660     courb2 -= courb2_offset;
4661
4662     /* Function Body */
4663     if (*ndimen > *ndimax || *ncoeff > *ncf1mx || *ncoeff > *ncf2mx) {
4664         goto L9119;
4665     }
4666
4667     if (*ndimen == 1 && *ncf1mx == *ncf2mx) {
4668         nboct = *ncf2mx << 3;
4669         if (*isenmsc == 1) {
4670             AdvApp2Var_SysBase::mcrfill_((integer *)&nboct,
4671                      (char *)&courb1[courb1_offset],
4672                      (char *)&courb2[courb2_offset]);
4673         }
4674         if (*isenmsc == -1) {
4675             AdvApp2Var_SysBase::mcrfill_((integer *)&nboct,
4676                      (char *)&courb2[courb2_offset],
4677                      (char *)&courb1[courb1_offset]);
4678         }
4679         *iercod = -3136;
4680         goto L9999;
4681     }
4682
4683     *iercod = 0;
4684     if (*isenmsc == 1) {
4685         i__1 = *ndimen;
4686         for (nd = 1; nd <= i__1; ++nd) {
4687             i__2 = *ncoeff;
4688             for (i__ = 1; i__ <= i__2; ++i__) {
4689                 courb2[i__ + nd * courb2_dim1] = courb1[nd + i__ *
4690                         courb1_dim1];
4691 /* L400: */
4692             }
4693 /* L500: */
4694         }
4695     } else if (*isenmsc == -1) {
4696         i__1 = *ndimen;
4697         for (nd = 1; nd <= i__1; ++nd) {
4698             i__2 = *ncoeff;
4699             for (i__ = 1; i__ <= i__2; ++i__) {
4700                 courb1[nd + i__ * courb1_dim1] = courb2[i__ + nd *
4701                         courb2_dim1];
4702 /* L1400: */
4703             }
4704 /* L1500: */
4705         }
4706     } else {
4707         *iercod = 3164;
4708     }
4709
4710     goto L9999;
4711
4712 /* ***********************************************************************
4713  */
4714
4715 L9119:
4716     *iercod = 3119;
4717
4718 L9999:
4719     if (*iercod != 0) {
4720         AdvApp2Var_SysBase::maermsg_("MMFMCB5", iercod, 7L);
4721     }
4722     return 0;
4723 } /* mmfmcb5_ */
4724
4725 //=======================================================================
4726 //function : AdvApp2Var_MathBase::mmfmtb1_
4727 //purpose  :
4728 //=======================================================================
4729 int AdvApp2Var_MathBase::mmfmtb1_(integer *maxsz1,
4730                                   doublereal *table1,
4731                                   integer *isize1,
4732                                   integer *jsize1,
4733                                   integer *maxsz2,
4734                                   doublereal *table2,
4735                                   integer *isize2,
4736                                   integer *jsize2,
4737                                   integer *iercod)
4738 {
4739   static integer c__8 = 8;
4740
4741    /* System generated locals */
4742     integer table1_dim1, table1_offset, table2_dim1, table2_offset, i__1,
4743             i__2;
4744
4745     /* Local variables */
4746     static doublereal work[1];
4747     static integer ilong, isize, ii, jj, ier;
4748     static long int iofst,iipt, jjpt;
4749
4750
4751 /************************************************************************
4752 *******/
4753
4754 /*     FUNCTION : */
4755 /*     ---------- */
4756 /*     Inversion of elements of a rectangular table (T1(i,j) */
4757 /*     loaded in T2(j,i)) */
4758
4759 /*     KEYWORDS : */
4760 /*     ----------- */
4761 /*      ALL, MATH_ACCES :: TABLEAU&, INVERSION, &TABLEAU */
4762
4763 /*     INPUT ARGUMENTS : */
4764 /*     ------------------ */
4765 /*     MAXSZ1: Max Nb of elements by the 1st dimension of TABLE1. */
4766 /*     TABLE1: Table of reals by two dimensions. */
4767 /*     ISIZE1: Nb of useful elements of TABLE1 on the 1st dimension */
4768 /*     JSIZE1: Nb of useful elements of TABLE1 on the 2nd dimension */
4769 /*     MAXSZ2: Nb max of elements by the 1st dimension of TABLE2. */
4770
4771 /*     OUTPUT ARGUMENTS : */
4772 /*     ------------------- */
4773 /*     TABLE2: Table of reals by two dimensions, containing the transposition
4774 /*             of the rectangular table TABLE1. */
4775 /*     ISIZE2: Nb of useful elements of TABLE2 on the 1st dimension */
4776 /*     JSIZE2: Nb of useful elements of TABLE2 on the 2nd dimension */
4777 /*     IERCOD: Erroe coder. */
4778 /*             = 0, ok. */
4779 /*             = 1, error in the dimension of tables */
4780 /*                  ether MAXSZ1 < ISIZE1 (table TABLE1 too small). */
4781 /*                  or MAXSZ2 < JSIZE1 (table TABLE2 too small). */
4782
4783 /*     COMMONS USED   : */
4784 /*     ---------------- */
4785
4786 /*     REFERENCES CALLED   : */
4787 /*     ---------------------- */
4788
4789 /*     DESCRIPTION/NOTES/LIMITATIONS : */
4790 /*     ----------------------------------- */
4791 /*    It is possible to use TABLE1 as input and output table i.e. */
4792 /*    call: */
4793 /*    CALL MMFMTB1(MAXSZ1,TABLE1,ISIZE1,JSIZE1,MAXSZ2,TABLE1 */
4794 /*               ,ISIZE2,JSIZE2,IERCOD) */
4795 /*    is valuable. */
4796 /* > */
4797 /* **********************************************************************
4798 */
4799
4800
4801     /* Parameter adjustments */
4802     table1_dim1 = *maxsz1;
4803     table1_offset = table1_dim1 + 1;
4804     table1 -= table1_offset;
4805     table2_dim1 = *maxsz2;
4806     table2_offset = table2_dim1 + 1;
4807     table2 -= table2_offset;
4808
4809     /* Function Body */
4810     *iercod = 0;
4811     if (*isize1 > *maxsz1 || *jsize1 > *maxsz2) {
4812         goto L9100;
4813     }
4814
4815     iofst = 0;
4816     isize = *maxsz2 * *isize1;
4817     AdvApp2Var_SysBase::mcrrqst_(&c__8, &isize, work, &iofst, &ier);
4818     if (ier > 0) {
4819         goto L9200;
4820     }
4821
4822 /*             DO NOT BE AFRAID OF CRUSHING. */
4823
4824     i__1 = *isize1;
4825     for (ii = 1; ii <= i__1; ++ii) {
4826         iipt = (ii - 1) * *maxsz2 + iofst;
4827         i__2 = *jsize1;
4828         for (jj = 1; jj <= i__2; ++jj) {
4829             jjpt = iipt + (jj - 1);
4830             work[jjpt] = table1[ii + jj * table1_dim1];
4831 /* L200: */
4832         }
4833 /* L100: */
4834     }
4835     ilong = isize << 3;
4836     AdvApp2Var_SysBase::mcrfill_((integer *)&ilong,
4837              (char *)&work[iofst],
4838              (char *)&table2[table2_offset]);
4839
4840 /* -------------- The number of elements of TABLE2 is returned ------------
4841 */
4842
4843     ii = *isize1;
4844     *isize2 = *jsize1;
4845     *jsize2 = ii;
4846
4847     goto L9999;
4848
4849 /* ------------------------------- THE END ------------------------------
4850 */
4851 /* --> Invalid input. */
4852 L9100:
4853     *iercod = 1;
4854     goto L9999;
4855 /* --> Pb of allocation. */
4856 L9200:
4857     *iercod = 2;
4858     goto L9999;
4859
4860 L9999:
4861     if (iofst != 0) {
4862         AdvApp2Var_SysBase::mcrdelt_(&c__8, &isize, work, &iofst, &ier);
4863     }
4864     if (ier > 0) {
4865         *iercod = 2;
4866     }
4867     return 0;
4868 } /* mmfmtb1_ */
4869
4870 //=======================================================================
4871 //function : AdvApp2Var_MathBase::mmgaus1_
4872 //purpose  :
4873 //=======================================================================
4874 int AdvApp2Var_MathBase::mmgaus1_(integer *ndimf,
4875                                   int (*bfunx) (
4876                                                 integer *ninteg,
4877                                                 doublereal *parame,
4878                                                 doublereal *vfunj1,
4879                                                 integer *iercod
4880                                                 ),
4881
4882                                   integer *k,
4883                                   doublereal *xd,
4884                                   doublereal *xf,
4885                                   doublereal *saux1,
4886                                   doublereal *saux2,
4887                                   doublereal *somme,
4888                                   integer *niter,
4889                                   integer *iercod)
4890 {
4891   /* System generated locals */
4892   integer i__1, i__2;
4893
4894   /* Local variables */
4895   static integer ndeg;
4896   static doublereal h__[20];
4897   static integer j;
4898   static doublereal t, u[20], x;
4899   static integer idimf;
4900   static doublereal c1x, c2x;
4901 /* **********************************************************************
4902 */
4903
4904 /*      FUNCTION : */
4905 /*      -------- */
4906
4907 /*      Calculate the integral of  function BFUNX passed in parameter */
4908 /*      between limits XD and XF . */
4909 /*      The function should be calculated for any value */
4910 /*      of the variable in the given interval.. */
4911 /*      The method GAUSS-LEGENDRE is used.
4912 /*      For explications refer to the book : */
4913 /*          Complements de mathematiques a l'usage des Ingenieurs de */
4914 /*          l'electrotechnique et des telecommunications. */
4915 /*          Par Andre ANGOT - Collection technique et scientifique du CNET
4916  */
4917 /*          page 772 .... */
4918 /*      The degree of LEGENDRE polynoms used is passed in parameter.
4919  */
4920 /*      KEYWORDS : */
4921 /*      --------- */
4922 /*         INTEGRATION,LEGENDRE,GAUSS */
4923
4924 /*      INPUT ARGUMENTS : */
4925 /*      ------------------ */
4926
4927 /*      NDIMF : Dimension of the function */
4928 /*      BFUNX : Function to integrate passed as argument */
4929 /*              Should be declared as EXTERNAL in the call routine. */
4930 /*                   SUBROUTINE BFUNX(NDIMF,X,VAL,IER) */
4931 /*                   REAL *8 X,VAL */
4932 /*     K      : Parameter determining the degree of the LEGENDRE polynom that
4933 */
4934 /*               can take a value between 0 and 10. */
4935 /*               The degree of the polynom is equal to 4 k, that is 4, 8,
4936 */
4937 /*               12, 16, 20, 24, 28, 32, 36 and 40. */
4938 /*               If K is not correct, the degree is set to 40 directly.
4939 */
4940 /*      XD     : Lower limit of the interval of integration. */
4941 /*      XF     : Upper limit of the interval of integration. */
4942 /*      SAUX1  : Auxiliary table */
4943 /*      SAUX2  : Auxiliary table */
4944
4945 /*      OUTPUT ARGUMENTS : */
4946 /*      ------------------- */
4947
4948 /*      SOMME : Value of the integral */
4949 /*      NITER : Number of iterations to be carried out. */
4950 /*              It is equal to the degree of the polynom. */
4951
4952 /*      IER   : Error code : */
4953 /*              < 0 ==> Attention - Warning */
4954 /*              = 0 ==> Everything is OK */
4955 /*              > 0 ==> Critical error - Apply special processing */
4956 /*                  ==> Error in the calculation of BFUNX (return code */
4957 /*                      of this routine */
4958
4959 /*              If error => SUM = 0 */
4960
4961 /*      COMMONS USED : */
4962 /*      ----------------- */
4963
4964
4965
4966 /*     REFERENCES CALLED   : */
4967 /*     ---------------------- */
4968
4969 /*     Type  Name */
4970 /*    @      BFUNX               MVGAUS0 */
4971
4972 /*      DESCRIPTION/NOTES/LIMITATIONS : */
4973 /*      --------------------------------- */
4974
4975 /*      See the explanations detailed in the listing */
4976 /*      Use of the GAUSS method (orthogonal polynoms) */
4977 /*      The symmetry of roots of these polynomes is used */
4978 /*      Depending on K, the degree of the interpolated polynom grows.
4979 */
4980 /*      If you wish to calculate the integral with a given precision, */
4981 /*      loop on k varying from 1 to 10 and test the difference of 2
4982 */
4983 /*      consecutive iterations. Stop the loop if this difference is less that
4984 /*      an epsilon value set to 10E-6 for example. */
4985 /*      If S1 and S2 are 2 successive iterations, test following this example :
4986  */
4987
4988 /*            AF=DABS(S1-S2) */
4989 /*            AS=DABS(S2) */
4990 /*            If AS < 1 test if FS < eps otherwise test if AF/AS < eps
4991 */
4992 /*            --        -----                    ----- */
4993 /* > */
4994 /************************************************************************
4995 ******/
4996 /*     DECLARATIONS */
4997 /************************************************************************
4998 ******/
4999
5000
5001
5002 /* ****** General Initialization */
5003
5004     /* Parameter adjustments */
5005     --somme;
5006     --saux2;
5007     --saux1;
5008
5009     /* Function Body */
5010     AdvApp2Var_SysBase::mvriraz_((integer *)ndimf,
5011              (char *)&somme[1]);
5012     *iercod = 0;
5013
5014 /* ****** Loading of coefficients U and H ** */
5015 /* -------------------------------------------- */
5016
5017     mvgaus0_(k, u, h__, &ndeg, iercod);
5018     if (*iercod > 0) {
5019         goto L9999;
5020     }
5021
5022 /* ****** C1X => Medium interval point  [XD,XF] */
5023 /* ****** C2X => 1/2 amplitude interval [XD,XF] */
5024
5025     c1x = (*xf + *xd) * .5;
5026     c2x = (*xf - *xd) * .5;
5027
5028 /* ---------------------------------------- */
5029 /* ****** Integration for degree NDEG ** */
5030 /* ---------------------------------------- */
5031
5032     i__1 = ndeg;
5033     for (j = 1; j <= i__1; ++j) {
5034         t = c2x * u[j - 1];
5035
5036         x = c1x + t;
5037         (*bfunx)(ndimf, &x, &saux1[1], iercod);
5038         if (*iercod != 0) {
5039             goto L9999;
5040         }
5041
5042         x = c1x - t;
5043         (*bfunx)(ndimf, &x, &saux2[1], iercod);
5044         if (*iercod != 0) {
5045             goto L9999;
5046         }
5047
5048         i__2 = *ndimf;
5049         for (idimf = 1; idimf <= i__2; ++idimf) {
5050             somme[idimf] += h__[j - 1] * (saux1[idimf] + saux2[idimf]);
5051         }
5052
5053     }
5054
5055     *niter = ndeg << 1;
5056     i__1 = *ndimf;
5057     for (idimf = 1; idimf <= i__1; ++idimf) {
5058         somme[idimf] *= c2x;
5059     }
5060
5061 /* ****** End of sub-program ** */
5062
5063 L9999:
5064
5065  return 0   ;
5066 } /* mmgaus1_ */
5067 //=======================================================================
5068 //function : mmherm0_
5069 //purpose  :
5070 //=======================================================================
5071 int mmherm0_(doublereal *debfin,
5072              integer *iercod)
5073 {
5074   static integer c__576 = 576;
5075   static integer c__6 = 6;
5076
5077
5078    /* System generated locals */
5079     integer i__1, i__2;
5080     doublereal d__1;
5081
5082     /* Local variables */
5083     static doublereal amat[36]  /* was [6][6] */;
5084     static integer iord[2];
5085     static doublereal prod;
5086     static integer iord1, iord2;
5087     static doublereal miden[36] /* was [6][6] */;
5088     static integer ncmat;
5089     static doublereal epspi, d1, d2;
5090     static integer ii, jj, pp, ncf;
5091     static doublereal cof[6];
5092     static integer iof[2], ier;
5093     static doublereal mat[36]   /* was [6][6] */;
5094     static integer cot;
5095     static doublereal abid[72]  /* was [12][6] */;
5096 /* ***********************************************************************
5097  */
5098
5099 /*     FUNCTION : */
5100 /*     ---------- */
5101 /*      INIT OF COEFFS. OF POLYNOMS OF HERMIT INTERPOLATION */
5102
5103 /*     KEYWORDS : */
5104 /*     ----------- */
5105 /*      MATH_ACCES :: HERMITE */
5106
5107 /*     INPUT ARGUMENTS */
5108 /*     -------------------- */
5109 /*       DEBFIN : PARAMETERS DEFINING THE CONSTRAINTS */
5110 /*                 DEBFIN(1) : FIRST PARAMETER */
5111 /*                 DEBFIN(2) : SECOND PARAMETER */
5112
5113 /*      ONE SHOULD HAVE: */
5114 /*                 ABS (DEBFIN(I)) < 100 */
5115 /*                 and */
5116 /*                 (ABS(DEBFIN(1)+ABS(DEBFIN(2))) > 1/100 */
5117 /*           (for overflows) */
5118
5119 /*      ABS(DEBFIN(2)-DEBFIN(1)) / (ABS(DEBFIN(1)+ABS(DEBFIN(2))) > 1/100
5120 */
5121 /*           (for the conditioning) */
5122
5123
5124 /*     OUTPUT ARGUMENTS : */
5125 /*     --------------------- */
5126
5127 /*       IERCOD : Error code : 0 : O.K. */
5128 /*                                1 : value of DEBFIN */
5129 /*                                are unreasonable */
5130 /*                                -1 : init was already done */
5131 /*                                   (OK but no processing) */
5132
5133 /*     COMMONS USED : */
5134 /*     ------------------ */
5135
5136 /*     REFERENCES CALLED : */
5137 /*     ---------------------- */
5138 /*     Type  Name */
5139
5140 /*     DESCRIPTION/NOTES/LIMITATIONS : */
5141 /*     ----------------------------------- */
5142
5143 /*        This program initializes the coefficients of Hermit polynoms */
5144 /*     that are read later by MMHERM1 */
5145 /* ***********************************************************************
5146  */
5147
5148
5149
5150 /* **********************************************************************
5151 */
5152
5153 /*     FUNCTION : */
5154 /*     ---------- */
5155 /*      Used to STORE  coefficients of Hermit interpolation polynoms
5156
5157 /*     KEYWORDS : */
5158 /*     ----------- */
5159 /*      HERMITE */
5160
5161 /*     DEMSCRIPTION/NOTES/LIMITATIONS : */
5162 /*     ----------------------------------- */
5163
5164 /*     The coefficients of hermit polynoms are calculated by */
5165 /*     the routine MMHERM0 and read by the routine MMHERM1 */
5166 /* > */
5167 /* **********************************************************************
5168 */
5169
5170
5171
5172
5173
5174 /*     NBCOEF is the size of CMHERM (see below) */
5175 /* ***********************************************************************
5176  */
5177
5178
5179
5180
5181
5182
5183
5184 /* ***********************************************************************
5185  */
5186 /*     Data checking */
5187 /* ***********************************************************************
5188  */
5189
5190
5191     /* Parameter adjustments */
5192     --debfin;
5193
5194     /* Function Body */
5195     d1 = abs(debfin[1]);
5196     if (d1 > (float)100.) {
5197         goto L9101;
5198     }
5199
5200     d2 = abs(debfin[2]);
5201     if (d2 > (float)100.) {
5202         goto L9101;
5203     }
5204
5205     d2 = d1 + d2;
5206     if (d2 < (float).01) {
5207         goto L9101;
5208     }
5209
5210     d1 = (d__1 = debfin[2] - debfin[1], abs(d__1));
5211     if (d1 / d2 < (float).01) {
5212         goto L9101;
5213     }
5214
5215
5216 /* ***********************************************************************
5217  */
5218 /*     Initialization */
5219 /* ***********************************************************************
5220  */
5221
5222     *iercod = 0;
5223
5224     epspi = 1e-10;
5225
5226
5227 /* ***********************************************************************
5228  */
5229
5230 /*     IS IT ALREADY INITIALIZED ? */
5231
5232     d1 = abs(debfin[1]) + abs(debfin[2]);
5233     d1 *= 16111959;
5234
5235     if (debfin[1] != mmcmher_.tdebut) {
5236         goto L100;
5237     }
5238     if (debfin[2] != mmcmher_.tfinal) {
5239         goto L100;
5240     }
5241     if (d1 != mmcmher_.verifi) {
5242         goto L100;
5243     }
5244
5245
5246     goto L9001;
5247
5248
5249 /* ***********************************************************************
5250  */
5251 /*     CALCULATION */
5252 /* ***********************************************************************
5253  */
5254
5255
5256 L100:
5257
5258 /*     Init. matrix identity : */
5259
5260     ncmat = 36;
5261     AdvApp2Var_SysBase::mvriraz_((integer *)&ncmat,
5262              (char *)miden);
5263
5264     for (ii = 1; ii <= 6; ++ii) {
5265         miden[ii + ii * 6 - 7] = 1.;
5266 /* L110: */
5267     }
5268
5269
5270
5271 /*     Init to 0 of table CMHERM */
5272
5273     AdvApp2Var_SysBase::mvriraz_((integer *)&c__576, (char *)mmcmher_.cmherm);
5274
5275 /*     Calculation by solution of linear systems */
5276
5277     for (iord1 = -1; iord1 <= 2; ++iord1) {
5278         for (iord2 = -1; iord2 <= 2; ++iord2) {
5279
5280             iord[0] = iord1;
5281             iord[1] = iord2;
5282
5283
5284             iof[0] = 0;
5285             iof[1] = iord[0] + 1;
5286
5287
5288             ncf = iord[0] + iord[1] + 2;
5289
5290 /*        Calculate matrix MAT to invert: */
5291
5292             for (cot = 1; cot <= 2; ++cot) {
5293
5294
5295                 if (iord[cot - 1] > -1) {
5296                     prod = 1.;
5297                     i__1 = ncf;
5298                     for (jj = 1; jj <= i__1; ++jj) {
5299                         cof[jj - 1] = 1.;
5300 /* L200: */
5301                     }
5302                 }
5303
5304                 i__1 = iord[cot - 1] + 1;
5305                 for (pp = 1; pp <= i__1; ++pp) {
5306
5307                     ii = pp + iof[cot - 1];
5308
5309                     prod = 1.;
5310
5311                     i__2 = pp - 1;
5312                     for (jj = 1; jj <= i__2; ++jj) {
5313                         mat[ii + jj * 6 - 7] = (float)0.;
5314 /* L300: */
5315                     }
5316
5317                     i__2 = ncf;
5318                     for (jj = pp; jj <= i__2; ++jj) {
5319
5320 /*        everything is done in these 3 lines
5321  */
5322
5323                         mat[ii + jj * 6 - 7] = cof[jj - 1] * prod;
5324                         cof[jj - 1] *= jj - pp;
5325                         prod *= debfin[cot];
5326
5327 /* L400: */
5328                     }
5329 /* L500: */
5330                 }
5331
5332 /* L1000: */
5333             }
5334
5335 /*     Inversion */
5336
5337             if (ncf >= 1) {
5338                 AdvApp2Var_MathBase::mmmrslwd_(&c__6, &ncf, &ncf, mat, miden, &epspi, abid, amat, &
5339                         ier);
5340                 if (ier > 0) {
5341                     goto L9101;
5342                 }
5343             }
5344
5345             for (cot = 1; cot <= 2; ++cot) {
5346                 i__1 = iord[cot - 1] + 1;
5347                 for (pp = 1; pp <= i__1; ++pp) {
5348                     i__2 = ncf;
5349                     for (ii = 1; ii <= i__2; ++ii) {
5350                         mmcmher_.cmherm[ii + (pp + (cot + ((iord1 + (iord2 <<
5351                                 2)) << 1)) * 3) * 6 + 155] = amat[ii + (pp +
5352                                 iof[cot - 1]) * 6 - 7];
5353 /* L1300: */
5354                     }
5355 /* L1400: */
5356                 }
5357 /* L1500: */
5358             }
5359
5360 /* L2000: */
5361         }
5362 /* L2010: */
5363     }
5364
5365 /* ***********************************************************************
5366  */
5367
5368 /*     The initialized flag is located: */
5369
5370     mmcmher_.tdebut = debfin[1];
5371     mmcmher_.tfinal = debfin[2];
5372
5373     d1 = abs(debfin[1]) + abs(debfin[2]);
5374     mmcmher_.verifi = d1 * 16111959;
5375
5376
5377 /* ***********************************************************************
5378  */
5379
5380     goto L9999;
5381
5382 /* ***********************************************************************
5383  */
5384
5385 L9101:
5386     *iercod = 1;
5387     goto L9999;
5388
5389 L9001:
5390     *iercod = -1;
5391     goto L9999;
5392
5393 /* ***********************************************************************
5394  */
5395
5396 L9999:
5397
5398     AdvApp2Var_SysBase::maermsg_("MMHERM0", iercod, 7L);
5399
5400 /* ***********************************************************************
5401  */
5402  return 0 ;
5403 } /* mmherm0_ */
5404
5405 //=======================================================================
5406 //function : mmherm1_
5407 //purpose  :
5408 //=======================================================================
5409 int mmherm1_(doublereal *debfin,
5410              integer *ordrmx,
5411              integer *iordre,
5412              doublereal *hermit,
5413              integer *iercod)
5414 {
5415   /* System generated locals */
5416   integer hermit_dim1, hermit_dim2, hermit_offset;
5417
5418   /* Local variables */
5419   static integer nbval;
5420   static doublereal d1;
5421   static integer cot;
5422
5423 /* ***********************************************************************
5424  */
5425
5426 /*     FUNCTION : */
5427 /*     ---------- */
5428 /*      reading of coeffs. of HERMIT interpolation polynoms */
5429
5430 /*     KEYWORDS : */
5431 /*     ----------- */
5432 /*      MATH_ACCES :: HERMIT */
5433
5434 /*     INPUT ARGUMENTS : */
5435 /*     -------------------- */
5436 /*       DEBFIN : PARAMETES DEFINING THE CONSTRAINTS */
5437 /*                 DEBFIN(1) : FIRST PARAMETER */
5438 /*                 DEBFIN(2) : SECOND PARAMETER */
5439
5440 /*           Should be equal to the corresponding arguments during the */
5441 /*           last call to MMHERM0 for the initialization of coeffs. */
5442
5443 /*       ORDRMX : indicates the dimensioning of HERMIT: */
5444 /*              there is no choice : ORDRMX should be equal to the value */
5445 /*              of PARAMETER IORDMX of INCLUDE MMCMHER, or 2 for the moment */
5446
5447 /*       IORDRE (2) : Orders of constraints in each corresponding parameter DEBFIN(I)
5448 /*              should be between -1 (no constraints) and ORDRMX. */
5449
5450
5451 /*     OUTPUT ARGUMENTS : */
5452 /*     --------------------- */
5453
5454 /*       HERMIT : HERMIT(1:IORDRE(1)+IORDRE(2)+2, j, cote) are the  */
5455 /*       coefficients in the canonic base of Hermit polynom */
5456 /*       corresponding to orders IORDRE with parameters DEBFIN for */
5457 /*       the constraint of order j on DEBFIN(cote). j is between 0 and IORDRE(cote). */
5458
5459
5460 /*       IERCOD : Error code : */
5461 /*          -1: O.K but necessary to reinitialize the coefficients */
5462 /*                 (info for optimization) */
5463 /*          0 : O.K. */
5464 /*          1 : Error in MMHERM0 */
5465 /*          2 : arguments invalid */
5466
5467 /*     COMMONS USED : */
5468 /*     ------------------ */
5469
5470 /*     REFERENCES CALLED   : */
5471 /*     ---------------------- */
5472 /*     Type  Name */
5473
5474 /*     DESCRIPTION/NOTES/LIMITATIONS : */
5475 /*     ----------------------------------- */
5476
5477 /*     This program reads coefficients of Hermit polynoms */
5478 /*     that were earlier initialized by MMHERM0 */
5479
5480 /* PMN : initialisation is no more done by the caller. */
5481
5482
5483 /* ***********************************************************************
5484  */
5485
5486
5487
5488 /* **********************************************************************
5489 */
5490
5491 /*     FUNCTION : */
5492 /*     ---------- */
5493 /*      Serves to STORE the coefficients of Hermit interpolation polynoms
5494
5495 /*     KEYWORDS : */
5496 /*     ----------- */
5497 /*      HERMITE */
5498
5499 /*     DEMSCRIPTION/NOTES/LIMITATIONS : */
5500 /*     ----------------------------------- */
5501
5502 /*     the coefficients of Hetmit polynoms are calculated by */
5503 /*     routine MMHERM0 and read by routine MMHERM1 */
5504
5505 /* > */
5506 /* **********************************************************************
5507 */
5508
5509
5510
5511
5512
5513 /*     NBCOEF is the size of CMHERM (see lower) */
5514
5515
5516
5517 /* ***********************************************************************
5518  */
5519
5520
5521
5522
5523
5524 /* ***********************************************************************
5525  */
5526 /*     Initializations */
5527 /* ***********************************************************************
5528  */
5529
5530     /* Parameter adjustments */
5531     --debfin;
5532     hermit_dim1 = (*ordrmx << 1) + 2;
5533     hermit_dim2 = *ordrmx + 1;
5534     hermit_offset = hermit_dim1 * hermit_dim2 + 1;
5535     hermit -= hermit_offset;
5536     --iordre;
5537
5538     /* Function Body */
5539     *iercod = 0;
5540
5541
5542 /* ***********************************************************************
5543  */
5544 /*     Data Checking */
5545 /* ***********************************************************************
5546  */
5547
5548
5549     if (*ordrmx != 2) {
5550         goto L9102;
5551     }
5552
5553     for (cot = 1; cot <= 2; ++cot) {
5554         if (iordre[cot] < -1) {
5555             goto L9102;
5556         }
5557         if (iordre[cot] > *ordrmx) {
5558             goto L9102;
5559         }
5560 /* L100: */
5561     }
5562
5563
5564 /*     IS-IT CORRECTLY INITIALIZED ? */
5565
5566     d1 = abs(debfin[1]) + abs(debfin[2]);
5567     d1 *= 16111959;
5568
5569 /*     OTHERWISE IT IS INITIALIZED */
5570
5571     if (debfin[1] != mmcmher_.tdebut || debfin[2] != mmcmher_.tfinal || d1
5572             != mmcmher_.verifi) {
5573         *iercod = -1;
5574         mmherm0_(&debfin[1], iercod);
5575         if (*iercod > 0) {
5576             goto L9101;
5577         }
5578     }
5579
5580
5581 /* ***********************************************************************
5582  */
5583 /*        READING */
5584 /* ***********************************************************************
5585  */
5586
5587     nbval = 36;
5588
5589     AdvApp2Var_SysBase::msrfill_(&nbval, &mmcmher_.cmherm[((((iordre[1] + (iordre[2] << 2)) << 1)
5590             + 1) * 3 + 1) * 6 + 156], &hermit[hermit_offset]);
5591
5592 /* ***********************************************************************
5593  */
5594
5595     goto L9999;
5596
5597 /* ***********************************************************************
5598  */
5599
5600 L9101:
5601     *iercod = 1;
5602     goto L9999;
5603
5604 L9102:
5605     *iercod = 2;
5606     goto L9999;
5607
5608 /* ***********************************************************************
5609  */
5610
5611 L9999:
5612
5613     AdvApp2Var_SysBase::maermsg_("MMHERM1", iercod, 7L);
5614
5615 /* ***********************************************************************
5616  */
5617  return 0 ;
5618 } /* mmherm1_ */
5619
5620 //=======================================================================
5621 //function : AdvApp2Var_MathBase::mmhjcan_
5622 //purpose  :
5623 //=======================================================================
5624 int AdvApp2Var_MathBase::mmhjcan_(integer *ndimen,
5625                             integer *ncourb,
5626                             integer *ncftab,
5627                             integer *orcont,
5628                             integer *ncflim,
5629                             doublereal *tcbold,
5630                             doublereal *tdecop,
5631                             doublereal *tcbnew,
5632                             integer *iercod)
5633
5634 {
5635   static integer c__2 = 2;
5636   static integer c__21 = 21;
5637   /* System generated locals */
5638     integer tcbold_dim1, tcbold_dim2, tcbold_offset, tcbnew_dim1, tcbnew_dim2,
5639              tcbnew_offset, i__1, i__2, i__3, i__4, i__5;
5640
5641
5642     /* Local variables */
5643     static logical ldbg;
5644     static integer ndeg;
5645     static doublereal taux1[21];
5646     static integer d__, e, i__, k;
5647     static doublereal mfact;
5648     static integer ncoeff;
5649     static doublereal tjacap[21];
5650     static integer iordre[2];
5651     static doublereal hermit[36]/* was [6][3][2] */, ctenor, bornes[2];
5652     static integer ier;
5653     static integer aux1, aux2;
5654
5655 /* ***********************************************************************
5656  */
5657
5658 /*     FUNCTION : */
5659 /*     ---------- */
5660 /*       CONVERSION OF TABLE TCBOLD OF POLYNOMIAL CURVE COEFFICIENTS */
5661 /*       EXPRESSED IN HERMIT JACOBI BASE, INTO A */
5662 /*       TABLE OF COEFFICIENTS TCBNEW OF COURVES EXPRESSED IN THE CANONIC BASE */
5663
5664 /*     KEYWORDS : */
5665 /*     ----------- */
5666 /*      CANNONIC, HERMIT, JACCOBI */
5667
5668 /*     INPUT ARGUMENTS : */
5669 /*     -------------------- */
5670 /*       ORDHER : ORDER OF HERMIT POLYNOMS OR ORDER OF CONTINUITY */
5671 /*       NCOEFS : NUMBER OF COEFFICIENTS OF A POLYNOMIAL CURVE */
5672 /*                FOR ONE OF ITS NDIM COMPONENTS;(DEGREE+1 OF THE CURVE)
5673 */
5674 /*       NDIM   : DIMENSION OF THE CURVE */
5675 /*       CBHEJA : TABLE OF COEFFICIENTS OF THE CURVE IN THE BASE */
5676 /*                HERMIT JACOBI */
5677 /*                (H(0,-1),..,H(ORDHER,-1),H(0,1),..,H(ORDHER,1), */
5678 /*                 JA(ORDHER+1,2*ORDHER+2),....,JA(ORDHER+1,NCOEFS-1) */
5679
5680 /*     OUTPUT ARGUMENTS  : */
5681 /*     --------------------- */
5682 /*       CBRCAN : TABLE OF COEFFICIENTS OF THE CURVE IN THE CANONIC BASE */
5683 /*                (1, t, ...) */
5684
5685 /*     COMMONS USED : */
5686 /*     ------------------ */
5687
5688
5689 /*     REFERENCES CALLED : */
5690 /*     --------------------- */
5691
5692
5693 /* ***********************************************************************
5694  */
5695
5696
5697 /* ***********************************************************************
5698  */
5699
5700 /*     FUNCTION : */
5701 /*     ---------- */
5702 /*        Providesinteger constants from 0 to 1000 */
5703
5704 /*     KEYWORDS : */
5705 /*     ----------- */
5706 /*        ALL, INTEGER */
5707
5708 /*     DEMSCRIPTION/NOTES/LIMITATIONS : */
5709 /*     ----------------------------------- */
5710 /* > */
5711 /* ***********************************************************************
5712  */
5713
5714
5715 /* ***********************************************************************
5716  */
5717
5718
5719
5720
5721 /* ***********************************************************************
5722  */
5723 /*                      INITIALIZATION */
5724 /* ***********************************************************************
5725  */
5726
5727     /* Parameter adjustments */
5728     --ncftab;
5729     tcbnew_dim1 = *ndimen;
5730     tcbnew_dim2 = *ncflim;
5731     tcbnew_offset = tcbnew_dim1 * (tcbnew_dim2 + 1) + 1;
5732     tcbnew -= tcbnew_offset;
5733     tcbold_dim1 = *ndimen;
5734     tcbold_dim2 = *ncflim;
5735     tcbold_offset = tcbold_dim1 * (tcbold_dim2 + 1) + 1;
5736     tcbold -= tcbold_offset;
5737
5738     /* Function Body */
5739     ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 2;
5740     if (ldbg) {
5741         AdvApp2Var_SysBase::mgenmsg_("MMHJCAN", 7L);
5742     }
5743     *iercod = 0;
5744
5745     bornes[0] = -1.;
5746     bornes[1] = 1.;
5747
5748 /* ***********************************************************************
5749  */
5750 /*                     PROCESSING */
5751 /* ***********************************************************************
5752  */
5753
5754     if (*orcont > 2) {
5755         goto L9101;
5756     }
5757     if (*ncflim > 21) {
5758         goto L9101;
5759     }
5760
5761 /*     CALCULATION OF HERMIT POLYNOMS IN THE CANONIC BASE ON (-1,1) */
5762
5763
5764     iordre[0] = *orcont;
5765     iordre[1] = *orcont;
5766     mmherm1_(bornes, &c__2, iordre, hermit, &ier);
5767     if (ier > 0) {
5768         goto L9102;
5769     }
5770
5771
5772     aux1 = *orcont + 1;
5773     aux2 = aux1 << 1;
5774
5775     i__1 = *ncourb;
5776     for (e = 1; e <= i__1; ++e) {
5777
5778         ctenor = (tdecop[e] - tdecop[e - 1]) / 2;
5779         ncoeff = ncftab[e];
5780         ndeg = ncoeff - 1;
5781         if (ncoeff > 21) {
5782             goto L9101;
5783         }
5784
5785         i__2 = *ndimen;
5786         for (d__ = 1; d__ <= i__2; ++d__) {
5787
5788 /*     CONVERSION OF THE COEFFICIENTS OF THE PART OF THE CURVE EXPRESSED */
5789 /*     IN HERMIT BASE, INTO THE CANONIC BASE */
5790
5791             AdvApp2Var_SysBase::mvriraz_((integer *)&ncoeff, (char *)taux1);
5792
5793             i__3 = aux2;
5794             for (k = 1; k <= i__3; ++k) {
5795                 i__4 = aux1;
5796                 for (i__ = 1; i__ <= i__4; ++i__) {
5797                     i__5 = i__ - 1;
5798                     mfact = AdvApp2Var_MathBase::pow__di(&ctenor, &i__5);
5799                     taux1[k - 1] += (tcbold[d__ + (i__ + e * tcbold_dim2) *
5800                             tcbold_dim1] * hermit[k + (i__ + 2) * 6 - 19] +
5801                             tcbold[d__ + (i__ + aux1 + e * tcbold_dim2) *
5802                             tcbold_dim1] * hermit[k + (i__ + 5) * 6 - 19]) *
5803                             mfact;
5804                 }
5805             }
5806
5807
5808             i__3 = ncoeff;
5809             for (i__ = aux2 + 1; i__ <= i__3; ++i__) {
5810                 taux1[i__ - 1] = tcbold[d__ + (i__ + e * tcbold_dim2) *
5811                         tcbold_dim1];
5812             }
5813
5814 /*     CONVERSION OF THE COEFFICIENTS OF THE PART OF THE CURVE EXPRESSED */
5815 /*     IN CANONIC-JACOBI BASE, INTO THE CANONIC BASE */
5816
5817
5818
5819             AdvApp2Var_MathBase::mmapcmp_(&minombr_.nbr[1], &c__21, &ncoeff, taux1, tjacap);
5820             AdvApp2Var_MathBase::mmjacan_(orcont, &ndeg, tjacap, taux1);
5821
5822 /*        RECOPY THE COEFS RESULTING FROM THE CONVERSION IN THE TABLE */
5823 /*        OF RESULTS */
5824
5825             i__3 = ncoeff;
5826             for (i__ = 1; i__ <= i__3; ++i__) {
5827                 tcbnew[d__ + (i__ + e * tcbnew_dim2) * tcbnew_dim1] = taux1[
5828                         i__ - 1];
5829             }
5830
5831         }
5832     }
5833
5834     goto L9999;
5835
5836 /* ***********************************************************************
5837  */
5838 /*                   PROCESSING OF ERRORS */
5839 /* ***********************************************************************
5840  */
5841
5842 L9101:
5843     *iercod = 1;
5844     goto L9999;
5845 L9102:
5846     *iercod = 2;
5847     goto L9999;
5848
5849 /* ***********************************************************************
5850  */
5851 /*                   RETURN CALLING PROGRAM */
5852 /* ***********************************************************************
5853  */
5854
5855 L9999:
5856
5857     AdvApp2Var_SysBase::maermsg_("MMHJCAN", iercod, 7L);
5858     if (ldbg) {
5859         AdvApp2Var_SysBase::mgsomsg_("MMHJCAN", 7L);
5860     }
5861  return 0 ;
5862 } /* mmhjcan_ */
5863
5864 //=======================================================================
5865 //function : AdvApp2Var_MathBase::mminltt_
5866 //purpose  :
5867 //=======================================================================
5868  int AdvApp2Var_MathBase::mminltt_(integer *ncolmx,
5869                             integer *nlgnmx,
5870                             doublereal *tabtri,
5871                             integer *nbrcol,
5872                             integer *nbrlgn,
5873                             doublereal *ajoute,
5874                             doublereal *,//epseg,
5875                             integer *iercod)
5876 {
5877   /* System generated locals */
5878   integer tabtri_dim1, tabtri_offset, i__1, i__2;
5879
5880   /* Local variables */
5881   static logical idbg;
5882   static integer icol, ilgn, nlgn, noct, inser;
5883   static doublereal epsega;
5884   static integer ibb;
5885
5886 /* ***********************************************************************
5887  */
5888
5889 /*     FUNCTION : */
5890 /*     ---------- */
5891 /*        . Insert a line in a table parsed without redundance */
5892
5893 /*     KEYWORDS : */
5894 /*     ----------- */
5895 /*      TOUS,MATH_ACCES :: TABLEAU&,INSERTION,&TABLEAU */
5896
5897 /*     INPUT ARGUMENTS : */
5898 /*     -------------------- */
5899 /*        . NCOLMX : Number of columns in the table */
5900 /*        . NLGNMX : Number of lines in the table */
5901 /*        . TABTRI : Table parsed by lines without redundances */
5902 /*        . NBRCOL : Number of columns used */
5903 /*        . NBRLGN : Number of lines used */
5904 /*        . AJOUTE : Line to be added */
5905 /*        . EPSEGA : Epsilon to test the redundance */
5906
5907 /*     OUTPUT ARGUMENTS : */
5908 /*     --------------------- */
5909 /*        . TABTRI : Table parsed by lines without redundances */
5910 /*        . NBRLGN : Number of lines used */
5911 /*        . IERCOD : 0 -> No problem */
5912 /*                   1 -> The table is full */
5913
5914 /*     COMMONS USED : */
5915 /*     ------------------ */
5916
5917 /*     REFERENCES CALLED : */
5918 /*     --------------------- */
5919
5920 /*     DESCRIPTION/NOTES/LIMITATIONS : */
5921 /*     ----------------------------------- */
5922 /*        . The line is inserted only if there is no line with all
5923 */
5924 /*     elements equl to those which are planned to be insered, to epsilon. */
5925
5926 /*        . Level of de debug = 3 */
5927
5928
5929 /*
5930 /*     DECLARATIONS , CONTROL OF INPUT ARGUMENTS , INITIALIZATION */
5931 /* ***********************************************************************
5932  */
5933
5934 /* --- Parameters */
5935
5936
5937 /* --- Functions */
5938
5939
5940 /* --- Local variables */
5941
5942
5943 /* --- Messages */
5944
5945     /* Parameter adjustments */
5946     tabtri_dim1 = *ncolmx;
5947     tabtri_offset = tabtri_dim1 + 1;
5948     tabtri -= tabtri_offset;
5949     --ajoute;
5950
5951     /* Function Body */
5952     ibb = AdvApp2Var_SysBase::mnfndeb_();
5953     idbg = ibb >= 3;
5954     if (idbg) {
5955         AdvApp2Var_SysBase::mgenmsg_("MMINLTT", 7L);
5956     }
5957
5958 /* --- Control arguments */
5959
5960     if (*nbrlgn >= *nlgnmx) {
5961         goto L9001;
5962     }
5963
5964 /* -------------------- */
5965 /* *** INITIALIZATION */
5966 /* -------------------- */
5967
5968     *iercod = 0;
5969
5970 /* ---------------------------- */
5971 /* *** SEARCH OF REDUNDANCE */
5972 /* ---------------------------- */
5973
5974     i__1 = *nbrlgn;
5975     for (ilgn = 1; ilgn <= i__1; ++ilgn) {
5976         if (tabtri[ilgn * tabtri_dim1 + 1] >= ajoute[1] - epsega) {
5977             if (tabtri[ilgn * tabtri_dim1 + 1] <= ajoute[1] + epsega) {
5978                 i__2 = *nbrcol;
5979                 for (icol = 1; icol <= i__2; ++icol) {
5980                     if (tabtri[icol + ilgn * tabtri_dim1] < ajoute[icol] -
5981                             epsega || tabtri[icol + ilgn * tabtri_dim1] >
5982                             ajoute[icol] + epsega) {
5983                         goto L20;
5984                     }
5985 /* L10: */
5986                 }
5987                 goto L9999;
5988             } else {
5989                 goto L30;
5990             }
5991         }
5992 L20:
5993         ;
5994     }
5995
5996 /* ----------------------------------- */
5997 /* *** SEARCH OF THE INSERTION POINT */
5998 /* ----------------------------------- */
5999
6000 L30:
6001
6002     i__1 = *nbrlgn;
6003     for (ilgn = 1; ilgn <= i__1; ++ilgn) {
6004         i__2 = *nbrcol;
6005         for (icol = 1; icol <= i__2; ++icol) {
6006             if (tabtri[icol + ilgn * tabtri_dim1] < ajoute[icol]) {
6007                 goto L50;
6008             }
6009             if (tabtri[icol + ilgn * tabtri_dim1] > ajoute[icol]) {
6010                 goto L70;
6011             }
6012 /* L60: */
6013         }
6014 L50:
6015         ;
6016     }
6017
6018     ilgn = *nbrlgn + 1;
6019
6020 /* -------------- */
6021 /* *** INSERTION */
6022 /* -------------- */
6023
6024 L70:
6025
6026     inser = ilgn;
6027     ++(*nbrlgn);
6028
6029 /* --- Shift lower */
6030
6031     nlgn = *nbrlgn - inser;
6032     if (nlgn > 0) {
6033         noct = (*ncolmx << 3) * nlgn;
6034         AdvApp2Var_SysBase::mcrfill_((integer *)&noct,
6035                  (char *)&tabtri[inser * tabtri_dim1 + 1],
6036                  (char *)&tabtri[(inser + 1)* tabtri_dim1 + 1]);
6037     }
6038
6039 /* --- Copy line */
6040
6041     noct = *nbrcol << 3;
6042     AdvApp2Var_SysBase::mcrfill_((integer *)&noct,
6043              (char *)&ajoute[1],
6044              (char *)&tabtri[inser * tabtri_dim1 + 1]);
6045
6046     goto L9999;
6047
6048 /* ******************************************************************** */
6049 /*       OUTPUT ERROR , RETURN CALLING PROGRAM , MESSAGES */
6050 /* ******************************************************************** */
6051
6052 /* --- The table is already full */
6053
6054 L9001:
6055     *iercod = 1;
6056
6057 /* --- End */
6058
6059 L9999:
6060     if (*iercod != 0) {
6061         AdvApp2Var_SysBase::maermsg_("MMINLTT", iercod, 7L);
6062     }
6063     if (idbg) {
6064         AdvApp2Var_SysBase::mgsomsg_("MMINLTT", 7L);
6065     }
6066  return 0 ;
6067 } /* mminltt_ */
6068
6069 //=======================================================================
6070 //function : AdvApp2Var_MathBase::mmjacan_
6071 //purpose  :
6072 //=======================================================================
6073  int AdvApp2Var_MathBase::mmjacan_(integer *ideriv,
6074                             integer *ndeg,
6075                             doublereal *poljac,
6076                             doublereal *polcan)
6077 {
6078     /* System generated locals */
6079   integer poljac_dim1, i__1, i__2;
6080
6081   /* Local variables */
6082   static integer iptt, i__, j, ibb;
6083   static doublereal bid;
6084
6085 /* ***********************************************************************
6086  */
6087
6088 /*     FUNCTION : */
6089 /*     ---------- */
6090 /*     Routine of transfer of Jacobi normalized to canonic [-1,1], */
6091 /*     the tables are ranked by even, then by uneven degree. */
6092
6093 /*     KEYWORDS : */
6094 /*     ----------- */
6095 /*        LEGENDRE,JACOBI,PASSAGE. */
6096
6097 /*     INPUT ARGUMENTS  : */
6098 /*     ------------------ */
6099 /*        IDERIV : Order of Jacobi between -1 and 2. */
6100 /*        NDEG :   The true degree of the polynom. */
6101 /*        POLJAC : The polynom in the Jacobi base. */
6102
6103 /*     OUTPUT ARGUMENTS : */
6104 /*     ------------------- */
6105 /*        POLCAN : The curve expressed in the canonic base [-1,1]. */
6106
6107 /*     COMMONS USED   : */
6108 /*     ---------------- */
6109
6110 /*     REFERENCES CALLED   : */
6111 /*     ----------------------- */
6112
6113 /*     DESCRIPTION/NOTES/LIMITATIONS : */
6114 /*     ----------------------------------- */
6115
6116 /* > */
6117 /* ***********************************************************************
6118  */
6119
6120 /*   Name of the routine */
6121
6122 /*   Matrices of conversion */
6123
6124
6125 /* ***********************************************************************
6126  */
6127
6128 /*     FUNCTION : */
6129 /*     ---------- */
6130 /*        MATRIX OF TRANSFORMATION OF LEGENDRE BASE */
6131
6132 /*     KEYWORDS : */
6133 /*     ----------- */
6134 /*        MATH */
6135
6136 /*     DEMSCRIPTION/NOTES/LIMITATIONS : */
6137 /*     ----------------------------------- */
6138
6139 /* > */
6140 /* ***********************************************************************
6141  */
6142
6143
6144
6145 /*  Legendre common / Restricted Casteljau. */
6146
6147 /*   0:1      0 Concerns the even terms, 1 the uneven terms. */
6148 /*   CANPLG : Matrix of passage to canonic from Jacobi with calculated parities */
6149 /*   PLGCAN : Matrix of passage from Jacobi to canonic with calculated parities */
6150
6151
6152 /* ***********************************************************************
6153  */
6154
6155     /* Parameter adjustments */
6156     poljac_dim1 = *ndeg / 2 + 1;
6157
6158     /* Function Body */
6159     ibb = AdvApp2Var_SysBase::mnfndeb_();
6160     if (ibb >= 5) {
6161         AdvApp2Var_SysBase::mgenmsg_("MMJACAN", 7L);
6162     }
6163
6164 /* ----------------- Expression of terms of even degree ----------------
6165 */
6166
6167     i__1 = *ndeg / 2;
6168     for (i__ = 0; i__ <= i__1; ++i__) {
6169         bid = 0.;
6170         iptt = i__ * 31 - (i__ + 1) * i__ / 2 + 1;
6171         i__2 = *ndeg / 2;
6172         for (j = i__; j <= i__2; ++j) {
6173             bid += mmjcobi_.plgcan[iptt + j + *ideriv * 992 + 991] * poljac[
6174                     j];
6175 /* L310: */
6176         }
6177         polcan[i__ * 2] = bid;
6178 /* L300: */
6179     }
6180
6181 /* --------------- Expression of terms of uneven degree ----------------
6182 */
6183
6184     if (*ndeg == 0) {
6185         goto L9999;
6186     }
6187
6188     i__1 = (*ndeg - 1) / 2;
6189     for (i__ = 0; i__ <= i__1; ++i__) {
6190         bid = 0.;
6191         iptt = i__ * 31 - (i__ + 1) * i__ / 2 + 1;
6192         i__2 = (*ndeg - 1) / 2;
6193         for (j = i__; j <= i__2; ++j) {
6194             bid += mmjcobi_.plgcan[iptt + j + ((*ideriv << 1) + 1) * 496 +
6195                     991] * poljac[j + poljac_dim1];
6196 /* L410: */
6197         }
6198         polcan[(i__ << 1) + 1] = bid;
6199 /* L400: */
6200     }
6201
6202 /* -------------------------------- The end -----------------------------
6203 */
6204
6205 L9999:
6206     if (ibb >= 5) {
6207         AdvApp2Var_SysBase::mgsomsg_("MMJACAN", 7L);
6208     }
6209     return 0;
6210 } /* mmjacan_ */
6211
6212 //=======================================================================
6213 //function : AdvApp2Var_MathBase::mmjaccv_
6214 //purpose  :
6215 //=======================================================================
6216  int AdvApp2Var_MathBase::mmjaccv_(integer *ncoef,
6217                             integer *ndim,
6218                             integer *ider,
6219                             doublereal *crvlgd,
6220                             doublereal *polaux,
6221                             doublereal *crvcan)
6222
6223 {
6224   /* Initialized data */
6225
6226   static char nomprg[8+1] = "MMJACCV ";
6227
6228   /* System generated locals */
6229   integer crvlgd_dim1, crvlgd_offset, crvcan_dim1, crvcan_offset,
6230   polaux_dim1, i__1, i__2;
6231
6232   /* Local variables */
6233   static integer ndeg, i__, nd, ii, ibb;
6234
6235 /* ***********************************************************************
6236  */
6237
6238 /*     FUNCTION : */
6239 /*     ---------- */
6240 /*        Passage from the normalized Jacobi base to the canonic base. */
6241
6242 /*     KEYWORDS : */
6243 /*     ----------- */
6244 /*        SMOOTHING, BASE, LEGENDRE */
6245
6246
6247 /*     INPUT ARGUMENTS : */
6248 /*     ------------------ */
6249 /*        NDIM: Space Dimension. */
6250 /*        NCOEF: Degree +1 of the polynom. */
6251 /*        IDER: Order of Jacobi polynoms. */
6252 /*        CRVLGD : Curve in the base of Jacobi. */
6253
6254 /*     OUTPUT ARGUMENTS : */
6255 /*     ------------------- */
6256 /*        POLAUX : Auxilliary space. */
6257 /*        CRVCAN : The curve in the canonic base [-1,1] */
6258
6259 /*     COMMONS USED   : */
6260 /*     ---------------- */
6261
6262 /*     REFERENCES CALLED   : */
6263 /*     ----------------------- */
6264
6265 /*     DESCRIPTION/NOTES/LIMITATIONS : */
6266 /*     ----------------------------------- */
6267
6268 /* > */
6269 /* *********************************************************************
6270 */
6271
6272 /*   Name of the routine */
6273     /* Parameter adjustments */
6274     polaux_dim1 = (*ncoef - 1) / 2 + 1;
6275     crvcan_dim1 = *ncoef - 1 + 1;
6276     crvcan_offset = crvcan_dim1;
6277     crvcan -= crvcan_offset;
6278     crvlgd_dim1 = *ncoef - 1 + 1;
6279     crvlgd_offset = crvlgd_dim1;
6280     crvlgd -= crvlgd_offset;
6281
6282     /* Function Body */
6283
6284     ibb = AdvApp2Var_SysBase::mnfndeb_();
6285     if (ibb >= 3) {
6286         AdvApp2Var_SysBase::mgenmsg_(nomprg, 6L);
6287     }
6288
6289     ndeg = *ncoef - 1;
6290
6291     i__1 = *ndim;
6292     for (nd = 1; nd <= i__1; ++nd) {
6293 /*  Loading of the auxilliary table. */
6294         ii = 0;
6295         i__2 = ndeg / 2;
6296         for (i__ = 0; i__ <= i__2; ++i__) {
6297             polaux[i__] = crvlgd[ii + nd * crvlgd_dim1];
6298             ii += 2;
6299 /* L310: */
6300         }
6301
6302         ii = 1;
6303         if (ndeg >= 1) {
6304             i__2 = (ndeg - 1) / 2;
6305             for (i__ = 0; i__ <= i__2; ++i__) {
6306                 polaux[i__ + polaux_dim1] = crvlgd[ii + nd * crvlgd_dim1];
6307                 ii += 2;
6308 /* L320: */
6309             }
6310         }
6311 /*   Call the routine of base change. */
6312         AdvApp2Var_MathBase::mmjacan_(ider, &ndeg, polaux, &crvcan[nd * crvcan_dim1]);
6313 /* L300: */
6314     }
6315
6316
6317 /* L9999: */
6318     return 0;
6319 } /* mmjaccv_ */
6320
6321 //=======================================================================
6322 //function : mmloncv_
6323 //purpose  :
6324 //=======================================================================
6325 int mmloncv_(integer *ndimax,
6326              integer *ndimen,
6327              integer *ncoeff,
6328              doublereal *courbe,
6329              doublereal *tdebut,
6330              doublereal *tfinal,
6331              doublereal *xlongc,
6332              integer *iercod)
6333
6334 {
6335   /* Initialized data */
6336
6337   static integer kgar = 0;
6338
6339   /* System generated locals */
6340   integer courbe_dim1, courbe_offset, i__1, i__2;
6341
6342   /* Local variables */
6343   static doublereal tran;
6344   static integer ngaus;
6345   static doublereal c1, c2, d1, d2, wgaus[20], uroot[20], x1, x2, dd;
6346   static integer ii, jj, kk;
6347   static doublereal som;
6348   static doublereal der1, der2;
6349
6350
6351
6352
6353 /* **********************************************************************
6354 */
6355
6356 /*     FUNCTION : Length of an arc of curve on a given interval */
6357 /*     ---------- for a function the mathematic representation  */
6358 /*                which of is a multidimensional polynom. */
6359 /*      The polynom is a set of polynoms the coefficients which of are ranked
6360         /*  in a table with 2 indices, each line relative to 1 polynom. */
6361 /*      The polynom is defined by its coefficients ordered by increasing
6362 *       power of the variable. */
6363 /*      All polynoms have the same number of coefficients (and the same degree). */
6364
6365 /*     KEYWORDS : LENGTH, CURVE */
6366 /*     ----------- */
6367
6368 /*     INPUT ARGUMENTS : */
6369 /*     -------------------- */
6370
6371 /*      NDIMAX : Max number of lines of tables (max number of polynoms). */
6372 /*      NDIMEN : Dimension of the polynom (Nomber of polynoms). */
6373 /*      NCOEFF : Number of coefficients of the polynom (no limitation) */
6374 /*               This is degree + 1 */
6375 /*      COURBE : Coefficients of the polynom ordered by increasing power */
6376 /*               Dimension to (NDIMAX,NCOEFF). */
6377 /*      TDEBUT : Lower limit of integration for length calculation. */
6378 /*      TFINAL : Upper limit of integration for length calculation.  */
6379
6380 /*     OUTPUT ARGUMENTS : */
6381 /*     --------------------- */
6382 /*      XLONGC : Length of arc of curve */
6383
6384 /*      IERCOD : Error code : */
6385 /*             = 0 ==> All is OK */
6386 /*             = 1 ==> NDIMEN or NCOEFF negative or null */
6387 /*             = 2 ==> Pb loading Legendre roots and Gauss weight */
6388 /*                     by MVGAUS0. */
6389
6390 /*     If error => XLONGC = 0 */
6391
6392 /*     COMMONS USED : */
6393 /*     ------------------ */
6394
6395 /*      .Neant. */
6396
6397 /*     REFERENCES CALLED   : */
6398 /*     ---------------------- */
6399 /*     Type  Name */
6400 /*           MAERMSG         R*8  DSQRT          I*4  MIN */
6401 /*           MVGAUS0 */
6402
6403 /*     DESCRIPTION/NOTES/LIMITATIONS : */
6404 /*     ----------------------------------- */
6405
6406 /*      See VGAUSS to understand well the technique. */
6407 /*      Actually SQRT (dpi^2) is integrated for i=1,nbdime */
6408 /*      Calculation of the derivative is included in the code to avoid an additional */
6409 /*      call of the routine. */
6410
6411 /*      The integrated function is strictly increasing, it */
6412 /*      is not necessary to use a high degree for the GAUSS method GAUSS. */
6413
6414 /*      The degree of LEGENDRE polynom results from the degree of the */
6415 /*      polynom to be integrated. It can vary from 4 to 40 (with step of 4). */
6416
6417 /*      The precision (relative) of integration is of order 1.D-8. */
6418
6419 /*      ATTENTION : if TDEBUT > TFINAL, the length is NEGATIVE. */
6420
6421 /*      Attention : the precision of the result is not controlled. */
6422 /*      If you wish to control it, use  MMCGLC1, taking into account that  */
6423 /*      the performance (in time) will be worse. */
6424
6425 /* >=====================================================================
6426 */
6427
6428 /*      ATTENTION : SAVE KGAR WGAUS and UROOT EVENTUALLY */
6429 /*     ,IERXV */
6430 /*      INTEGER I1,I20 */
6431 /*      PARAMETER (I1=1,I20=20) */
6432
6433     /* Parameter adjustments */
6434     courbe_dim1 = *ndimax;
6435     courbe_offset = courbe_dim1 + 1;
6436     courbe -= courbe_offset;
6437
6438     /* Function Body */
6439
6440 /* ****** General initialization ** */
6441
6442     *iercod = 999999;
6443     *xlongc = 0.;
6444
6445 /* ****** Initialization of UROOT, WGAUS, NGAUS and KGAR ** */
6446
6447 /*      CALL MXVINIT(IERXV,'INTEGER',I1,KGAR,'INTEGER',I1,NGAUS */
6448 /*     1    ,'DOUBLE PRECISION',I20,UROOT,'DOUBLE PRECISION',I20,WGAUS) */
6449 /*      IF (IERXV.GT.0) KGAR=0 */
6450
6451 /* ****** Test the equity of limits ** */
6452
6453     if (*tdebut == *tfinal) {
6454         *iercod = 0;
6455         goto L9900;
6456     }
6457
6458 /* ****** Test the dimension and the number of coefficients ** */
6459
6460     if (*ndimen <= 0 || *ncoeff <= 0) {
6461         *iercod = 1;
6462         goto L9900;
6463     }
6464
6465 /* ****** Calculate the optimal degree ** */
6466
6467     kk = *ncoeff / 4 + 1;
6468     kk = min(kk,10);
6469
6470 /* ****** Return the coefficients for the integral (DEGRE=4*KK) */
6471 /*       if KK <> KGAR. */
6472
6473     if (kk != kgar) {
6474         mvgaus0_(&kk, uroot, wgaus, &ngaus, iercod);
6475         if (*iercod > 0) {
6476             kgar = 0;
6477             *iercod = 2;
6478             goto L9900;
6479         }
6480         kgar = kk;
6481     }
6482
6483 /*      C1 => Point medium interval */
6484 /*      C2 => 1/2 amplitude interval */
6485
6486     c1 = (*tfinal + *tdebut) * .5;
6487     c2 = (*tfinal - *tdebut) * .5;
6488
6489 /* ----------------------------------------------------------- */
6490 /* ****** Integration - Loop on GAUSS intervals ** */
6491 /* ----------------------------------------------------------- */
6492
6493     som = 0.;
6494
6495     i__1 = ngaus;
6496     for (jj = 1; jj <= i__1; ++jj) {
6497
6498 /* ****** Integration taking the symmetry into account ** */
6499
6500         tran = c2 * uroot[jj - 1];
6501         x1 = c1 + tran;
6502         x2 = c1 - tran;
6503
6504 /* ****** Derivation on the dimension of the space ** */
6505
6506         der1 = 0.;
6507         der2 = 0.;
6508         i__2 = *ndimen;
6509         for (kk = 1; kk <= i__2; ++kk) {
6510             d1 = (*ncoeff - 1) * courbe[kk + *ncoeff * courbe_dim1];
6511             d2 = d1;
6512             for (ii = *ncoeff - 1; ii >= 2; --ii) {
6513                 dd = (ii - 1) * courbe[kk + ii * courbe_dim1];
6514                 d1 = d1 * x1 + dd;
6515                 d2 = d2 * x2 + dd;
6516 /* L100: */
6517             }
6518             der1 += d1 * d1;
6519             der2 += d2 * d2;
6520 /* L200: */
6521         }
6522
6523 /* ****** Integration ** */
6524
6525         som += wgaus[jj - 1] * c2 * (sqrt(der1) + sqrt(der2));
6526
6527 /* ****** End of loop on GAUSS intervals ** */
6528
6529 /* L300: */
6530     }
6531
6532 /* ****** Work ended ** */
6533
6534     *xlongc = som;
6535
6536 /* ****** It is forced IERCOD  =  0 ** */
6537
6538     *iercod = 0;
6539
6540 /* ****** Final processing ** */
6541
6542 L9900:
6543
6544 /* ****** Save UROOT, WGAUS, NGAUS and KGAR ** */
6545
6546 /*      CALL MXVSAVE(IERXV,'INTEGER',I1,KGAR,'INTEGER',I1,NGAUS */
6547 /*     1    ,'DOUBLE PRECISION',I20,UROOT,'DOUBLE PRECISION',I20,WGAUS) */
6548 /*      IF (IERXV.GT.0) KGAR=0 */
6549
6550 /* ****** End of sub-program ** */
6551
6552     if (*iercod != 0) {
6553         AdvApp2Var_SysBase::maermsg_("MMLONCV", iercod, 7L);
6554     }
6555  return 0 ;
6556 } /* mmloncv_ */
6557
6558 //=======================================================================
6559 //function : AdvApp2Var_MathBase::mmpobas_
6560 //purpose  :
6561 //=======================================================================
6562  int AdvApp2Var_MathBase::mmpobas_(doublereal *tparam,
6563                             integer *iordre,
6564                             integer *ncoeff,
6565                             integer *nderiv,
6566                             doublereal *valbas,
6567                             integer *iercod)
6568
6569 {
6570   static integer c__2 = 2;
6571   static integer c__1 = 1;
6572
6573
6574    /* Initialized data */
6575
6576     static doublereal moin11[2] = { -1.,1. };
6577
6578     /* System generated locals */
6579     integer valbas_dim1, i__1;
6580
6581     /* Local variables */
6582     static doublereal vjac[80], herm[24];
6583     static integer iord[2];
6584     static doublereal wval[4];
6585     static integer nwcof, iunit;
6586     static doublereal wpoly[7];
6587     static integer ii, jj, iorjac;
6588     static doublereal hermit[36]        /* was [6][3][2] */;
6589     static integer kk1, kk2, kk3;
6590     static integer khe, ier;
6591
6592
6593 /* ***********************************************************************
6594  */
6595
6596 /*     FUNCTION : */
6597 /*     ---------- */
6598 /*       Position on the polynoms of base hermit-Jacobi */
6599 /*       and their succesive derivatives */
6600
6601 /*     KEYWORDS : */
6602 /*     ----------- */
6603 /*      PUBLIC, POSITION, HERMIT, JACOBI */
6604
6605 /*     INPUT ARGUMENTS : */
6606 /*     -------------------- */
6607 /*       TPARAM : Parameter for which the position is found. */
6608 /*       IORDRE : Orderof hermit-Jacobi (-1,0,1, ou 2) */
6609 /*       NCOEFF : Number of coefficients of polynoms (Nb of value to calculate) */
6610 /*       NDERIV : Number of derivative to calculate (0<= N <=3) */
6611 /*              0 -> Position simple on base functions */
6612 /*              N -> Position on base functions and derivative */
6613 /*              of order 1 to N */
6614
6615 /*     OUTPUT ARGUMENTS : */
6616 /*     --------------------- */
6617 /*     VALBAS (NCOEFF, 0:NDERIV) : calculated value */
6618 /*           i */
6619 /*          d    vj(t)  = VALBAS(J, I) */
6620 /*          -- i */
6621 /*          dt */
6622
6623 /*    IERCOD : Error code */
6624 /*      0 : Ok */
6625 /*      1 : Incoherence of input arguments */
6626
6627 /*     COMMONS USED : */
6628 /*     -------------- */
6629
6630
6631 /*     REFERENCES CALLED : */
6632 /*     ------------------- */
6633
6634
6635 /*     DESCRIPTION/NOTES/LIMITATIONS : */
6636 /*     ----------------------------------- */
6637
6638 /* > */
6639 /* ***********************************************************************
6640  */
6641 /*                            DECLARATIONS */
6642 /* ***********************************************************************
6643  */
6644
6645
6646
6647     /* Parameter adjustments */
6648     valbas_dim1 = *ncoeff;
6649     --valbas;
6650
6651     /* Function Body */
6652
6653 /* ***********************************************************************
6654  */
6655 /*                      INITIALIZATIONS */
6656 /* ***********************************************************************
6657  */
6658
6659     *iercod = 0;
6660
6661 /* ***********************************************************************
6662  */
6663 /*                     PROCESSING */
6664 /* ***********************************************************************
6665  */
6666
6667     if (*nderiv > 3) {
6668         goto L9101;
6669     }
6670     if (*ncoeff > 20) {
6671         goto L9101;
6672     }
6673     if (*iordre > 2) {
6674         goto L9101;
6675     }
6676
6677     iord[0] = *iordre;
6678     iord[1] = *iordre;
6679     iorjac = (*iordre + 1) << 1;
6680
6681 /*  (1) Generic Calculations .... */
6682
6683 /*  (1.a) Calculation of hermit polynoms */
6684
6685     if (*iordre >= 0) {
6686         mmherm1_(moin11, &c__2, iord, hermit, &ier);
6687         if (ier > 0) {
6688             goto L9102;
6689         }
6690     }
6691
6692 /*  (1.b) Evaluation of hermit polynoms */
6693
6694     jj = 1;
6695     iunit = *nderiv + 1;
6696     khe = (*iordre + 1) * iunit;
6697
6698     if (*nderiv > 0) {
6699
6700         i__1 = *iordre;
6701         for (ii = 0; ii <= i__1; ++ii) {
6702             mmdrvcb_(nderiv, &c__1, &iorjac, &hermit[(ii + 3) * 6 - 18],
6703                     tparam, &herm[jj - 1], &ier);
6704             if (ier > 0) {
6705                 goto L9102;
6706             }
6707
6708             mmdrvcb_(nderiv, &c__1, &iorjac, &hermit[(ii + 6) * 6 - 18],
6709                     tparam, &herm[jj + khe - 1], &ier);
6710             if (ier > 0) {
6711                 goto L9102;
6712             }
6713             jj += iunit;
6714         }
6715
6716     } else {
6717
6718         i__1 = *iordre;
6719         for (ii = 0; ii <= i__1; ++ii) {
6720             AdvApp2Var_MathBase::mmpocrb_(&c__1, &iorjac, &hermit[(ii + 3) * 6 - 18], &c__1,
6721                     tparam, &herm[jj - 1]);
6722
6723             AdvApp2Var_MathBase::mmpocrb_(&c__1, &iorjac, &hermit[(ii + 6) * 6 - 18], &c__1,
6724                     tparam, &herm[jj + khe - 1]);
6725             jj += iunit;
6726         }
6727     }
6728
6729 /*  (1.c) Evaluation of Jacobi polynoms */
6730
6731     ii = *ncoeff - iorjac;
6732
6733     mmpojac_(tparam, &iorjac, &ii, nderiv, vjac, &ier);
6734     if (ier > 0) {
6735         goto L9102;
6736     }
6737
6738 /*  (1.d) Evaluation of W(t) */
6739
6740 /* Computing MAX */
6741     i__1 = iorjac + 1;
6742     nwcof = max(i__1,1);
6743     AdvApp2Var_SysBase::mvriraz_((integer *)&nwcof,
6744              (char *)wpoly);
6745     wpoly[0] = 1.;
6746     if (*iordre == 2) {
6747         wpoly[2] = -3.;
6748         wpoly[4] = 3.;
6749         wpoly[6] = -1.;
6750     } else if (*iordre == 1) {
6751         wpoly[2] = -2.;
6752         wpoly[4] = 1.;
6753     } else if (*iordre == 0) {
6754         wpoly[2] = -1.;
6755     }
6756
6757     mmdrvcb_(nderiv, &c__1, &nwcof, wpoly, tparam, wval, &ier);
6758     if (ier > 0) {
6759         goto L9102;
6760     }
6761
6762     kk1 = *ncoeff - iorjac;
6763     kk2 = kk1 << 1;
6764     kk3 = kk1 * 3;
6765
6766 /*  (2) Evaluation of order 0 */
6767
6768     jj = 1;
6769     i__1 = iorjac;
6770     for (ii = 1; ii <= i__1; ++ii) {
6771         valbas[ii] = herm[jj - 1];
6772         jj += iunit;
6773     }
6774
6775     i__1 = kk1;
6776     for (ii = 1; ii <= i__1; ++ii) {
6777         valbas[ii + iorjac] = wval[0] * vjac[ii - 1];
6778     }
6779
6780 /*  (3) Evaluation of order 1 */
6781
6782     if (*nderiv >= 1) {
6783         jj = 2;
6784         i__1 = iorjac;
6785         for (ii = 1; ii <= i__1; ++ii) {
6786             valbas[ii + valbas_dim1] = herm[jj - 1];
6787             jj += iunit;
6788         }
6789
6790
6791         i__1 = kk1;
6792         for (ii = 1; ii <= i__1; ++ii) {
6793             valbas[ii + iorjac + valbas_dim1] = wval[0] * vjac[ii + kk1 - 1]
6794                     + wval[1] * vjac[ii - 1];
6795         }
6796     }
6797
6798 /*  (4)  Evaluation of order 2 */
6799
6800     if (*nderiv >= 2) {
6801         jj = 3;
6802         i__1 = iorjac;
6803         for (ii = 1; ii <= i__1; ++ii) {
6804             valbas[ii + (valbas_dim1 << 1)] = herm[jj - 1];
6805             jj += iunit;
6806         }
6807
6808         i__1 = kk1;
6809         for (ii = 1; ii <= i__1; ++ii) {
6810             valbas[ii + iorjac + (valbas_dim1 << 1)] = wval[0] * vjac[ii +
6811                     kk2 - 1] + wval[1] * 2 * vjac[ii + kk1 - 1] + wval[2] *
6812                     vjac[ii - 1];
6813         }
6814     }
6815
6816 /*  (5) Evaluation of order 3 */
6817
6818     if (*nderiv >= 3) {
6819         jj = 4;
6820         i__1 = iorjac;
6821         for (ii = 1; ii <= i__1; ++ii) {
6822             valbas[ii + valbas_dim1 * 3] = herm[jj - 1];
6823             jj += iunit;
6824         }
6825
6826         i__1 = kk1;
6827         for (ii = 1; ii <= i__1; ++ii) {
6828             valbas[ii + iorjac + valbas_dim1 * 3] = wval[0] * vjac[ii + kk3 -
6829                     1] + wval[1] * 3 * vjac[ii + kk2 - 1] + wval[2] * 3 *
6830                     vjac[ii + kk1 - 1] + wval[3] * vjac[ii - 1];
6831         }
6832     }
6833
6834     goto L9999;
6835
6836 /* ***********************************************************************
6837  */
6838 /*                   ERROR PROCESSING */
6839 /* ***********************************************************************
6840  */
6841
6842 L9101:
6843     *iercod = 1;
6844     goto L9999;
6845
6846 L9102:
6847     *iercod = 2;
6848
6849 /* ***********************************************************************
6850  */
6851 /*                   RETURN CALLING PROGRAM */
6852 /* ***********************************************************************
6853  */
6854
6855 L9999:
6856
6857     if (*iercod > 0) {
6858         AdvApp2Var_SysBase::maermsg_("MMPOBAS", iercod, 7L);
6859     }
6860  return 0 ;
6861 } /* mmpobas_ */
6862
6863 //=======================================================================
6864 //function : AdvApp2Var_MathBase::mmpocrb_
6865 //purpose  :
6866 //=======================================================================
6867  int AdvApp2Var_MathBase::mmpocrb_(integer *ndimax,
6868                             integer *ncoeff,
6869                             doublereal *courbe,
6870                             integer *ndim,
6871                             doublereal *tparam,
6872                             doublereal *pntcrb)
6873
6874 {
6875   /* System generated locals */
6876   integer courbe_dim1, courbe_offset, i__1, i__2;
6877
6878   /* Local variables */
6879   static integer ncof2;
6880   static integer isize, nd, kcf, ncf;
6881
6882
6883 /* ***********************************************************************
6884  */
6885
6886 /*     FUNCTION : */
6887 /*     ---------- */
6888 /*        CALCULATE THE COORDINATES OF A POINT OF A CURVE OF GIVEN PARAMETER */
6889 /*        TPARAM ( IN 2D, 3D OR MORE) */
6890
6891 /*     KEYWORDS : */
6892 /*     ----------- */
6893 /*       TOUS , MATH_ACCES :: COURBE&,PARAMETRE& , POSITIONNEMENT , &POINT
6894  */
6895
6896 /*     INPUT ARGUMENTS  : */
6897 /*     ------------------ */
6898 /*        NDIMAX : format / dimension of the curve */
6899 /*        NCOEFF : Nb of coefficients of the curve */
6900 /*        COURBE : Matrix of coefficients of the curve */
6901 /*        NDIM   : Dimension useful of the workspace  */
6902 /*        TPARAM : Value of the parameter where the point is calculated */
6903
6904 /*     OUTPUT ARGUMENTS : */
6905 /*     ------------------- */
6906 /*        PNTCRB : Coordinates of the calculated point */
6907
6908 /*     COMMONS USED   : */
6909 /*     ---------------- */
6910
6911 /*      .Neant. */
6912
6913 /*     REFERENCES CALLED   : */
6914 /*     ---------------------- */
6915 /*     Type  Name */
6916 /*           MIRAZ                MVPSCR2              MVPSCR3 */
6917
6918 /*     DESCRIPTION/NOTES/LIMITATIONS : */
6919 /*     ----------------------------------- */
6920
6921 /* > */
6922 /* ***********************************************************************
6923  */
6924
6925
6926 /* ***********************************************************************
6927  */
6928
6929     /* Parameter adjustments */
6930     courbe_dim1 = *ndimax;
6931     courbe_offset = courbe_dim1 + 1;
6932     courbe -= courbe_offset;
6933     --pntcrb;
6934
6935     /* Function Body */
6936     isize = *ndim << 3;
6937     AdvApp2Var_SysBase::miraz_((integer *)&isize,
6938            (char *)&pntcrb[1]);
6939
6940     if (*ncoeff <= 0) {
6941         goto L9999;
6942     }
6943
6944 /*   optimal processing 3d */
6945
6946     if (*ndim == 3 && *ndimax == 3) {
6947         mvpscr3_(ncoeff, &courbe[courbe_offset], tparam, &pntcrb[1]);
6948
6949 /*   optimal processing 2d */
6950
6951     } else if (*ndim == 2 && *ndimax == 2) {
6952         mvpscr2_(ncoeff, &courbe[courbe_offset], tparam, &pntcrb[1]);
6953
6954 /*   Any dimension - scheme of HORNER */
6955
6956     } else if (*tparam == 0.) {
6957         i__1 = *ndim;
6958         for (nd = 1; nd <= i__1; ++nd) {
6959             pntcrb[nd] = courbe[nd + courbe_dim1];
6960 /* L100: */
6961         }
6962     } else if (*tparam == 1.) {
6963         i__1 = *ncoeff;
6964         for (ncf = 1; ncf <= i__1; ++ncf) {
6965             i__2 = *ndim;
6966             for (nd = 1; nd <= i__2; ++nd) {
6967                 pntcrb[nd] += courbe[nd + ncf * courbe_dim1];
6968 /* L300: */
6969             }
6970 /* L200: */
6971         }
6972     } else {
6973         ncof2 = *ncoeff + 2;
6974         i__1 = *ndim;
6975         for (nd = 1; nd <= i__1; ++nd) {
6976             i__2 = *ncoeff;
6977             for (ncf = 2; ncf <= i__2; ++ncf) {
6978                 kcf = ncof2 - ncf;
6979                 pntcrb[nd] = (pntcrb[nd] + courbe[nd + kcf * courbe_dim1]) * *
6980                         tparam;
6981 /* L500: */
6982             }
6983             pntcrb[nd] += courbe[nd + courbe_dim1];
6984 /* L400: */
6985         }
6986     }
6987
6988 L9999:
6989  return 0   ;
6990 } /* mmpocrb_ */
6991
6992 //=======================================================================
6993 //function : AdvApp2Var_MathBase::mmmpocur_
6994 //purpose  :
6995 //=======================================================================
6996  int AdvApp2Var_MathBase::mmmpocur_(integer *ncofmx,
6997                              integer *ndim,
6998                              integer *ndeg,
6999                              doublereal *courbe,
7000                              doublereal *tparam,
7001                              doublereal *tabval)
7002
7003 {
7004   /* System generated locals */
7005   integer courbe_dim1, courbe_offset, i__1;
7006
7007   /* Local variables */
7008   static integer i__, nd;
7009   static doublereal fu;
7010
7011
7012 /* ***********************************************************************
7013  */
7014
7015 /*     FUNCTION : */
7016 /*     ---------- */
7017 /*        Position of a point on curve (ncofmx,ndim). */
7018
7019 /*     KEYWORDS : */
7020 /*     ----------- */
7021 /*        TOUS , AB_SPECIFI :: COURBE&,POLYNOME&,POSITIONNEMENT,&POINT */
7022
7023 /*     INPUT ARGUMENTS  : */
7024 /*     ------------------ */
7025 /*        NCOFMX: Format / degree of the CURVE. */
7026 /*        NDIM  : Dimension of the space. */
7027 /*        NDEG  : Degree of the polynom. */
7028 /*        COURBE: Coefficients of the curve. */
7029 /*        TPARAM: Parameter on the curve */
7030
7031 /*     OUTPUT ARGUMENTS  : */
7032 /*     ------------------- */
7033 /*        TABVAL(NDIM): The resulting point (or table of values) */
7034
7035 /*     COMMONS USED   : */
7036 /*     ---------------- */
7037
7038 /*     REFERENCES CALLED : */
7039 /*     ----------------------- */
7040
7041 /*     DESCRIPTION/NOTES/LIMITATIONS : */
7042 /*     ----------------------------------- */
7043
7044 /* > */
7045 /* ***********************************************************************
7046  */
7047
7048     /* Parameter adjustments */
7049     --tabval;
7050     courbe_dim1 = *ncofmx;
7051     courbe_offset = courbe_dim1 + 1;
7052     courbe -= courbe_offset;
7053
7054     /* Function Body */
7055     if (*ndeg < 1) {
7056         i__1 = *ndim;
7057         for (nd = 1; nd <= i__1; ++nd) {
7058             tabval[nd] = 0.;
7059 /* L290: */
7060         }
7061     } else {
7062         i__1 = *ndim;
7063         for (nd = 1; nd <= i__1; ++nd) {
7064             fu = courbe[*ndeg + nd * courbe_dim1];
7065             for (i__ = *ndeg - 1; i__ >= 1; --i__) {
7066                 fu = fu * *tparam + courbe[i__ + nd * courbe_dim1];
7067 /* L120: */
7068             }
7069             tabval[nd] = fu;
7070 /* L300: */
7071         }
7072     }
7073  return 0 ;
7074 } /* mmmpocur_ */
7075
7076 //=======================================================================
7077 //function : mmpojac_
7078 //purpose  :
7079 //=======================================================================
7080 int mmpojac_(doublereal *tparam,
7081              integer *iordre,
7082              integer *ncoeff,
7083              integer *nderiv,
7084              doublereal *valjac,
7085              integer *iercod)
7086
7087 {
7088   static integer c__2 = 2;
7089
7090     /* Initialized data */
7091
7092     static integer nbcof = -1;
7093
7094     /* System generated locals */
7095     integer valjac_dim1, i__1, i__2;
7096
7097     /* Local variables */
7098     static doublereal cofa, cofb, denom, tnorm[100];
7099     static integer ii, jj, kk1, kk2;
7100     static doublereal aux1, aux2;
7101
7102
7103 /* ***********************************************************************
7104  */
7105
7106 /*     FUNCTION : */
7107 /*     ---------- */
7108 /*       Positioning on Jacobi polynoms and their derivatives */
7109 /*       successive by a recurrent algorithm */
7110
7111 /*     KEYWORDS : */
7112 /*     ----------- */
7113 /*      RESERVE, POSITIONING, JACOBI */
7114
7115 /*     INPUT ARGUMENTS : */
7116 /*     -------------------- */
7117 /*       TPARAM : Parameter for which positioning is done. */
7118 /*       IORDRE : Order of hermit-?? (-1,0,1, or 2) */
7119 /*       NCOEFF : Number of coeeficients of polynoms (Nb of value to */
7120 /*                calculate) */
7121 /*       NDERIV : Number of derivative to calculate (0<= N <=3) */
7122 /*              0 -> Position simple on jacobi functions */
7123 /*              N -> Position on jacobi functions and their */
7124 /*              derivatives of order 1 to N. */
7125
7126 /*     OUTPUT ARGUMENTS : */
7127 /*     --------------------- */
7128 /*     VALJAC (NCOEFF, 0:NDERIV) : the calculated values */
7129 /*           i */
7130 /*          d    vj(t)  = VALJAC(J, I) */
7131 /*          -- i */
7132 /*          dt */
7133
7134 /*    IERCOD : Error Code */
7135 /*      0 : Ok */
7136 /*      1 : Incoherence of input arguments */
7137
7138 /*     COMMONS USED : */
7139 /*     ------------------ */
7140
7141
7142 /*     REFERENCES CALLED : */
7143 /*     --------------------- */
7144
7145
7146 /*     DESCRIPTION/NOTES/LIMITATIONS : */
7147 /*     ----------------------------------- */
7148
7149 /* > */
7150 /* ***********************************************************************
7151  */
7152 /*                            DECLARATIONS */
7153 /* ***********************************************************************
7154  */
7155
7156
7157 /*     static varaibles */
7158
7159
7160
7161     /* Parameter adjustments */
7162     valjac_dim1 = *ncoeff;
7163     --valjac;
7164
7165     /* Function Body */
7166
7167 /* ***********************************************************************
7168  */
7169 /*                      INITIALISATIONS */
7170 /* ***********************************************************************
7171  */
7172
7173     *iercod = 0;
7174
7175 /* ***********************************************************************
7176  */
7177 /*                     Processing */
7178 /* ***********************************************************************
7179  */
7180
7181     if (*nderiv > 3) {
7182         goto L9101;
7183     }
7184     if (*ncoeff > 100) {
7185         goto L9101;
7186     }
7187
7188 /*  --- Calculation of norms */
7189
7190 /*      IF (NCOEFF.GT.NBCOF) THEN */
7191     i__1 = *ncoeff;
7192     for (ii = 1; ii <= i__1; ++ii) {
7193         kk1 = ii - 1;
7194         aux2 = 1.;
7195         i__2 = *iordre;
7196         for (jj = 1; jj <= i__2; ++jj) {
7197             aux2 = aux2 * (doublereal) (kk1 + *iordre + jj) / (doublereal) (
7198                     kk1 + jj);
7199         }
7200         i__2 = (*iordre << 1) + 1;
7201         tnorm[ii - 1] = sqrt(aux2 * (kk1 * 2. + (*iordre << 1) + 1) / pow__ii(&
7202                 c__2, &i__2));
7203     }
7204
7205     nbcof = *ncoeff;
7206
7207 /*      END IF */
7208
7209 /*  --- Trivial Positions ----- */
7210
7211     valjac[1] = 1.;
7212     aux1 = (doublereal) (*iordre + 1);
7213     valjac[2] = aux1 * *tparam;
7214
7215     if (*nderiv >= 1) {
7216         valjac[valjac_dim1 + 1] = 0.;
7217         valjac[valjac_dim1 + 2] = aux1;
7218
7219         if (*nderiv >= 2) {
7220             valjac[(valjac_dim1 << 1) + 1] = 0.;
7221             valjac[(valjac_dim1 << 1) + 2] = 0.;
7222
7223             if (*nderiv >= 3) {
7224                 valjac[valjac_dim1 * 3 + 1] = 0.;
7225                 valjac[valjac_dim1 * 3 + 2] = 0.;
7226             }
7227         }
7228     }
7229
7230 /*  --- Positioning by recurrence */
7231
7232     i__1 = *ncoeff;
7233     for (ii = 3; ii <= i__1; ++ii) {
7234
7235         kk1 = ii - 1;
7236         kk2 = ii - 2;
7237         aux1 = (doublereal) (*iordre + kk2);
7238         aux2 = aux1 * 2;
7239         cofa = aux2 * (aux2 + 1) * (aux2 + 2);
7240         cofb = (aux2 + 2) * -2. * aux1 * aux1;
7241         denom = kk1 * 2. * (kk2 + (*iordre << 1) + 1) * aux2;
7242         denom = 1. / denom;
7243
7244 /*        --> Pi(t) */
7245         valjac[ii] = (cofa * *tparam * valjac[kk1] + cofb * valjac[kk2]) *
7246                 denom;
7247 /*        --> P'i(t) */
7248         if (*nderiv >= 1) {
7249             valjac[ii + valjac_dim1] = (cofa * *tparam * valjac[kk1 +
7250                     valjac_dim1] + cofa * valjac[kk1] + cofb * valjac[kk2 +
7251                     valjac_dim1]) * denom;
7252 /*        --> P''i(t) */
7253             if (*nderiv >= 2) {
7254                 valjac[ii + (valjac_dim1 << 1)] = (cofa * *tparam * valjac[
7255                         kk1 + (valjac_dim1 << 1)] + cofa * 2 * valjac[kk1 +
7256                         valjac_dim1] + cofb * valjac[kk2 + (valjac_dim1 << 1)]
7257                         ) * denom;
7258             }
7259 /*        --> P'i(t) */
7260             if (*nderiv >= 3) {
7261                 valjac[ii + valjac_dim1 * 3] = (cofa * *tparam * valjac[kk1 +
7262                         valjac_dim1 * 3] + cofa * 3 * valjac[kk1 + (
7263                         valjac_dim1 << 1)] + cofb * valjac[kk2 + valjac_dim1 *
7264                          3]) * denom;
7265             }
7266         }
7267     }
7268
7269 /*    ---> Normalization */
7270
7271     i__1 = *ncoeff;
7272     for (ii = 1; ii <= i__1; ++ii) {
7273         i__2 = *nderiv;
7274         for (jj = 0; jj <= i__2; ++jj) {
7275             valjac[ii + jj * valjac_dim1] = tnorm[ii - 1] * valjac[ii + jj *
7276                     valjac_dim1];
7277         }
7278     }
7279
7280     goto L9999;
7281
7282 /* ***********************************************************************
7283  */
7284 /*                   PROCESSING OF ERRORS */
7285 /* ***********************************************************************
7286  */
7287
7288 L9101:
7289     *iercod = 1;
7290     goto L9999;
7291
7292
7293 /* ***********************************************************************
7294  */
7295 /*                   RETURN CALLING PROGRAM */
7296 /* ***********************************************************************
7297  */
7298
7299 L9999:
7300
7301     if (*iercod > 0) {
7302         AdvApp2Var_SysBase::maermsg_("MMPOJAC", iercod, 7L);
7303     }
7304  return 0 ;
7305 } /* mmpojac_ */
7306
7307 //=======================================================================
7308 //function : AdvApp2Var_MathBase::mmposui_
7309 //purpose  :
7310 //=======================================================================
7311  int AdvApp2Var_MathBase::mmposui_(integer *dimmat,
7312                             integer *,//nistoc,
7313                             integer *aposit,
7314                             integer *posuiv,
7315                             integer *iercod)
7316
7317 {
7318   /* System generated locals */
7319   integer i__1, i__2;
7320
7321   /* Local variables */
7322   static logical ldbg;
7323   static integer imin, jmin, i__, j, k;
7324   static logical trouve;
7325
7326 /* ***********************************************************************
7327  */
7328
7329 /*     FUNCTION : */
7330 /*     ---------- */
7331 /*       FILL THE TABLE OF POSITIONING POSUIV WHICH ALLOWS TO */
7332 /*       PARSE BY COLUMN THE INFERIOR TRIANGULAR PART OF THE */
7333 /*       MATRIX  IN FORM OF PROFILE */
7334
7335
7336 /*     KEYWORDS : */
7337 /*     ----------- */
7338 /*      RESERVE, MATRIX, PROFILE */
7339
7340 /*     INPUT ARGUMENTS : */
7341 /*     -------------------- */
7342
7343 /*       NISTOC: NUMBER OF COEFFICIENTS IN THE PROFILE */
7344 /*       DIMMAT: NUMBER OF LINE OF THE SYMMETRIC SQUARE MATRIX */
7345 /*       APOSIT: TABLE OF POSITIONING OF STORAGE TERMS */
7346 /*               APOSIT(1,I) CONTAINS THE NUMBER OF TERMES-1 ON LINE
7347 /*               I IN THE PROFILE OF THE MATRIX */
7348 /*               APOSIT(2,I) CONTAINS THE INDEX OF STORAGE OF DIAGONAL TERM
7349 /*               OF LINE I */
7350
7351
7352 /*     OUTPUT ARGUMENTS : */
7353 /*     --------------------- */
7354 /*       POSUIV: POSUIV(K) (WHERE K IS THE INDEX OF STORAGE OF MAT(I,J)) */
7355 /*               CONTAINS THE SMALLEST NUMBER IMIN>I OF THE  LINE THAT */
7356 /*               POSSESSES A TERM MAT(IMIN,J) THAT IS IN THE PROFILE. */
7357 /*               IF THERE IS NO TERM MAT(IMIN,J) IN THE PROFILE THEN POSUIV(K)=-1 */
7358
7359
7360 /*     COMMONS USED : */
7361 /*     ------------------ */
7362
7363
7364 /*     REFERENCES CALLED : */
7365 /*     --------------------- */
7366
7367
7368 /*     DESCRIPTION/NOTES/LIMITATIONS : */
7369 /*     ----------------------------------- */
7370
7371
7372 /* ***********************************************************************
7373  */
7374 /*                            DECLARATIONS */
7375 /* ***********************************************************************
7376  */
7377
7378
7379
7380 /* ***********************************************************************
7381  */
7382 /*                      INITIALIZATIONS */
7383 /* ***********************************************************************
7384  */
7385
7386     /* Parameter adjustments */
7387     aposit -= 3;
7388     --posuiv;
7389
7390     /* Function Body */
7391     ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 2;
7392     if (ldbg) {
7393         AdvApp2Var_SysBase::mgenmsg_("MMPOSUI", 7L);
7394     }
7395     *iercod = 0;
7396
7397
7398 /* ***********************************************************************
7399  */
7400 /*                     PROCESSING */
7401 /* ***********************************************************************
7402  */
7403
7404
7405
7406     i__1 = *dimmat;
7407     for (i__ = 1; i__ <= i__1; ++i__) {
7408         jmin = i__ - aposit[(i__ << 1) + 1];
7409         i__2 = i__;
7410         for (j = jmin; j <= i__2; ++j) {
7411             imin = i__ + 1;
7412             trouve = FALSE_;
7413             while(! trouve && imin <= *dimmat) {
7414                 if (imin - aposit[(imin << 1) + 1] <= j) {
7415                     trouve = TRUE_;
7416                 } else {
7417                     ++imin;
7418                 }
7419             }
7420             k = aposit[(i__ << 1) + 2] - i__ + j;
7421             if (trouve) {
7422                 posuiv[k] = imin;
7423             } else {
7424                 posuiv[k] = -1;
7425             }
7426         }
7427     }
7428
7429
7430
7431
7432
7433     goto L9999;
7434
7435 /* ***********************************************************************
7436  */
7437 /*                   ERROR PROCESSING */
7438 /* ***********************************************************************
7439  */
7440
7441
7442
7443
7444 /* ***********************************************************************
7445  */
7446 /*                   RETURN CALLING PROGRAM */
7447 /* ***********************************************************************
7448  */
7449
7450 L9999:
7451
7452 /* ___ DESALLOCATION, ... */
7453
7454     AdvApp2Var_SysBase::maermsg_("MMPOSUI", iercod, 7L);
7455     if (ldbg) {
7456         AdvApp2Var_SysBase::mgsomsg_("MMPOSUI", 7L);
7457     }
7458  return 0 ;
7459 } /* mmposui_ */
7460
7461 //=======================================================================
7462 //function : AdvApp2Var_MathBase::mmresol_
7463 //purpose  :
7464 //=======================================================================
7465  int AdvApp2Var_MathBase::mmresol_(integer *hdimen,
7466                             integer *gdimen,
7467                             integer *hnstoc,
7468                             integer *gnstoc,
7469                             integer *mnstoc,
7470                             doublereal *matsyh,
7471                             doublereal *matsyg,
7472                             doublereal *vecsyh,
7473                             doublereal *vecsyg,
7474                             integer *hposit,
7475                             integer *hposui,
7476                             integer *gposit,
7477                             integer *mmposui,
7478                             integer *mposit,
7479                             doublereal *vecsol,
7480                             integer *iercod)
7481
7482 {
7483   static integer c__100 = 100;
7484
7485    /* System generated locals */
7486     integer i__1, i__2;
7487
7488     /* Local variables */
7489     static logical ldbg;
7490     static doublereal mcho[100];
7491     static integer jmin, jmax, i__, j, k, l;
7492     static long int iofv1, iofv2, iofv3, iofv4;
7493     static doublereal v1[100], v2[100], v3[100], v4[100];
7494     static integer deblig, dimhch;
7495     static doublereal hchole[100];
7496     static long int iofmch, iofmam, iofhch;
7497     static doublereal matsym[100];
7498     static integer ier;
7499     static integer aux;
7500
7501
7502
7503 /* ***********************************************************************
7504  */
7505
7506 /*     FUNCTION : */
7507 /*     ---------- */
7508 /*       SOLUTION OF THE SYSTEM */
7509 /*       H  t(G)   V     B */
7510 /*                    = */
7511 /*       G    0    L     C */
7512
7513 /*     KEYWORDS : */
7514 /*     ----------- */
7515 /*      RESERVE, SOLUTION, SYSTEM, LAGRANGIAN */
7516
7517 /*     INPUT ARGUMENTS : */
7518 /*     -------------------- */
7519 /*      HDIMEN: NOMBER OF LINE (OR COLUMN) OF THE HESSIAN MATRIX */
7520 /*      GDIMEN: NOMBER OF LINE OF THE MATRIX OF CONSTRAINTS */
7521 /*      HNSTOC: NOMBErS OF TERMS IN THE PROFILE OF HESSIAN MATRIX
7522 */
7523 /*      GNSTOC: NOMBERS OF TERMS IN THE PROFILE OF THE MATRIX OF CONSTRAINTS */
7524 /*      MNSTOC: NOMBERS OF TERMS IN THE PROFILE OF THE MATRIX M= G H t(G) */
7525 /*              where H IS THE HESSIAN MATRIX AND G IS THE MATRIX OF CONSTRAINTS */
7526 /*      MATSYH: TRIANGULAR INFERIOR PART OF THE HESSIAN MATRIX
7527 /*              IN FORM OF PROFILE */
7528 /*      MATSYG: MATRIX OF CONSTRAINTS IN FORM OF PROFILE */
7529 /*      VECSYH: VECTOR OF THE SECOND MEMBER ASSOCIATED TO MATSYH */
7530 /*      VECSYG: VECTOR OF THE SECOND MEMBER ASSOCIATED TO MATSYG */
7531 /*      HPOSIT: TABLE OF POSITIONING OF THE HESSIAN MATRIX */
7532 /*              HPOSIT(1,I) CONTAINS THE NUMBER OF TERMS -1 */
7533 /*              WHICH ARE IN THE PROFILE AT LINE I */
7534 /*              HPOSIT(2,I) CONTAINS THE INDEX OF STORAGE OF TERM */
7535 /*              DIAGONAL OF THE MATRIX AT LINE I */
7536 /*      HPOSUI: TABLE ALLOWING TO PARSE THE HESSIAN MATRIX BY COLUMN */
7537 /*              IN FORM OF PROFILE */
7538 /*             HPOSUI(K) CONTAINS THE NUMBER OF LINE IMIN FOLLOWING THE CURRENT LINE*/
7539 /*              I WHERE H(I,J)=MATSYH(K) AS IT EXISTS IN THE */
7540 /*              SAME COLUMN J A TERM IN THE PROFILE OF LINE IMIN */
7541 /*              IF SUCH TERM DOES NOT EXIST IMIN=-1 */
7542 /*      GPOSIT: TABLE OF POSITIONING OF THE MATRIX OF CONSTRAINTS */
7543 /*              GPOSIT(1,I) CONTAINS THE NUMBER OF TERMS OF LINE I */
7544 /*                          WHICH ARE IN THE PROFILE */
7545 /*              GPOSIT(2,I) CONTAINS THE INDEX OF STORAGE OF THE LAST TERM
7546 /*                          OF LINE I WHICH IS IN THE PROFILE */
7547 /*              GPOSIT(3,I) CONTAINS THE NUMBER OF COLUMN CORRESPONDING */
7548 /*                          TO THE FIRST TERM OF LINE I WHICH IS IN THE PROFILE */
7549 /*      MMPOSUI, MPOSIT: SAME STRUCTURE AS HPOSUI, BUT FOR MATRIX
7550 /*              M=G H t(G) */
7551
7552
7553 /*     OUTPUT ARGUMENTS : */
7554 /*     --------------------- */
7555 /*       VECSOL: VECTOR SOLUTION V OF THE SYSTEM */
7556 /*       IERCOD: ERROR CODE */
7557
7558 /*     COMMONS USED : */
7559 /*     ------------------ */
7560
7561
7562 /*     REFERENCES CALLED : */
7563 /*     --------------------- */
7564
7565
7566 /*     DESCRIPTION/NOTES/LIMITATIONS : */
7567 /*     ----------------------------------- */
7568 /* > */
7569 /* ***********************************************************************
7570  */
7571 /*                            DECLARATIONS */
7572 /* ***********************************************************************
7573  */
7574
7575 /* ***********************************************************************
7576  */
7577 /*                      INITIALISATIONS */
7578 /* ***********************************************************************
7579  */
7580
7581     /* Parameter adjustments */
7582     --vecsol;
7583     hposit -= 3;
7584     --vecsyh;
7585     --hposui;
7586     --matsyh;
7587     --matsyg;
7588     --vecsyg;
7589     gposit -= 4;
7590     --mmposui;
7591     mposit -= 3;
7592
7593     /* Function Body */
7594     ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 2;
7595     if (ldbg) {
7596         AdvApp2Var_SysBase::mgenmsg_("MMRESOL", 7L);
7597     }
7598     *iercod = 0;
7599     iofhch = 0;
7600     iofv1 = 0;
7601     iofv2 = 0;
7602     iofv3 = 0;
7603     iofv4 = 0;
7604     iofmam = 0;
7605     iofmch = 0;
7606
7607 /* ***********************************************************************
7608  */
7609 /*                     PROCESSING */
7610 /* ***********************************************************************
7611  */
7612
7613 /*    Dynamic allocation */
7614
7615     AdvApp2Var_SysBase::macrar8_(hdimen, &c__100, v1, &iofv1, &ier);
7616     if (ier > 0) {
7617         goto L9102;
7618     }
7619     dimhch = hposit[(*hdimen << 1) + 2];
7620     AdvApp2Var_SysBase::macrar8_(&dimhch, &c__100, hchole, &iofhch, &ier);
7621     if (ier > 0) {
7622         goto L9102;
7623     }
7624
7625 /*   solution of system 1     H V1 = b */
7626 /*   where H=MATSYH  and b=VECSYH */
7627
7628     mmchole_(hnstoc, hdimen, &matsyh[1], &hposit[3], &hposui[1], &hchole[
7629             iofhch], &ier);
7630     if (ier > 0) {
7631         goto L9101;
7632     }
7633     mmrslss_(hnstoc, hdimen, &hchole[iofhch], &hposit[3], &hposui[1], &vecsyh[
7634             1], &v1[iofv1], &ier);
7635     if (ier > 0) {
7636         goto L9102;
7637     }
7638
7639 /*    Case when there are constraints */
7640
7641     if (*gdimen > 0) {
7642
7643 /*    Calculate the vector of the second member V2=G H(-1) b -c = G v1-c */
7644 /*    of system of unknown Lagrangian vector MULTIP */
7645 /*    where G=MATSYG */
7646 /*          c=VECSYG */
7647
7648         AdvApp2Var_SysBase::macrar8_(gdimen, &c__100, v2, &iofv2, &ier);
7649         if (ier > 0) {
7650             goto L9102;
7651         }
7652         AdvApp2Var_SysBase::macrar8_(hdimen, &c__100, v3, &iofv3, &ier);
7653         if (ier > 0) {
7654             goto L9102;
7655         }
7656         AdvApp2Var_SysBase::macrar8_(gdimen, &c__100, v4, &iofv4, &ier);
7657         if (ier > 0) {
7658             goto L9102;
7659         }
7660         AdvApp2Var_SysBase::macrar8_(mnstoc, &c__100, matsym, &iofmam, &ier);
7661         if (ier > 0) {
7662             goto L9102;
7663         }
7664
7665         deblig = 1;
7666         mmatvec_(gdimen, hdimen, &gposit[4], gnstoc, &matsyg[1], &v1[iofv1], &
7667                 deblig, &v2[iofv2], &ier);
7668         if (ier > 0) {
7669             goto L9101;
7670         }
7671         i__1 = *gdimen;
7672         for (i__ = 1; i__ <= i__1; ++i__) {
7673             v2[i__ + iofv2 - 1] -= vecsyg[i__];
7674         }
7675
7676 /*     Calculate the matrix M= G H(-1) t(G) */
7677 /*     RESOL DU SYST 2 : H qi = gi */
7678 /*            where is a vector column of t(G) */
7679 /*                qi=v3 */
7680 /*            then calculate G qi */
7681 /*            then construct M in form of profile */
7682
7683
7684
7685         i__1 = *gdimen;
7686         for (i__ = 1; i__ <= i__1; ++i__) {
7687             AdvApp2Var_SysBase::mvriraz_((integer *)hdimen, (char *)&v1[iofv1]);
7688             AdvApp2Var_SysBase::mvriraz_((integer *)hdimen, (char *)&v3[iofv3]);
7689             AdvApp2Var_SysBase::mvriraz_((integer *)gdimen, (char *)&v4[iofv4]);
7690             jmin = gposit[i__ * 3 + 3];
7691             jmax = gposit[i__ * 3 + 1] + gposit[i__ * 3 + 3] - 1;
7692             aux = gposit[i__ * 3 + 2] - gposit[i__ * 3 + 1] - jmin + 1;
7693             i__2 = jmax;
7694             for (j = jmin; j <= i__2; ++j) {
7695                 k = j + aux;
7696                 v1[j + iofv1 - 1] = matsyg[k];
7697             }
7698             mmrslss_(hnstoc, hdimen, &hchole[iofhch], &hposit[3], &hposui[1],
7699                     &v1[iofv1], &v3[iofv3], &ier);
7700             if (ier > 0) {
7701                 goto L9101;
7702             }
7703
7704             deblig = i__;
7705             mmatvec_(gdimen, hdimen, &gposit[4], gnstoc, &matsyg[1], &v3[
7706                     iofv3], &deblig, &v4[iofv4], &ier);
7707             if (ier > 0) {
7708                 goto L9101;
7709             }
7710
7711             k = mposit[(i__ << 1) + 2];
7712             matsym[k + iofmam - 1] = v4[i__ + iofv4 - 1];
7713             while(mmposui[k] > 0) {
7714                 l = mmposui[k];
7715                 k = mposit[(l << 1) + 2] - l + i__;
7716                 matsym[k + iofmam - 1] = v4[l + iofv4 - 1];
7717             }
7718         }
7719
7720
7721 /*    SOLVE SYST 3  M L = V2 */
7722 /*     WITH L=V4 */
7723
7724
7725         AdvApp2Var_SysBase::mvriraz_((integer *)gdimen, (char *)&v4[iofv4]);
7726         AdvApp2Var_SysBase::macrar8_(mnstoc, &c__100, mcho, &iofmch, &ier);
7727         if (ier > 0) {
7728             goto L9102;
7729         }
7730         mmchole_(mnstoc, gdimen, &matsym[iofmam], &mposit[3], &mmposui[1], &
7731                 mcho[iofmch], &ier);
7732         if (ier > 0) {
7733             goto L9101;
7734         }
7735         mmrslss_(mnstoc, gdimen, &mcho[iofmch], &mposit[3], &mmposui[1], &v2[
7736                 iofv2], &v4[iofv4], &ier);
7737         if (ier > 0) {
7738             goto L9102;
7739         }
7740
7741
7742 /*    CALCULATE THE VECTOR OF THE SECOND MEMBER OF THE SYSTEM  Hx = b - t(G) L
7743 */
7744 /*                                                      = V1 */
7745
7746         AdvApp2Var_SysBase::mvriraz_((integer *)hdimen, (char *)&v1[iofv1]);
7747         mmtmave_(gdimen, hdimen, &gposit[4], gnstoc, &matsyg[1], &v4[iofv4], &
7748                 v1[iofv1], &ier);
7749         if (ier > 0) {
7750             goto L9101;
7751         }
7752         i__1 = *hdimen;
7753         for (i__ = 1; i__ <= i__1; ++i__) {
7754             v1[i__ + iofv1 - 1] = vecsyh[i__] - v1[i__ + iofv1 - 1];
7755         }
7756
7757 /*    RESOL SYST 4   Hx = b - t(G) L */
7758
7759
7760         mmrslss_(hnstoc, hdimen, &hchole[iofhch], &hposit[3], &hposui[1], &v1[
7761                 iofv1], &vecsol[1], &ier);
7762         if (ier > 0) {
7763             goto L9102;
7764         }
7765     } else {
7766         i__1 = *hdimen;
7767         for (i__ = 1; i__ <= i__1; ++i__) {
7768             vecsol[i__] = v1[i__ + iofv1 - 1];
7769         }
7770     }
7771
7772     goto L9999;
7773
7774 /* ***********************************************************************
7775  */
7776 /*                   PROCESSING OF ERRORS */
7777 /* ***********************************************************************
7778  */
7779
7780
7781 L9101:
7782     *iercod = 1;
7783     goto L9999;
7784
7785 L9102:
7786     AdvApp2Var_SysBase::mswrdbg_("MMRESOL : PROBLEM WITH DIMMAT", 30L);
7787     *iercod = 2;
7788
7789 /* ***********************************************************************
7790  */
7791 /*                   RETURN CALLING PROGRAM */
7792 /* ***********************************************************************
7793  */
7794
7795 L9999:
7796
7797 /* ___ DESALLOCATION, ... */
7798     AdvApp2Var_SysBase::macrdr8_(hdimen, &c__100, v1, &iofv1, &ier);
7799     if (*iercod == 0 && ier > 0) {
7800         *iercod = 3;
7801     }
7802     AdvApp2Var_SysBase::macrdr8_(&dimhch, &c__100, hchole, &iofhch, &ier);
7803     if (*iercod == 0 && ier > 0) {
7804         *iercod = 3;
7805     }
7806     AdvApp2Var_SysBase::macrdr8_(gdimen, &c__100, v2, &iofv2, &ier);
7807     if (*iercod == 0 && ier > 0) {
7808         *iercod = 3;
7809     }
7810     AdvApp2Var_SysBase::macrdr8_(hdimen, &c__100, v3, &iofv3, &ier);
7811     if (*iercod == 0 && ier > 0) {
7812         *iercod = 3;
7813     }
7814     AdvApp2Var_SysBase::macrdr8_(gdimen, &c__100, v4, &iofv4, &ier);
7815     if (*iercod == 0 && ier > 0) {
7816         *iercod = 3;
7817     }
7818     AdvApp2Var_SysBase::macrdr8_(mnstoc, &c__100, matsym, &iofmam, &ier);
7819     if (*iercod == 0 && ier > 0) {
7820         *iercod = 3;
7821     }
7822     AdvApp2Var_SysBase::macrdr8_(mnstoc, &c__100, mcho, &iofmch, &ier);
7823     if (*iercod == 0 && ier > 0) {
7824         *iercod = 3;
7825     }
7826
7827     AdvApp2Var_SysBase::maermsg_("MMRESOL", iercod, 7L);
7828     if (ldbg) {
7829         AdvApp2Var_SysBase::mgsomsg_("MMRESOL", 7L);
7830     }
7831  return 0 ;
7832 } /* mmresol_ */
7833
7834 //=======================================================================
7835 //function : mmrslss_
7836 //purpose  :
7837 //=======================================================================
7838 int mmrslss_(integer *,//mxcoef,
7839              integer *dimens,
7840              doublereal *smatri,
7841              integer *sposit,
7842              integer *posuiv,
7843              doublereal *mscnmbr,
7844              doublereal *soluti,
7845              integer *iercod)
7846 {
7847   /* System generated locals */
7848   integer i__1, i__2;
7849
7850   /* Local variables */
7851   static logical ldbg;
7852   static integer i__, j;
7853   static doublereal somme;
7854   static integer pointe, ptcour;
7855
7856 /* ***********************************************************************
7857  */
7858
7859 /*     FuNCTION : */
7860 /*     ----------                     T */
7861 /*       Solves linear system SS x = b where S is a  */
7862 /*       triangular lower matrix given in form of profile */
7863
7864 /*     KEYWORDS : */
7865 /*     ----------- */
7866 /*     RESERVE, MATRICE_PROFILE, RESOLUTION, CHOLESKI */
7867
7868 /*     INPUT ARGUMENTS : */
7869 /*     -------------------- */
7870 /*     MXCOEF  : Maximum number of non-null coefficient in the matrix */
7871 /*     DIMENS  : Dimension of the matrix */
7872 /*     SMATRI(MXCOEF) : Values of coefficients of the matrix */
7873 /*     SPOSIT(2,DIMENS): */
7874 /*       SPOSIT(1,*) : Distance diagonal-extremity of the line */
7875 /*       SPOSIT(2,*) : Position of diagonal terms in AMATRI */
7876 /*     POSUIV(MXCOEF): first line inferior not out of profile */
7877 /*     MSCNMBR(DIMENS): Vector second member of the equation */
7878
7879 /*     OUTPUT ARGUMENTS : */
7880 /*     --------------------- */
7881 /*     SOLUTI(NDIMEN) : Result vector */
7882 /*     IERCOD   : Error code 0  : ok */
7883
7884 /*     COMMONS USED : */
7885 /*     ------------------ */
7886
7887
7888 /*     REFERENCES CALLED : */
7889 /*     --------------------- */
7890
7891
7892 /*     DESCRIPTION/NOTES/LIMITATIONS : */
7893 /*     ----------------------------------- */
7894 /*       T */
7895 /*     SS  is the decomposition of choleski of a symmetric matrix */
7896 /*     defined postive, that can result from routine MMCHOLE. */
7897
7898 /*     For a full matrix it is possible to use MRSLMSC */
7899
7900 /*     LEVEL OF DEBUG = 4 */
7901 /* > */
7902 /* ***********************************************************************
7903  */
7904 /*                            DECLARATIONS */
7905 /* ***********************************************************************
7906  */
7907
7908
7909
7910 /* ***********************************************************************
7911  */
7912 /*                      INITIALISATIONS */
7913 /* ***********************************************************************
7914  */
7915
7916     /* Parameter adjustments */
7917     --posuiv;
7918     --smatri;
7919     --soluti;
7920     --mscnmbr;
7921     sposit -= 3;
7922
7923     /* Function Body */
7924     ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 4;
7925     if (ldbg) {
7926         AdvApp2Var_SysBase::mgenmsg_("MMRSLSS", 7L);
7927     }
7928     *iercod = 0;
7929
7930 /* ***********************************************************************
7931  */
7932 /*                     PROCESSING */
7933 /* ***********************************************************************
7934  */
7935
7936 /* ----- Solution of Sw = b */
7937
7938     i__1 = *dimens;
7939     for (i__ = 1; i__ <= i__1; ++i__) {
7940
7941         pointe = sposit[(i__ << 1) + 2];
7942         somme = 0.;
7943         i__2 = i__ - 1;
7944         for (j = i__ - sposit[(i__ << 1) + 1]; j <= i__2; ++j) {
7945             somme += smatri[pointe - (i__ - j)] * soluti[j];
7946         }
7947
7948         soluti[i__] = (mscnmbr[i__] - somme) / smatri[pointe];
7949     }
7950 /*                     T */
7951 /* ----- Solution of S u = w */
7952
7953     for (i__ = *dimens; i__ >= 1; --i__) {
7954
7955         pointe = sposit[(i__ << 1) + 2];
7956         j = posuiv[pointe];
7957         somme = 0.;
7958         while(j > 0) {
7959             ptcour = sposit[(j << 1) + 2] - (j - i__);
7960             somme += smatri[ptcour] * soluti[j];
7961             j = posuiv[ptcour];
7962         }
7963
7964         soluti[i__] = (soluti[i__] - somme) / smatri[pointe];
7965     }
7966
7967     goto L9999;
7968
7969 /* ***********************************************************************
7970  */
7971 /*                   ERROR PROCESSING */
7972 /* ***********************************************************************
7973  */
7974
7975
7976 /* ***********************************************************************
7977  */
7978 /*                   RETURN PROGRAM CALLING */
7979 /* ***********************************************************************
7980  */
7981
7982 L9999:
7983
7984     AdvApp2Var_SysBase::maermsg_("MMRSLSS", iercod, 7L);
7985     if (ldbg) {
7986         AdvApp2Var_SysBase::mgsomsg_("MMRSLSS", 7L);
7987     }
7988  return 0 ;
7989 } /* mmrslss_ */
7990
7991 //=======================================================================
7992 //function : mmrslw_
7993 //purpose  :
7994 //=======================================================================
7995 int mmrslw_(integer *normax,
7996             integer *nordre,
7997             integer *ndimen,
7998             doublereal *epspiv,
7999             doublereal *abmatr,
8000             doublereal *xmatri,
8001             integer *iercod)
8002 {
8003   /* System generated locals */
8004     integer abmatr_dim1, abmatr_offset, xmatri_dim1, xmatri_offset, i__1,
8005             i__2, i__3;
8006     doublereal d__1;
8007
8008     /* Local variables */
8009     static integer kpiv;
8010     static doublereal pivot;
8011     static integer ii, jj, kk;
8012     static doublereal akj;
8013
8014
8015 /* **********************************************************************
8016 */
8017
8018 /*     FUNCTION : */
8019 /*     ---------- */
8020 /*  Solution of a linear system A.x = B of N equations to N */
8021 /*  unknown by Gauss method (partial pivot) or : */
8022 /*          A is matrix NORDRE * NORDRE, */
8023 /*          B is matrix NORDRE (lines) * NDIMEN (columns), */
8024 /*          x is matrix NORDRE (lines) * NDIMEN (columns). */
8025 /*  In this program, A and B are stored in matrix ABMATR  */
8026 /*  the lines and columns which of were inverted. ABMATR(k,j) is */
8027 /*  term A(j,k) if k <= NORDRE, B(j,k-NORDRE) otherwise (see example). */
8028
8029 /*     KEYWORDS : */
8030 /*     ----------- */
8031 /* TOUS, MATH_ACCES::EQUATION&, MATRICE&, RESOLUTION, GAUSS, &SOLUTION */
8032
8033 /*     INPUT ARGUMENTS : */
8034 /*     ------------------ */
8035 /*   NORMAX : Max size of the first index of XMATRI. This argument */
8036 /*            serves only for the declaration of dimension of XMATRI and should be */
8037 /*            above or equal to NORDRE. */
8038 /*   NORDRE : Order of the matrix i.e. number of equations and  */
8039 /*            unknown quantities of the linear system to be solved. */
8040 /*   NDIMEN : Number of the second member. */
8041 /*   EPSPIV : Minimal value of a pivot. If during the calculation  */
8042 /*            the absolute value of the pivot is below EPSPIV, the */
8043 /*            system of equations is declared singular. EPSPIV should */
8044 /*            be a "small" real. */
8045
8046 /*   ABMATR(NORDRE+NDIMEN,NORDRE) : Auxiliary matrix containing  */
8047 /*                                  matrix A and matrix B. */
8048
8049 /*     OUTPUT ARGUMENTS : */
8050 /*     ------------------- */
8051 /*   XMATRI : Matrix containing  NORDRE*NDIMEN solutions. */
8052 /*   IERCOD=0 shows that all solutions are calculated. */
8053 /*   IERCOD=1 shows that the matrix is of lower rank than NORDRE */
8054 /*            (the system is singular). */
8055
8056 /*     COMMONS USED   : */
8057 /*     ---------------- */
8058
8059 /*     REFERENCES CALLED   : */
8060 /*     ----------------------- */
8061
8062 /*     DESCRIPTION/NOTES/LIMITATIONS : */
8063 /*     ----------------------------------- */
8064 /*     ATTENTION : the indices of line and column are inverted */
8065 /*                 compared to usual indices. */
8066 /*                 System : */
8067 /*                        a1*x + b1*y = c1 */
8068 /*                        a2*x + b2*y = c2 */
8069 /*                 should be represented by matrix ABMATR : */
8070
8071 /*                 ABMATR(1,1) = a1  ABMATR(1,2) = a2 */
8072 /*                 ABMATR(2,1) = b1  ABMATR(2,2) = b2 */
8073 /*                 ABMATR(3,1) = c1  ABMATR(3,2) = c2 */
8074
8075 /*     To solve this system, it is necessary to set : */
8076
8077 /*                 NORDRE = 2 (there are 2 equations with 2 unknown values), */
8078 /*                 NDIMEN = 1 (there is only one second member), */
8079 /*                 any NORMAX can be taken >= NORDRE. */
8080
8081 /*     To use this routine, it is recommended to use one of */
8082 /*     interfaces : MMRSLWI or MMMRSLWD. */
8083 /* > */
8084 /* **********************************************************************
8085 */
8086
8087 /*   Name of the routine */
8088
8089 /*      INTEGER IBB,MNFNDEB */
8090
8091 /*      IBB=MNFNDEB() */
8092 /*      IF (IBB.GE.2) CALL MGENMSG(NOMPR) */
8093     /* Parameter adjustments */
8094     xmatri_dim1 = *normax;
8095     xmatri_offset = xmatri_dim1 + 1;
8096     xmatri -= xmatri_offset;
8097     abmatr_dim1 = *nordre + *ndimen;
8098     abmatr_offset = abmatr_dim1 + 1;
8099     abmatr -= abmatr_offset;
8100
8101     /* Function Body */
8102     *iercod = 0;
8103
8104 /* *********************************************************************
8105 */
8106 /*                  Triangulation of matrix ABMATR. */
8107 /* *********************************************************************
8108 */
8109
8110     i__1 = *nordre;
8111     for (kk = 1; kk <= i__1; ++kk) {
8112
8113 /* ---------- Find max pivot in column KK. ------------
8114 --- */
8115
8116         pivot = *epspiv;
8117         kpiv = 0;
8118         i__2 = *nordre;
8119         for (jj = kk; jj <= i__2; ++jj) {
8120             akj = (d__1 = abmatr[kk + jj * abmatr_dim1], abs(d__1));
8121             if (akj > pivot) {
8122                 pivot = akj;
8123                 kpiv = jj;
8124             }
8125 /* L100: */
8126         }
8127         if (kpiv == 0) {
8128             goto L9900;
8129         }
8130
8131 /* --------- Swapping of line KPIV with line KK. ------
8132 --- */
8133
8134         if (kpiv != kk) {
8135             i__2 = *nordre + *ndimen;
8136             for (jj = kk; jj <= i__2; ++jj) {
8137                 akj = abmatr[jj + kk * abmatr_dim1];
8138                 abmatr[jj + kk * abmatr_dim1] = abmatr[jj + kpiv *
8139                         abmatr_dim1];
8140                 abmatr[jj + kpiv * abmatr_dim1] = akj;
8141 /* L200: */
8142             }
8143         }
8144
8145 /* ---------- Removal and triangularization. -----------
8146 --- */
8147
8148         pivot = -abmatr[kk + kk * abmatr_dim1];
8149         i__2 = *nordre;
8150         for (ii = kk + 1; ii <= i__2; ++ii) {
8151             akj = abmatr[kk + ii * abmatr_dim1] / pivot;
8152             i__3 = *nordre + *ndimen;
8153             for (jj = kk + 1; jj <= i__3; ++jj) {
8154                 abmatr[jj + ii * abmatr_dim1] += akj * abmatr[jj + kk *
8155                         abmatr_dim1];
8156 /* L400: */
8157             }
8158 /* L300: */
8159         }
8160
8161
8162 /* L1000: */
8163     }
8164
8165 /* *********************************************************************
8166 */
8167 /*          Solution of the system of triangular equations. */
8168 /*   Matrix ABMATR(NORDRE+JJ,II), contains second members  */
8169 /*             of the system for 1<=j<=NDIMEN and 1<=i<=NORDRE. */
8170 /* *********************************************************************
8171 */
8172
8173
8174 /* ---------------- Calculation of solutions by ascending. -----------------
8175 */
8176
8177     for (kk = *nordre; kk >= 1; --kk) {
8178         pivot = abmatr[kk + kk * abmatr_dim1];
8179         i__1 = *ndimen;
8180         for (ii = 1; ii <= i__1; ++ii) {
8181             akj = abmatr[ii + *nordre + kk * abmatr_dim1];
8182             i__2 = *nordre;
8183             for (jj = kk + 1; jj <= i__2; ++jj) {
8184                 akj -= abmatr[jj + kk * abmatr_dim1] * xmatri[jj + ii *
8185                         xmatri_dim1];
8186 /* L800: */
8187             }
8188             xmatri[kk + ii * xmatri_dim1] = akj / pivot;
8189 /* L700: */
8190         }
8191 /* L600: */
8192     }
8193     goto L9999;
8194
8195 /* ------If the absolute value of a pivot is smaller than --------
8196 /* ---------- EPSPIV: return the code of error. ------------
8197 */
8198
8199 L9900:
8200     *iercod = 1;
8201
8202
8203
8204 L9999:
8205     if (*iercod > 0) {
8206         AdvApp2Var_SysBase::maermsg_("MMRSLW ", iercod, 7L);
8207     }
8208 /*      IF (IBB.GE.2) CALL MGSOMSG(NOMPR) */
8209  return 0 ;
8210 } /* mmrslw_ */
8211
8212 //=======================================================================
8213 //function : AdvApp2Var_MathBase::mmmrslwd_
8214 //purpose  :
8215 //=======================================================================
8216  int AdvApp2Var_MathBase::mmmrslwd_(integer *normax,
8217                              integer *nordre,
8218                              integer *ndim,
8219                              doublereal *amat,
8220                              doublereal *bmat,
8221                              doublereal *epspiv,
8222                              doublereal *aaux,
8223                              doublereal *xmat,
8224                              integer *iercod)
8225
8226 {
8227   /* System generated locals */
8228   integer amat_dim1, amat_offset, bmat_dim1, bmat_offset, xmat_dim1,
8229   xmat_offset, aaux_dim1, aaux_offset, i__1, i__2;
8230
8231   /* Local variables */
8232   static integer i__, j;
8233   static integer ibb;
8234
8235 /*      IMPLICIT DOUBLE PRECISION (A-H,O-Z) */
8236 /*      IMPLICIT INTEGER (I-N) */
8237
8238
8239 /* **********************************************************************
8240 */
8241
8242 /*     FUNCTION : */
8243 /*     ---------- */
8244 /*        Solution of a linear system by Gauss method where */
8245 /*        the second member is a table of vectors. Method of partial pivot. */
8246
8247 /*     KEYWORDS : */
8248 /*     ----------- */
8249 /*        ALL, MATH_ACCES :: */
8250 /*        SYSTEME&,EQUATION&, RESOLUTION,GAUSS ,&VECTEUR */
8251
8252 /*     INPUT ARGUMENTS : */
8253 /*     ------------------ */
8254 /*        NORMAX : Max. Dimension of AMAT. */
8255 /*        NORDRE :  Order of the matrix. */
8256 /*        NDIM : Number of columns of BMAT and XMAT. */
8257 /*        AMAT(NORMAX,NORDRE) : The processed matrix. */
8258 /*        BMAT(NORMAX,NDIM)   : The matrix of second member. */
8259 /*        XMAT(NORMAX,NDIM)   : The matrix of solutions. */
8260 /*        EPSPIV : Min value of a pivot. */
8261
8262 /*     OUTPUT ARGUMENTS : */
8263 /*     ------------------- */
8264 /*        AAUX(NORDRE+NDIM,NORDRE) : Auxiliary matrix. */
8265 /*        XMAT(NORMAX,NDIM) : Matrix of solutions. */
8266 /*        IERCOD=0 shows that solutions in XMAT are valid. */
8267 /*        IERCOD=1 shows that matrix AMAT is of lower rank than NORDRE. */
8268
8269 /*     COMMONS USED   : */
8270 /*     ---------------- */
8271
8272 /*      .Neant. */
8273
8274 /*     REFERENCES CALLED : */
8275 /*     ---------------------- */
8276 /*     Type  Name */
8277 /*           MAERMSG              MGENMSG              MGSOMSG */
8278 /*           MMRSLW          I*4  MNFNDEB */
8279
8280 /*     DESCRIPTION/NOTES/LIMITATIONS : */
8281 /*     ----------------------------------- */
8282 /*    ATTENTION : lines and columns are located in usual order : */
8283 /*               1st index  = index line */
8284 /*               2nd index = index column */
8285 /*    Example, the system : */
8286 /*                 a1*x + b1*y = c1 */
8287 /*                 a2*x + b2*y = c2 */
8288 /*    is represented by matrix AMAT : */
8289
8290 /*                 AMAT(1,1) = a1  AMAT(2,1) = a2 */
8291 /*                 AMAT(1,2) = b1  AMAT(2,2) = b2 */
8292
8293 /*     The first index is the index of line, the second index */
8294 /*     is the index of columns (Compare with MMRSLWI which is faster). */
8295
8296 /* > */
8297 /* **********************************************************************
8298 */
8299
8300 /*   Name of the routine */
8301
8302     /* Parameter adjustments */
8303     amat_dim1 = *normax;
8304     amat_offset = amat_dim1 + 1;
8305     amat -= amat_offset;
8306     xmat_dim1 = *normax;
8307     xmat_offset = xmat_dim1 + 1;
8308     xmat -= xmat_offset;
8309     aaux_dim1 = *nordre + *ndim;
8310     aaux_offset = aaux_dim1 + 1;
8311     aaux -= aaux_offset;
8312     bmat_dim1 = *normax;
8313     bmat_offset = bmat_dim1 + 1;
8314     bmat -= bmat_offset;
8315
8316     /* Function Body */
8317     ibb = AdvApp2Var_SysBase::mnfndeb_();
8318     if (ibb >= 3) {
8319         AdvApp2Var_SysBase::mgenmsg_("MMMRSLW", 7L);
8320     }
8321
8322 /*   Initialization of the auxiliary matrix. */
8323
8324     i__1 = *nordre;
8325     for (i__ = 1; i__ <= i__1; ++i__) {
8326         i__2 = *nordre;
8327         for (j = 1; j <= i__2; ++j) {
8328             aaux[j + i__ * aaux_dim1] = amat[i__ + j * amat_dim1];
8329 /* L200: */
8330         }
8331 /* L100: */
8332     }
8333
8334 /*    Second member. */
8335
8336     i__1 = *nordre;
8337     for (i__ = 1; i__ <= i__1; ++i__) {
8338         i__2 = *ndim;
8339         for (j = 1; j <= i__2; ++j) {
8340             aaux[j + *nordre + i__ * aaux_dim1] = bmat[i__ + j * bmat_dim1];
8341 /* L400: */
8342         }
8343 /* L300: */
8344     }
8345
8346 /*    Solution of the system of equations. */
8347
8348     mmrslw_(normax, nordre, ndim, epspiv, &aaux[aaux_offset], &xmat[
8349             xmat_offset], iercod);
8350
8351
8352     if (*iercod != 0) {
8353         AdvApp2Var_SysBase::maermsg_("MMMRSLW", iercod, 7L);
8354     }
8355     if (ibb >= 3) {
8356         AdvApp2Var_SysBase::mgsomsg_("MMMRSLW", 7L);
8357     }
8358  return 0 ;
8359 } /* mmmrslwd_ */
8360
8361 //=======================================================================
8362 //function : AdvApp2Var_MathBase::mmrtptt_
8363 //purpose  :
8364 //=======================================================================
8365  int AdvApp2Var_MathBase::mmrtptt_(integer *ndglgd,
8366                             doublereal *rtlegd)
8367
8368 {
8369   static integer ideb, nmod2, nsur2, ilong, ibb;
8370
8371
8372 /* **********************************************************************
8373 */
8374
8375 /*     FUNCTION : */
8376 /*     ---------- */
8377 /*     Extracts from Common LDGRTL the STRICTLY positive roots of the */
8378 /*     Legendre polynom of degree NDGLGD, for 2 <= NDGLGD <= 61. */
8379
8380 /*     KEYWORDS : */
8381 /*     ----------- */
8382 /*     TOUS, AB_SPECIFI::COMMON&, EXTRACTION, &RACINE, &LEGENDRE. */
8383
8384 /*     INPUT ARGUMENTS : */
8385 /*     ------------------ */
8386 /*        NDGLGD : Mathematic degree of Legendre polynom. */
8387 /*                 This degree should be above or equal to 2 and */
8388 /*                 below or equal to 61. */
8389
8390 /*     OUTPUT ARGUMENTS : */
8391 /*     ------------------- */
8392 /*        RTLEGD : The table of strictly positive roots of */
8393 /*                 Legendre polynom of degree NDGLGD. */
8394
8395 /*     COMMONS USED   : */
8396 /*     ---------------- */
8397
8398 /*     REFERENCES CALLED   : */
8399 /*     ----------------------- */
8400
8401 /*     DESCRIPTION/NOTES/LIMITATIONS : */
8402 /*     ----------------------------------- */
8403 /*     ATTENTION: the condition on NDEGRE ( 2 <= NDEGRE <= 61) is not */
8404 /*     tested. The caller should make the test. */
8405
8406 /* > */
8407 /* **********************************************************************
8408 */
8409 /*   Nome of the routine */
8410
8411
8412 /*   Common MLGDRTL: */
8413 /*   This common includes POSITIVE roots of Legendre polynoms */
8414 /*   AND the weight of Gauss quadrature formulas on all */
8415 /*   POSITIVE roots of Legendre polynoms. */
8416
8417
8418 /* ***********************************************************************
8419  */
8420
8421 /*     FUNCTION : */
8422 /*     ---------- */
8423 /*   The common of Legendre roots. */
8424
8425 /*     KEYWORDS : */
8426 /*     ----------- */
8427 /*        BASE LEGENDRE */
8428
8429 /*     DEMSCRIPTION/NOTES/LIMITATIONS : */
8430 /*     ----------------------------------- */
8431
8432 /* > */
8433 /* ***********************************************************************
8434  */
8435
8436
8437
8438
8439 /*   ROOTAB : Table of all rotts of Legendre polynoms */
8440 /*   between [0,1]. They are ranked for degrees increasing from 2 to 61. */
8441 /*   HILTAB : Table of Legendre interpolators concerning ROOTAB. */
8442 /*   The address is the same. */
8443 /*   HI0TAB : Table of Legendre interpolators for root x=0 */
8444 /*   the polynoms of UNEVEN degree. */
8445 /*   RTLTB0 : Table of Li(uk) where uk are roots of a */
8446 /*   Legendre polynom of EVEN degree. */
8447 /*   RTLTB1 : Table of Li(uk) where uk are roots of a */
8448 /*   Legendre polynom of UNEVEN degree. */
8449
8450
8451 /************************************************************************
8452 *****/
8453     /* Parameter adjustments */
8454     --rtlegd;
8455
8456     /* Function Body */
8457     ibb = AdvApp2Var_SysBase::mnfndeb_();
8458     if (ibb >= 3) {
8459         AdvApp2Var_SysBase::mgenmsg_("MMRTPTT", 7L);
8460     }
8461     if (*ndglgd < 2) {
8462         goto L9999;
8463     }
8464
8465     nsur2 = *ndglgd / 2;
8466     nmod2 = *ndglgd % 2;
8467
8468     ilong = nsur2 << 3;
8469     ideb = nsur2 * (nsur2 - 1) / 2 + 1;
8470     AdvApp2Var_SysBase::mcrfill_((integer *)&ilong,
8471              (char *)&mlgdrtl_.rootab[ideb + nmod2 * 465 - 1],
8472              (char *)&rtlegd[1]);
8473
8474 /* ----------------------------- The end --------------------------------
8475 */
8476
8477 L9999:
8478     if (ibb >= 3) {
8479         AdvApp2Var_SysBase::mgsomsg_("MMRTPTT", 7L);
8480     }
8481     return 0;
8482 } /* mmrtptt_ */
8483
8484 //=======================================================================
8485 //function : AdvApp2Var_MathBase::mmsrre2_
8486 //purpose  :
8487 //=======================================================================
8488  int AdvApp2Var_MathBase::mmsrre2_(doublereal *tparam,
8489                             integer *nbrval,
8490                             doublereal *tablev,
8491                             doublereal *epsil,
8492                             integer *numint,
8493                             integer *itypen,
8494                             integer *iercod)
8495 {
8496   /* System generated locals */
8497   doublereal d__1;
8498
8499   /* Local variables */
8500   static integer ideb, ifin, imil, ibb;
8501
8502 /* ***********************************************************************
8503  */
8504
8505 /*     FUNCTION : */
8506 /*     -------- */
8507
8508 /*     Find the interval corresponding to a valueb given in  */
8509 /*     increasing order of real numbers with double precision. */
8510
8511 /*     KEYWORDS : */
8512 /*     --------- */
8513 /*     TOUS,MATH_ACCES::TABLEAU&,POINT&,CORRESPONDANCE,&RANG */
8514
8515 /*     INPUT ARGUMENTS : */
8516 /*     ------------------ */
8517
8518 /*     TPARAM  : Value to be tested. */
8519 /*     NBRVAL  : Size of TABLEV */
8520 /*     TABLEV  : Table of reals. */
8521 /*     EPSIL   : Epsilon of precision */
8522
8523 /*     OUTPUT ARGUMENTS : */
8524 /*     ------------------- */
8525
8526 /*     NUMINT  : Number of the interval (between 1 and NBRVAL-1). */
8527 /*     ITYPEN  : = 0 TPARAM is inside the interval NUMINT */
8528 /*               = 1 : TPARAM corresponds to the lower limit of */
8529 /*               the provided interval. */
8530 /*               = 2 : TPARAM corresponds to the upper limit of */
8531 /*               the provided interval. */
8532
8533 /*     IERCOD : Error code. */
8534 /*                     = 0 : OK */
8535 /*                     = 1 : TABLEV does not contain enough elements. */
8536 /*                     = 2 : TPARAM out of limits of TABLEV. */
8537
8538 /*     COMMONS USED : */
8539 /*     ---------------- */
8540
8541 /*     REFERENCES CALLED : */
8542 /*     ------------------- */
8543
8544 /*     DESCRIPTION/NOTES/LIMITATIONS : */
8545 /*     --------------------------------- */
8546 /*     There are NBRVAL values in TABLEV which stands for NBRVAL-1 intervals. */
8547 /*     One searches the interval containing TPARAM by */
8548 /*     dichotomy. Complexity of the algorithm : Log(n)/Log(2).(RBD). */
8549 /* > */
8550 /* ***********************************************************************
8551  */
8552
8553
8554 /* Initialisations */
8555
8556     /* Parameter adjustments */
8557     --tablev;
8558
8559     /* Function Body */
8560     ibb = AdvApp2Var_SysBase::mnfndeb_();
8561     if (ibb >= 6) {
8562         AdvApp2Var_SysBase::mgenmsg_("MMSRRE2", 7L);
8563     }
8564
8565     *iercod = 0;
8566     *numint = 0;
8567     *itypen = 0;
8568     ideb = 1;
8569     ifin = *nbrval;
8570
8571 /* TABLEV should contain at least two values */
8572
8573     if (*nbrval < 2) {
8574         *iercod = 1;
8575         goto L9999;
8576     }
8577
8578 /* TPARAM should be between extreme limits of TABLEV. */
8579
8580     if (*tparam < tablev[1] || *tparam > tablev[*nbrval]) {
8581         *iercod = 2;
8582         goto L9999;
8583     }
8584
8585 /* ----------------------- SEARCH OF THE INTERVAL --------------------
8586 */
8587
8588 L1000:
8589
8590 /* Test end of loop (found). */
8591
8592     if (ideb + 1 == ifin) {
8593         *numint = ideb;
8594         goto L2000;
8595     }
8596
8597 /* Find by dichotomy on increasing values of TABLEV. */
8598
8599     imil = (ideb + ifin) / 2;
8600     if (*tparam >= tablev[ideb] && *tparam <= tablev[imil]) {
8601         ifin = imil;
8602     } else {
8603         ideb = imil;
8604     }
8605
8606     goto L1000;
8607
8608 /* -------------- TEST IF TPARAM IS NOT A VALUE ---------
8609 /* ------------------------OF TABLEV UP TO EPSIL ----------------------
8610 */
8611
8612 L2000:
8613     if ((d__1 = *tparam - tablev[ideb], abs(d__1)) < *epsil) {
8614         *itypen = 1;
8615         goto L9999;
8616     }
8617     if ((d__1 = *tparam - tablev[ifin], abs(d__1)) < *epsil) {
8618         *itypen = 2;
8619         goto L9999;
8620     }
8621
8622 /* --------------------------- THE END ----------------------------------
8623 */
8624
8625 L9999:
8626     if (*iercod > 0) {
8627         AdvApp2Var_SysBase::maermsg_("MMSRRE2", iercod, 7L);
8628     }
8629     if (ibb >= 6) {
8630         AdvApp2Var_SysBase::mgsomsg_("MMSRRE2", 7L);
8631     }
8632  return 0 ;
8633 } /* mmsrre2_ */
8634
8635 //=======================================================================
8636 //function : mmtmave_
8637 //purpose  :
8638 //=======================================================================
8639 int mmtmave_(integer *nligne,
8640              integer *ncolon,
8641              integer *gposit,
8642              integer *,//gnstoc,
8643              doublereal *gmatri,
8644              doublereal *vecin,
8645              doublereal *vecout,
8646              integer *iercod)
8647
8648 {
8649   /* System generated locals */
8650   integer i__1, i__2;
8651
8652   /* Local variables */
8653   static logical ldbg;
8654   static integer imin, imax, i__, j, k;
8655   static doublereal somme;
8656   static integer aux;
8657
8658
8659 /* ***********************************************************************
8660  */
8661
8662 /*     FUNCTION : */
8663 /*     ---------- */
8664 /*                          t */
8665 /*      CREATES PRODUCT   G V */
8666 /*      WHERE THE MATRIX IS IN FORM OF PROFILE */
8667
8668 /*     KEYWORDS : */
8669 /*     ----------- */
8670 /*      RESERVE, PRODUCT, MATRIX, PROFILE, VECTOR */
8671
8672 /*     INPUT ARGUMENTS : */
8673 /*     -------------------- */
8674 /*       NLIGNE : NUMBER OF LINE OF THE MATRIX */
8675 /*       NCOLON : NOMBER OF COLUMN OF THE MATRIX */
8676 /*       GPOSIT: TABLE OF POSITIONING OF TERMS OF STORAGE */
8677 /*               GPOSIT(1,I) CONTAINS THE NUMBER of TERMS-1 ON LINE
8678                I IN THE PROFILE OF THE MATRIX */
8679 /*              GPOSIT(2,I) CONTAINS THE INDEX OF STORAGE OF THE DIAGONAL TERM
8680 /*               OF LINE I */
8681 /*               GPOSIT(3,I) CONTAINS THE INDEX COLUMN OF THE FIRST TERM OF
8682 /*                           PROFILE OF LINE I */
8683 /*       GNSTOC : NOMBER OF TERM IN THE PROFILE OF GMATRI */
8684 /*       GMATRI : MATRIX OF CONSTRAINTS IN FORM OF PROFILE */
8685 /*       VECIN :  INPUT VECTOR */
8686
8687 /*     OUTPUT ARGUMENTS : */
8688 /*     --------------------- */
8689 /*       VECOUT : VECTOR PRODUCT */
8690 /*       IERCOD : ERROR CODE */
8691
8692
8693 /*     COMMONS USED : */
8694 /*     ------------------ */
8695
8696
8697 /*     REFERENCES CALLED : */
8698 /*     --------------------- */
8699
8700
8701 /*     DESCRIPTION/NOTES/LIMITATIONS : */
8702 /*     ----------------------------------- */
8703 /* > */
8704 /* ***********************************************************************
8705  */
8706 /*                            DECLARATIONS */
8707 /* ***********************************************************************
8708  */
8709
8710
8711
8712 /* ***********************************************************************
8713  */
8714 /*                      INITIALISATIONS */
8715 /* ***********************************************************************
8716  */
8717
8718     /* Parameter adjustments */
8719     --vecin;
8720     gposit -= 4;
8721     --vecout;
8722     --gmatri;
8723
8724     /* Function Body */
8725     ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 2;
8726     if (ldbg) {
8727         AdvApp2Var_SysBase::mgenmsg_("MMTMAVE", 7L);
8728     }
8729     *iercod = 0;
8730
8731 /* ***********************************************************************
8732  */
8733 /*                     PROCESSING */
8734 /* ***********************************************************************
8735  */
8736
8737
8738
8739     i__1 = *ncolon;
8740     for (i__ = 1; i__ <= i__1; ++i__) {
8741         somme = 0.;
8742         i__2 = *nligne;
8743         for (j = 1; j <= i__2; ++j) {
8744             imin = gposit[j * 3 + 3];
8745             imax = gposit[j * 3 + 1] + gposit[j * 3 + 3] - 1;
8746             aux = gposit[j * 3 + 2] - gposit[j * 3 + 1] - imin + 1;
8747             if (imin <= i__ && i__ <= imax) {
8748                 k = i__ + aux;
8749                 somme += gmatri[k] * vecin[j];
8750             }
8751         }
8752         vecout[i__] = somme;
8753     }
8754
8755
8756
8757
8758
8759     goto L9999;
8760
8761 /* ***********************************************************************
8762  */
8763 /*                   ERROR PROCESSING */
8764 /* ***********************************************************************
8765  */
8766
8767
8768 /* ***********************************************************************
8769  */
8770 /*                   RETURN CALLING PROGRAM */
8771 /* ***********************************************************************
8772  */
8773
8774 L9999:
8775
8776 /* ___ DESALLOCATION, ... */
8777
8778     AdvApp2Var_SysBase::maermsg_("MMTMAVE", iercod, 7L);
8779     if (ldbg) {
8780         AdvApp2Var_SysBase::mgsomsg_("MMTMAVE", 7L);
8781     }
8782  return 0 ;
8783 } /* mmtmave_ */
8784
8785 //=======================================================================
8786 //function : mmtrpj0_
8787 //purpose  :
8788 //=======================================================================
8789 int mmtrpj0_(integer *ncofmx,
8790              integer *ndimen,
8791              integer *ncoeff,
8792              doublereal *epsi3d,
8793              doublereal *crvlgd,
8794              doublereal *ycvmax,
8795              doublereal *epstrc,
8796              integer *ncfnew)
8797
8798 {
8799   /* System generated locals */
8800   integer crvlgd_dim1, crvlgd_offset, i__1, i__2;
8801   doublereal d__1;
8802
8803   /* Local variables */
8804   static integer ncut, i__;
8805   static doublereal bidon, error;
8806   static integer nd;
8807
8808
8809 /* ***********************************************************************
8810  */
8811
8812 /*     FUNCTION : */
8813 /*     ---------- */
8814 /*        Lowers the degree of a curve defined on (-1,1) in the direction of */
8815 /*        Legendre with a given precision. */
8816
8817 /*     KEYWORDS : */
8818 /*     ----------- */
8819 /*        LEGENDRE, POLYGON, TRUNCATION, CURVE, SMOOTHING. */
8820
8821 /*     INPUT ARGUMENTS : */
8822 /*     ------------------ */
8823 /*        NCOFMX : Max Nb of coeff. of the curve (dimensioning). */
8824 /*        NDIMEN : Dimension of the space. */
8825 /*        NCOEFF : Degree +1 of the polynom. */
8826 /*        EPSI3D : Precision required for the approximation. */
8827 /*        CRVLGD : The curve the degree which of it is required to lower. */
8828
8829 /*     OUTPUT ARGUMENTS : */
8830 /*     ------------------- */
8831 /*        EPSTRC : Precision of the approximation. */
8832 /*        NCFNEW : Degree +1 of the resulting polynom. */
8833
8834 /*     COMMONS USED   : */
8835 /*     ---------------- */
8836
8837 /*     REFERENCES CALLED   : */
8838 /*     ----------------------- */
8839
8840 /*     DESCRIPTION/NOTES/LIMITATIONS : */
8841 /*     ----------------------------------- */
8842 /* > */
8843 /* ***********************************************************************
8844  */
8845
8846
8847 /* ------- Minimum degree that can be attained : Stop at 1 (RBD) ---------
8848 */
8849
8850     /* Parameter adjustments */
8851     --ycvmax;
8852     crvlgd_dim1 = *ncofmx;
8853     crvlgd_offset = crvlgd_dim1 + 1;
8854     crvlgd -= crvlgd_offset;
8855
8856     /* Function Body */
8857     *ncfnew = 1;
8858 /* ------------------- Init for error calculation -----------------------
8859 */
8860     i__1 = *ndimen;
8861     for (i__ = 1; i__ <= i__1; ++i__) {
8862         ycvmax[i__] = 0.;
8863 /* L100: */
8864     }
8865     *epstrc = 0.;
8866     error = 0.;
8867
8868 /*   Cutting of coefficients. */
8869
8870     ncut = 2;
8871 /* ------ Loop on the series of Legendre :NCOEFF --> 2 (RBD) -----------
8872 */
8873     i__1 = ncut;
8874     for (i__ = *ncoeff; i__ >= i__1; --i__) {
8875 /*   Factor of renormalization. */
8876         bidon = ((i__ - 1) * 2. + 1.) / 2.;
8877         bidon = sqrt(bidon);
8878         i__2 = *ndimen;
8879         for (nd = 1; nd <= i__2; ++nd) {
8880             ycvmax[nd] += (d__1 = crvlgd[i__ + nd * crvlgd_dim1], abs(d__1)) *
8881                      bidon;
8882 /* L310: */
8883         }
8884 /*   Cutting is stopped if the norm becomes too great. */
8885         error = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
8886         if (error > *epsi3d) {
8887             *ncfnew = i__;
8888             goto L9999;
8889         }
8890
8891 /* ---  Max error cumulee when the I-th coeff is removed. */
8892
8893         *epstrc = error;
8894
8895 /* L300: */
8896     }
8897
8898 /* --------------------------------- End --------------------------------
8899 */
8900
8901 L9999:
8902     return 0;
8903 } /* mmtrpj0_ */
8904
8905 //=======================================================================
8906 //function : mmtrpj2_
8907 //purpose  :
8908 //=======================================================================
8909 int mmtrpj2_(integer *ncofmx,
8910              integer *ndimen,
8911              integer *ncoeff,
8912              doublereal *epsi3d,
8913              doublereal *crvlgd,
8914              doublereal *ycvmax,
8915              doublereal *epstrc,
8916              integer *ncfnew)
8917
8918 {
8919     /* Initialized data */
8920
8921     static doublereal xmaxj[57] = { .9682458365518542212948163499456,
8922             .986013297183269340427888048593603,
8923             1.07810420343739860362585159028115,
8924             1.17325804490920057010925920756025,
8925             1.26476561266905634732910520370741,
8926             1.35169950227289626684434056681946,
8927             1.43424378958284137759129885012494,
8928             1.51281316274895465689402798226634,
8929             1.5878364329591908800533936587012,
8930             1.65970112228228167018443636171226,
8931             1.72874345388622461848433443013543,
8932             1.7952515611463877544077632304216,
8933             1.85947199025328260370244491818047,
8934             1.92161634324190018916351663207101,
8935             1.98186713586472025397859895825157,
8936             2.04038269834980146276967984252188,
8937             2.09730119173852573441223706382076,
8938             2.15274387655763462685970799663412,
8939             2.20681777186342079455059961912859,
8940             2.25961782459354604684402726624239,
8941             2.31122868752403808176824020121524,
8942             2.36172618435386566570998793688131,
8943             2.41117852396114589446497298177554,
8944             2.45964731268663657873849811095449,
8945             2.50718840313973523778244737914028,
8946             2.55385260994795361951813645784034,
8947             2.59968631659221867834697883938297,
8948             2.64473199258285846332860663371298,
8949             2.68902863641518586789566216064557,
8950             2.73261215675199397407027673053895,
8951             2.77551570192374483822124304745691,
8952             2.8177699459714315371037628127545,
8953             2.85940333797200948896046563785957,
8954             2.90044232019793636101516293333324,
8955             2.94091151970640874812265419871976,
8956             2.98083391718088702956696303389061,
8957             3.02023099621926980436221568258656,
8958             3.05912287574998661724731962377847,
8959             3.09752842783622025614245706196447,
8960             3.13546538278134559341444834866301,
8961             3.17295042316122606504398054547289,
8962             3.2099992681699613513775259670214,
8963             3.24662674946606137764916854570219,
8964             3.28284687953866689817670991319787,
8965             3.31867291347259485044591136879087,
8966             3.35411740487202127264475726990106,
8967             3.38919225660177218727305224515862,
8968             3.42390876691942143189170489271753,
8969             3.45827767149820230182596660024454,
8970             3.49230918177808483937957161007792,
8971             3.5260130200285724149540352829756,
8972             3.55939845146044235497103883695448,
8973             3.59247431368364585025958062194665,
8974             3.62524904377393592090180712976368,
8975             3.65773070318071087226169680450936,
8976             3.68992700068237648299565823810245,
8977             3.72184531357268220291630708234186 };
8978
8979     /* System generated locals */
8980     integer crvlgd_dim1, crvlgd_offset, i__1, i__2;
8981     doublereal d__1;
8982
8983     /* Local variables */
8984     static integer ncut, i__;
8985     static doublereal bidon, error;
8986     static integer ia, nd;
8987     static doublereal bid, eps1;
8988
8989
8990 /* ***********************************************************************
8991  */
8992
8993 /*     FUNCTION : */
8994 /*     ---------- */
8995 /*        Lower the degree of a curve defined on (-1,1) in the direction of */
8996 /*        Legendre with a given precision. */
8997
8998 /*     KEYWORDS : */
8999 /*     ----------- */
9000 /*        LEGENDRE, POLYGON, TRUNCATION, CURVE, SMOOTHING. */
9001
9002 /*     INPUT ARGUMENTS : */
9003 /*     ------------------ */
9004 /*        NCOFMX : Max nb of coeff. of the curve (dimensioning). */
9005 /*        NDIMEN : Dimension of the space. */
9006 /*        NCOEFF : Degree +1 of the polynom. */
9007 /*        EPSI3D : Precision required for the approximation. */
9008 /*        CRVLGD : The curve the degree which of will be lowered. */
9009
9010 /*     OUTPUT ARGUMENTS : */
9011 /*     ------------------- */
9012 /*        YCVMAX : Auxiliary table (error max on each dimension).
9013 */
9014 /*        EPSTRC : Precision of the approximation. */
9015 /*        NCFNEW : Degree +1 of the resulting polynom. */
9016
9017 /*     COMMONS USED   : */
9018 /*     ---------------- */
9019
9020 /*     REFERENCES CALLED   : */
9021 /*     ----------------------- */
9022
9023 /*     DESCRIPTION/NOTES/LIMITATIONS : */
9024 /*     ----------------------------------- */
9025 /* > */
9026 /* ***********************************************************************
9027  */
9028
9029
9030     /* Parameter adjustments */
9031     --ycvmax;
9032     crvlgd_dim1 = *ncofmx;
9033     crvlgd_offset = crvlgd_dim1 + 1;
9034     crvlgd -= crvlgd_offset;
9035
9036     /* Function Body */
9037
9038
9039
9040 /*   Minimum degree that can be reached : Stop at IA (RBD). -------------
9041 */
9042     ia = 2;
9043     *ncfnew = ia;
9044 /* Init for calculation of error. */
9045     i__1 = *ndimen;
9046     for (i__ = 1; i__ <= i__1; ++i__) {
9047         ycvmax[i__] = 0.;
9048 /* L100: */
9049     }
9050     *epstrc = 0.;
9051     error = 0.;
9052
9053 /*   Cutting of coefficients. */
9054
9055     ncut = ia + 1;
9056 /* ------ Loop on the series of Jacobi :NCOEFF --> IA+1 (RBD) ----------
9057 */
9058     i__1 = ncut;
9059     for (i__ = *ncoeff; i__ >= i__1; --i__) {
9060 /*   Factor of renormalization. */
9061         bidon = xmaxj[i__ - ncut];
9062         i__2 = *ndimen;
9063         for (nd = 1; nd <= i__2; ++nd) {
9064             ycvmax[nd] += (d__1 = crvlgd[i__ + nd * crvlgd_dim1], abs(d__1)) *
9065                      bidon;
9066 /* L310: */
9067         }
9068 /*   One stops to cut if the norm becomes too great. */
9069         error = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
9070         if (error > *epsi3d) {
9071             *ncfnew = i__;
9072             goto L400;
9073         }
9074
9075 /* --- Max error cumulated when the I-th coeff is removed. */
9076
9077         *epstrc = error;
9078
9079 /* L300: */
9080     }
9081
9082 /* ------- Cutting of zero coeffs of interpolation (RBD) -------
9083 */
9084
9085 L400:
9086     if (*ncfnew == ia) {
9087         AdvApp2Var_MathBase::mmeps1_(&eps1);
9088         for (i__ = ia; i__ >= 2; --i__) {
9089             bid = 0.;
9090             i__1 = *ndimen;
9091             for (nd = 1; nd <= i__1; ++nd) {
9092                 bid += (d__1 = crvlgd[i__ + nd * crvlgd_dim1], abs(d__1));
9093 /* L600: */
9094             }
9095             if (bid > eps1) {
9096                 *ncfnew = i__;
9097                 goto L9999;
9098             }
9099 /* L500: */
9100         }
9101 /* --- If all coeffs can be removed, this is a point. */
9102         *ncfnew = 1;
9103     }
9104
9105 /* --------------------------------- End --------------------------------
9106 */
9107
9108 L9999:
9109     return 0;
9110 } /* mmtrpj2_ */
9111
9112 //=======================================================================
9113 //function : mmtrpj4_
9114 //purpose  :
9115 //=======================================================================
9116 int mmtrpj4_(integer *ncofmx,
9117              integer *ndimen,
9118              integer *ncoeff,
9119              doublereal *epsi3d,
9120              doublereal *crvlgd,
9121              doublereal *ycvmax,
9122              doublereal *epstrc,
9123              integer *ncfnew)
9124 {
9125     /* Initialized data */
9126
9127     static doublereal xmaxj[55] = { 1.1092649593311780079813740546678,
9128             1.05299572648705464724876659688996,
9129             1.0949715351434178709281698645813,
9130             1.15078388379719068145021100764647,
9131             1.2094863084718701596278219811869,
9132             1.26806623151369531323304177532868,
9133             1.32549784426476978866302826176202,
9134             1.38142537365039019558329304432581,
9135             1.43575531950773585146867625840552,
9136             1.48850442653629641402403231015299,
9137             1.53973611681876234549146350844736,
9138             1.58953193485272191557448229046492,
9139             1.63797820416306624705258190017418,
9140             1.68515974143594899185621942934906,
9141             1.73115699602477936547107755854868,
9142             1.77604489805513552087086912113251,
9143             1.81989256661534438347398400420601,
9144             1.86276344480103110090865609776681,
9145             1.90471563564740808542244678597105,
9146             1.94580231994751044968731427898046,
9147             1.98607219357764450634552790950067,
9148             2.02556989246317857340333585562678,
9149             2.06433638992049685189059517340452,
9150             2.10240936014742726236706004607473,
9151             2.13982350649113222745523925190532,
9152             2.17661085564771614285379929798896,
9153             2.21280102016879766322589373557048,
9154             2.2484214321456956597803794333791,
9155             2.28349755104077956674135810027654,
9156             2.31805304852593774867640120860446,
9157             2.35210997297725685169643559615022,
9158             2.38568889602346315560143377261814,
9159             2.41880904328694215730192284109322,
9160             2.45148841120796359750021227795539,
9161             2.48374387161372199992570528025315,
9162             2.5155912654873773953959098501893,
9163             2.54704548720896557684101746505398,
9164             2.57812056037881628390134077704127,
9165             2.60882970619319538196517982945269,
9166             2.63918540521920497868347679257107,
9167             2.66919945330942891495458446613851,
9168             2.69888301230439621709803756505788,
9169             2.72824665609081486737132853370048,
9170             2.75730041251405791603760003778285,
9171             2.78605380158311346185098508516203,
9172             2.81451587035387403267676338931454,
9173             2.84269522483114290814009184272637,
9174             2.87060005919012917988363332454033,
9175             2.89823818258367657739520912946934,
9176             2.92561704377132528239806135133273,
9177             2.95274375377994262301217318010209,
9178             2.97962510678256471794289060402033,
9179             3.00626759936182712291041810228171,
9180             3.03267744830655121818899164295959,
9181             3.05886060707437081434964933864149 };
9182
9183     /* System generated locals */
9184     integer crvlgd_dim1, crvlgd_offset, i__1, i__2;
9185     doublereal d__1;
9186
9187     /* Local variables */
9188     static integer ncut, i__;
9189     static doublereal bidon, error;
9190     static integer ia, nd;
9191     static doublereal bid, eps1;
9192
9193
9194
9195 /* ***********************************************************************
9196  */
9197
9198 /*     FUNCTION : */
9199 /*     ---------- */
9200 /*        Lowers the degree of a curve defined on (-1,1) in the direction of */
9201 /*        Legendre with a given precision. */
9202
9203 /*     KEYWORDS : */
9204 /*     ----------- */
9205 /*        LEGENDRE, POLYGON, TRONCATION, CURVE, SMOOTHING. */
9206
9207 /*     INPUT ARGUMENTS : */
9208 /*     ------------------ */
9209 /*        NCOFMX : Max nb of coeff. of the curve (dimensioning). */
9210 /*        NDIMEN : Dimension of the space. */
9211 /*        NCOEFF : Degree +1 of the polynom. */
9212 /*        EPSI3D : Precision required for the approximation. */
9213 /*        CRVLGD : The curve which wishes to lower the degree. */
9214
9215 /*     OUTPUT ARGUMENTS : */
9216 /*     ------------------- */
9217 /*        YCVMAX : Auxiliary table (max error on each dimension).
9218 */
9219 /*        EPSTRC : Precision of the approximation. */
9220 /*        NCFNEW : Degree +1 of the resulting polynom. */
9221
9222 /*     COMMONS USED   : */
9223 /*     ---------------- */
9224
9225 /*     REFERENCES CALLED   : */
9226 /*     ----------------------- */
9227
9228 /*     DESCRIPTION/NOTES/LIMITATIONS : */
9229 /*     ----------------------------------- */
9230 /* > */
9231 /* ***********************************************************************
9232  */
9233
9234
9235     /* Parameter adjustments */
9236     --ycvmax;
9237     crvlgd_dim1 = *ncofmx;
9238     crvlgd_offset = crvlgd_dim1 + 1;
9239     crvlgd -= crvlgd_offset;
9240
9241     /* Function Body */
9242
9243
9244
9245 /*   Minimum degree that can be reached : Stop at IA (RBD). -------------
9246 */
9247     ia = 4;
9248     *ncfnew = ia;
9249 /* Init for error calculation. */
9250     i__1 = *ndimen;
9251     for (i__ = 1; i__ <= i__1; ++i__) {
9252         ycvmax[i__] = 0.;
9253 /* L100: */
9254     }
9255     *epstrc = 0.;
9256     error = 0.;
9257
9258 /*   Cutting of coefficients. */
9259
9260     ncut = ia + 1;
9261 /* ------ Loop on the series of Jacobi :NCOEFF --> IA+1 (RBD) ----------
9262 */
9263     i__1 = ncut;
9264     for (i__ = *ncoeff; i__ >= i__1; --i__) {
9265 /*   Factor of renormalization. */
9266         bidon = xmaxj[i__ - ncut];
9267         i__2 = *ndimen;
9268         for (nd = 1; nd <= i__2; ++nd) {
9269             ycvmax[nd] += (d__1 = crvlgd[i__ + nd * crvlgd_dim1], abs(d__1)) *
9270                      bidon;
9271 /* L310: */
9272         }
9273 /*   Stop cutting if the norm becomes too great. */
9274         error = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
9275         if (error > *epsi3d) {
9276             *ncfnew = i__;
9277             goto L400;
9278         }
9279
9280 /* -- Error max cumulated when the I-eme coeff is removed. */
9281
9282         *epstrc = error;
9283
9284 /* L300: */
9285     }
9286
9287 /* ------- Cutting of zero coeffs of the pole of interpolation (RBD) -------
9288 */
9289
9290 L400:
9291     if (*ncfnew == ia) {
9292         AdvApp2Var_MathBase::mmeps1_(&eps1);
9293         for (i__ = ia; i__ >= 2; --i__) {
9294             bid = 0.;
9295             i__1 = *ndimen;
9296             for (nd = 1; nd <= i__1; ++nd) {
9297                 bid += (d__1 = crvlgd[i__ + nd * crvlgd_dim1], abs(d__1));
9298 /* L600: */
9299             }
9300             if (bid > eps1) {
9301                 *ncfnew = i__;
9302                 goto L9999;
9303             }
9304 /* L500: */
9305         }
9306 /* --- If all coeffs can be removed, this is a point. */
9307         *ncfnew = 1;
9308     }
9309
9310 /* --------------------------------- End --------------------------------
9311 */
9312
9313 L9999:
9314     return 0;
9315 } /* mmtrpj4_ */
9316
9317 //=======================================================================
9318 //function : mmtrpj6_
9319 //purpose  :
9320 //=======================================================================
9321 int mmtrpj6_(integer *ncofmx,
9322              integer *ndimen,
9323              integer *ncoeff,
9324              doublereal *epsi3d,
9325              doublereal *crvlgd,
9326              doublereal *ycvmax,
9327              doublereal *epstrc,
9328              integer *ncfnew)
9329
9330 {
9331     /* Initialized data */
9332
9333     static doublereal xmaxj[53] = { 1.21091229812484768570102219548814,
9334             1.11626917091567929907256116528817,
9335             1.1327140810290884106278510474203,
9336             1.1679452722668028753522098022171,
9337             1.20910611986279066645602153641334,
9338             1.25228283758701572089625983127043,
9339             1.29591971597287895911380446311508,
9340             1.3393138157481884258308028584917,
9341             1.3821288728999671920677617491385,
9342             1.42420414683357356104823573391816,
9343             1.46546895108549501306970087318319,
9344             1.50590085198398789708599726315869,
9345             1.54550385142820987194251585145013,
9346             1.58429644271680300005206185490937,
9347             1.62230484071440103826322971668038,
9348             1.65955905239130512405565733793667,
9349             1.69609056468292429853775667485212,
9350             1.73193098017228915881592458573809,
9351             1.7671112206990325429863426635397,
9352             1.80166107681586964987277458875667,
9353             1.83560897003644959204940535551721,
9354             1.86898184653271388435058371983316,
9355             1.90180515174518670797686768515502,
9356             1.93410285411785808749237200054739,
9357             1.96589749778987993293150856865539,
9358             1.99721027139062501070081653790635,
9359             2.02806108474738744005306947877164,
9360             2.05846864831762572089033752595401,
9361             2.08845055210580131460156962214748,
9362             2.11802334209486194329576724042253,
9363             2.14720259305166593214642386780469,
9364             2.17600297710595096918495785742803,
9365             2.20443832785205516555772788192013,
9366             2.2325216999457379530416998244706,
9367             2.2602654243075083168599953074345,
9368             2.28768115912702794202525264301585,
9369             2.3147799369092684021274946755348,
9370             2.34157220782483457076721300512406,
9371             2.36806787963276257263034969490066,
9372             2.39427635443992520016789041085844,
9373             2.42020656255081863955040620243062,
9374             2.44586699364757383088888037359254,
9375             2.47126572552427660024678584642791,
9376             2.49641045058324178349347438430311,
9377             2.52130850028451113942299097584818,
9378             2.54596686772399937214920135190177,
9379             2.5703922285006754089328998222275,
9380             2.59459096001908861492582631591134,
9381             2.61856915936049852435394597597773,
9382             2.64233265984385295286445444361827,
9383             2.66588704638685848486056711408168,
9384             2.68923766976735295746679957665724,
9385             2.71238965987606292679677228666411 };
9386
9387     /* System generated locals */
9388     integer crvlgd_dim1, crvlgd_offset, i__1, i__2;
9389     doublereal d__1;
9390
9391     /* Local variables */
9392     static integer ncut, i__;
9393     static doublereal bidon, error;
9394     static integer ia, nd;
9395     static doublereal bid, eps1;
9396
9397
9398
9399 /* ***********************************************************************
9400  */
9401
9402 /*     FUNCTION : */
9403 /*     ---------- */
9404 /*        Lowers the degree of a curve defined on (-1,1) in the direction of */
9405 /*        Legendre to a given precision. */
9406
9407 /*     KEYWORDS : */
9408 /*     ----------- */
9409 /*        LEGENDRE,POLYGON,TRUNCATION,CURVE,SMOOTHING. */
9410
9411 /*     INPUT ARGUMENTS : */
9412 /*     ------------------ */
9413 /*        NCOFMX : Max nb of coeff. of the curve (dimensioning). */
9414 /*        NDIMEN : Dimension of the space. */
9415 /*        NCOEFF : Degree +1 of the polynom. */
9416 /*        EPSI3D : Precision required for the approximation. */
9417 /*        CRVLGD : The curve the degree which of will be lowered. */
9418
9419 /*     OUTPUT ARGUMENTS : */
9420 /*     ------------------- */
9421 /*        YCVMAX : Auxiliary table (max error on each dimension).
9422 /*        EPSTRC : Precision of the approximation. */
9423 /*        NCFNEW : Degree +1 of the resulting polynom. */
9424
9425 /*     COMMONS USED   : */
9426 /*     ---------------- */
9427
9428 /*     REFERENCES CALLED   : */
9429 /*     ----------------------- */
9430
9431 /*     DESCRIPTION/NOTES/LIMITATIONS : */
9432 /*     ----------------------------------- */
9433 /* > */
9434 /* ***********************************************************************
9435  */
9436
9437
9438     /* Parameter adjustments */
9439     --ycvmax;
9440     crvlgd_dim1 = *ncofmx;
9441     crvlgd_offset = crvlgd_dim1 + 1;
9442     crvlgd -= crvlgd_offset;
9443
9444     /* Function Body */
9445
9446
9447
9448 /*   Minimum degree that can be reached : Stop at IA (RBD). -------------
9449 */
9450     ia = 6;
9451     *ncfnew = ia;
9452 /* Init for error calculation. */
9453     i__1 = *ndimen;
9454     for (i__ = 1; i__ <= i__1; ++i__) {
9455         ycvmax[i__] = 0.;
9456 /* L100: */
9457     }
9458     *epstrc = 0.;
9459     error = 0.;
9460
9461 /*   Cutting of coefficients. */
9462
9463     ncut = ia + 1;
9464 /* ------ Loop on the series of Jacobi :NCOEFF --> IA+1 (RBD) ----------
9465 */
9466     i__1 = ncut;
9467     for (i__ = *ncoeff; i__ >= i__1; --i__) {
9468 /*   Factor of renormalization. */
9469         bidon = xmaxj[i__ - ncut];
9470         i__2 = *ndimen;
9471         for (nd = 1; nd <= i__2; ++nd) {
9472             ycvmax[nd] += (d__1 = crvlgd[i__ + nd * crvlgd_dim1], abs(d__1)) *
9473                      bidon;
9474 /* L310: */
9475         }
9476 /*   Stop cutting if the norm becomes too great. */
9477         error = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
9478         if (error > *epsi3d) {
9479             *ncfnew = i__;
9480             goto L400;
9481         }
9482
9483 /* --- Max error cumulated when the I-th coeff is removed. */
9484
9485         *epstrc = error;
9486
9487 /* L300: */
9488     }
9489
9490 /* ------- Cutting of zero coeff. of the pole of interpolation (RBD) -------
9491 */
9492
9493 L400:
9494     if (*ncfnew == ia) {
9495         AdvApp2Var_MathBase::mmeps1_(&eps1);
9496         for (i__ = ia; i__ >= 2; --i__) {
9497             bid = 0.;
9498             i__1 = *ndimen;
9499             for (nd = 1; nd <= i__1; ++nd) {
9500                 bid += (d__1 = crvlgd[i__ + nd * crvlgd_dim1], abs(d__1));
9501 /* L600: */
9502             }
9503             if (bid > eps1) {
9504                 *ncfnew = i__;
9505                 goto L9999;
9506             }
9507 /* L500: */
9508         }
9509 /* --- If all coeffs can be removed, this is a point. */
9510         *ncfnew = 1;
9511     }
9512
9513 /* --------------------------------- End --------------------------------
9514 */
9515
9516 L9999:
9517     return 0;
9518 } /* mmtrpj6_ */
9519
9520 //=======================================================================
9521 //function : AdvApp2Var_MathBase::mmtrpjj_
9522 //purpose  :
9523 //=======================================================================
9524  int AdvApp2Var_MathBase::mmtrpjj_(integer *ncofmx,
9525                             integer *ndimen,
9526                             integer *ncoeff,
9527                             doublereal *epsi3d,
9528                             integer *iordre,
9529                             doublereal *crvlgd,
9530                             doublereal *ycvmax,
9531                             doublereal *errmax,
9532                             integer *ncfnew)
9533 {
9534     /* System generated locals */
9535     integer crvlgd_dim1, crvlgd_offset;
9536
9537     /* Local variables */
9538     static integer ia;
9539
9540
9541 /* ***********************************************************************
9542  */
9543
9544 /*     FUNCTION : */
9545 /*     ---------- */
9546 /*        Lower the degree of a curve defined on (-1,1) in the direction of */
9547 /*        Legendre with a given precision. */
9548
9549 /*     KEYWORDS : */
9550 /*     ----------- */
9551 /*        LEGENDRE, POLYGON, TRUNCATION, CURVE, SMOOTHING. */
9552
9553 /*     INPUT ARGUMENTS : */
9554 /*     ------------------ */
9555 /*        NCOFMX : Max Nb coeff. of the curve (dimensioning). */
9556 /*        NDIMEN : Dimension of the space. */
9557 /*        NCOEFF : Degree +1 of the polynom. */
9558 /*        EPSI3D : Precision required for the approximation. */
9559 /*        IORDRE : Order of continuity at the extremities. */
9560 /*        CRVLGD : The curve the degree which of should be lowered. */
9561
9562 /*     OUTPUT ARGUMENTS : */
9563 /*     ------------------- */
9564 /*        ERRMAX : Precision of the approximation. */
9565 /*        NCFNEW : Degree +1 of the resulting polynom. */
9566
9567 /*     COMMONS USED   : */
9568 /*     ---------------- */
9569
9570 /*     REFERENCES CALLED : */
9571 /*     ----------------------- */
9572
9573 /*     DESCRIPTION/NOTES/LIMITATIONS : */
9574 /*     ----------------------------------- */
9575 /* > */
9576 /* ***********************************************************************
9577  */
9578
9579
9580     /* Parameter adjustments */
9581     --ycvmax;
9582     crvlgd_dim1 = *ncofmx;
9583     crvlgd_offset = crvlgd_dim1 + 1;
9584     crvlgd -= crvlgd_offset;
9585
9586     /* Function Body */
9587     ia = (*iordre + 1) << 1;
9588
9589     if (ia == 0) {
9590         mmtrpj0_(ncofmx, ndimen, ncoeff, epsi3d, &crvlgd[crvlgd_offset], &
9591                 ycvmax[1], errmax, ncfnew);
9592     } else if (ia == 2) {
9593         mmtrpj2_(ncofmx, ndimen, ncoeff, epsi3d, &crvlgd[crvlgd_offset], &
9594                 ycvmax[1], errmax, ncfnew);
9595     } else if (ia == 4) {
9596         mmtrpj4_(ncofmx, ndimen, ncoeff, epsi3d, &crvlgd[crvlgd_offset], &
9597                 ycvmax[1], errmax, ncfnew);
9598     } else {
9599         mmtrpj6_(ncofmx, ndimen, ncoeff, epsi3d, &crvlgd[crvlgd_offset], &
9600                 ycvmax[1], errmax, ncfnew);
9601     }
9602
9603 /* ------------------------ End -----------------------------------------
9604 */
9605
9606     return 0;
9607 } /* mmtrpjj_ */
9608
9609 //=======================================================================
9610 //function : AdvApp2Var_MathBase::mmunivt_
9611 //purpose  :
9612 //=======================================================================
9613  int AdvApp2Var_MathBase::mmunivt_(integer *ndimen,
9614              doublereal *vector,
9615              doublereal *vecnrm,
9616              doublereal *epsiln,
9617              integer *iercod)
9618 {
9619
9620   static doublereal c_b2 = 10.;
9621
9622     /* System generated locals */
9623     integer i__1;
9624     doublereal d__1;
9625
9626     /* Local variables */
9627     static integer nchif, iunit, izero;
9628     static doublereal vnorm;
9629     static integer ii;
9630     static doublereal bid;
9631     static doublereal eps0;
9632
9633
9634
9635
9636 /* ***********************************************************************
9637  */
9638
9639 /*     FUNCTION : */
9640 /*     ---------- */
9641 /*        CALCULATE THE NORMAL VECTOR BASING ON ANY VECTOR */
9642 /*        WITH PRECISION GIVEN BY THE USER. */
9643
9644 /*     KEYWORDS : */
9645 /*     ----------- */
9646 /*        ALL, MATH_ACCES :: */
9647 /*        VECTEUR&, NORMALISATION, &VECTEUR */
9648
9649 /*     INPUT ARGUMENTS : */
9650 /*     ------------------ */
9651 /*        NDIMEN   : DIMENSION OF THE SPACE */
9652 /*        VECTOR   : VECTOR TO BE NORMED */
9653 /*        EPSILN   : EPSILON BELOW WHICH IT IS CONSIDERED THAT THE */
9654 /*                 NORM OF THE VECTOR IS NULL. IF EPSILN<=0, A DEFAULT VALUE */
9655 /*                 IS IMPOSED (10.D-17 ON VAX). */
9656
9657 /*     OUTPUT ARGUMENTS : */
9658 /*     ------------------- */
9659 /*        VECNRM : NORMED VECTOR */
9660 /*        IERCOD  101 : THE VECTOR IS NULL UP TO EPSILN. */
9661 /*                  0 : OK. */
9662
9663 /*     COMMONS USED   : */
9664 /*     ---------------- */
9665
9666 /*     REFERENCES CALLED   : */
9667 /*     ----------------------- */
9668
9669 /*     DESCRIPTION/NOTES/LIMITATIONS : */
9670 /*     ----------------------------------- */
9671 /*     VECTOR and VECNRM can be identic. */
9672
9673 /*     The norm of vector is calculated and each component is divided by
9674 /*     this norm. After this it is checked if all componentes of the */
9675 /*     vector except for one cost 0 with machine precision. In */
9676 /*     this case the quasi-null components are set to 0.D0. */
9677 /* > */
9678 /* ***********************************************************************
9679  */
9680
9681
9682     /* Parameter adjustments */
9683     --vecnrm;
9684     --vector;
9685
9686     /* Function Body */
9687     *iercod = 0;
9688
9689 /* -------- Precision by default : zero machine 10.D-17 on Vax ------
9690 */
9691
9692     AdvApp2Var_SysBase::maovsr8_(&nchif);
9693     if (*epsiln <= 0.) {
9694         i__1 = -nchif;
9695         eps0 = AdvApp2Var_MathBase::pow__di(&c_b2, &i__1);
9696     } else {
9697         eps0 = *epsiln;
9698     }
9699
9700 /* ------------------------- Calculation of the norm --------------------
9701 */
9702
9703     vnorm = AdvApp2Var_MathBase::mzsnorm_(ndimen, &vector[1]);
9704     if (vnorm <= eps0) {
9705         AdvApp2Var_SysBase::mvriraz_((integer *)ndimen, (char *)&vecnrm[1]);
9706         *iercod = 101;
9707         goto L9999;
9708     }
9709
9710 /* ---------------------- Calculation of the vector norm  ---------------
9711 */
9712
9713     izero = 0;
9714     i__1 = (-nchif - 1) / 2;
9715     eps0 = AdvApp2Var_MathBase::pow__di(&c_b2, &i__1);
9716     i__1 = *ndimen;
9717     for (ii = 1; ii <= i__1; ++ii) {
9718         vecnrm[ii] = vector[ii] / vnorm;
9719         if ((d__1 = vecnrm[ii], abs(d__1)) <= eps0) {
9720             ++izero;
9721         } else {
9722             iunit = ii;
9723         }
9724 /* L20: */
9725     }
9726
9727 /* ------ Case when all coordinates except for one are almost null ----
9728 */
9729 /* ------------- then one of coordinates costs 1.D0 or -1.D0 --------
9730 */
9731
9732     if (izero == *ndimen - 1) {
9733         bid = vecnrm[iunit];
9734         i__1 = *ndimen;
9735         for (ii = 1; ii <= i__1; ++ii) {
9736             vecnrm[ii] = 0.;
9737 /* L30: */
9738         }
9739         if (bid > 0.) {
9740             vecnrm[iunit] = 1.;
9741         } else {
9742             vecnrm[iunit] = -1.;
9743         }
9744     }
9745
9746 /* -------------------------------- The end -----------------------------
9747 */
9748
9749 L9999:
9750     return 0;
9751 } /* mmunivt_ */
9752
9753 //=======================================================================
9754 //function : AdvApp2Var_MathBase::mmveps3_
9755 //purpose  :
9756 //=======================================================================
9757  int AdvApp2Var_MathBase::mmveps3_(doublereal *eps03)
9758 {
9759   /* Initialized data */
9760
9761   static char nomprg[8+1] = "MMEPS1  ";
9762
9763   static integer ibb;
9764
9765
9766
9767 /************************************************************************
9768 *******/
9769
9770 /*     FUNCTION : */
9771 /*     ---------- */
9772 /*        Extraction of EPS1 from COMMON MPRCSN. */
9773
9774 /*     KEYWORDS : */
9775 /*     ----------- */
9776 /*        MPRCSN,PRECISON,EPS3. */
9777
9778 /*     INPUT ARGUMENTS : */
9779 /*     ------------------ */
9780 /*       Humm. */
9781
9782 /*     OUTPUT ARGUMENTS : */
9783 /*     ------------------- */
9784 /*        EPS3 :  space zero of the denominator (10**-9) */
9785 /*        EPS3 should value 10**-15 */
9786
9787 /*     COMMONS USED   : */
9788 /*     ---------------- */
9789
9790 /*     REFERENCES CALLED   : */
9791 /*     ----------------------- */
9792
9793 /*     DESCRIPTION/NOTES/LIMITATIONS : */
9794 /*     ----------------------------------- */
9795
9796 /* > */
9797 /* ***********************************************************************
9798  */
9799
9800
9801
9802 /* ***********************************************************************
9803  */
9804
9805 /*     FUNCTION : */
9806 /*     ---------- */
9807 /*          GIVES TOLERANCES OF NULLITY IN STRIM */
9808 /*          AND LIMITS OF ITERATIVE PROCESSES */
9809
9810 /*          GENERAL CONTEXT, MODIFIABLE BY THE UTILISER */
9811
9812 /*     KEYWORDS : */
9813 /*     ----------- */
9814 /*          PARAMETER , TOLERANCE */
9815
9816 /*     DESCRIPTION/NOTES/LIMITATIONS : */
9817 /*     ----------------------------------- */
9818 /*       INITIALISATION   :  PROFILE , **VIA MPRFTX** AT INPUT IN STRIM*/
9819 /*       LOADING OF DEFAULT VALUES OF THE PROFILE IN MPRFTX AT INPUT*/
9820 /*       IN STRIM. THEY ARE PRESERVED IN THE LOCAL VARIABLES OF MPRFTX */
9821
9822 /*        RESET DEFAULT VALUES                   : MDFINT */
9823 /*        MODIFICATION INTERACTIVE BY THE USER   : MDBINT */
9824
9825 /*        ACCESS FUNCTION  :  MMEPS1  ...  EPS1 */
9826 /*                            MEPSPB  ...  EPS3,EPS4 */
9827 /*                            MEPSLN  ...  EPS2, NITERM , NITERR */
9828 /*                            MEPSNR  ...  EPS2 , NITERM */
9829 /*                            MITERR  ...  NITERR */
9830
9831 /* > */
9832 /* ***********************************************************************
9833  */
9834
9835 /*     NITERM : MAX NB OF ITERATIONS */
9836 /*     NITERR : NB OF RAPID ITERATIONS */
9837 /*     EPS1   : TOLERANCE OF 3D NULL DISTANCE */
9838 /*     EPS2   : TOLERANCE OF ZERO PARAMETRIC DISTANCE */
9839 /*     EPS3   : TOLERANCE TO AVOID DIVISION BY 0.. */
9840 /*     EPS4   : TOLERANCE ANGULAR */
9841
9842
9843
9844 /* ***********************************************************************
9845  */
9846
9847     ibb = AdvApp2Var_SysBase::mnfndeb_();
9848     if (ibb >= 5) {
9849         AdvApp2Var_SysBase::mgenmsg_(nomprg, 6L);
9850     }
9851
9852     *eps03 = mmprcsn_.eps3;
9853
9854     return 0;
9855 } /* mmveps3_ */
9856
9857 //=======================================================================
9858 //function : AdvApp2Var_MathBase::mmvncol_
9859 //purpose  :
9860 //=======================================================================
9861  int AdvApp2Var_MathBase::mmvncol_(integer *ndimen,
9862                             doublereal *vecin,
9863                             doublereal *vecout,
9864                             integer *iercod)
9865
9866 {
9867   /* System generated locals */
9868   integer i__1;
9869
9870   /* Local variables */
9871   static logical ldbg;
9872   static integer d__;
9873   static doublereal vaux1[3], vaux2[3];
9874   static logical colin;
9875   static doublereal valaux;
9876   static integer aux;
9877   static logical nul;
9878
9879 /* ***********************************************************************
9880  */
9881
9882 /*     FUNCTION : */
9883 /*     ---------- */
9884 /*       CALCULATE A VECTOR NON-COLINEAR TO A GIVEN NON-NULL VECTOR */
9885
9886 /*     KEYWORDS : */
9887 /*     ----------- */
9888 /*      PUBLIC, VECTOR, FREE */
9889
9890 /*     INPUT ARGUMENTS  : */
9891 /*     -------------------- */
9892 /*       ndimen : dimension of the space */
9893 /*       vecin  : input vector */
9894
9895 /*     OUTPUT ARGUMENTS : */
9896 /*     --------------------- */
9897
9898 /*       vecout : vector non colinear to vecin */
9899
9900 /*     COMMONS USED : */
9901 /*     ------------------ */
9902
9903
9904 /*     REFERENCES CALLED : */
9905 /*     --------------------- */
9906
9907
9908 /*     DESCRIPTION/NOTES/LIMITATIONS : */
9909 /*     ----------------------------------- */
9910 /* > */
9911 /* ***********************************************************************
9912  */
9913 /*                            DECLARATIONS */
9914 /* ***********************************************************************
9915  */
9916
9917
9918
9919 /* ***********************************************************************
9920  */
9921 /*                      INITIALISATIONS */
9922 /* ***********************************************************************
9923  */
9924
9925     /* Parameter adjustments */
9926     --vecout;
9927     --vecin;
9928
9929     /* Function Body */
9930     ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 2;
9931     if (ldbg) {
9932         AdvApp2Var_SysBase::mgenmsg_("MMVNCOL", 7L);
9933     }
9934     *iercod = 0;
9935
9936 /* ***********************************************************************
9937  */
9938 /*                     PROCESSING */
9939 /* ***********************************************************************
9940  */
9941
9942     if (*ndimen <= 1 || *ndimen > 3) {
9943         goto L9101;
9944     }
9945     nul = FALSE_;
9946     d__ = 1;
9947     aux = 0;
9948     while(d__ <= *ndimen) {
9949         if (vecin[d__] == 0.) {
9950             ++aux;
9951         }
9952         ++d__;
9953     }
9954     if (aux == *ndimen) {
9955         goto L9101;
9956     }
9957
9958
9959     for (d__ = 1; d__ <= 3; ++d__) {
9960         vaux1[d__ - 1] = 0.;
9961     }
9962     i__1 = *ndimen;
9963     for (d__ = 1; d__ <= i__1; ++d__) {
9964         vaux1[d__ - 1] = vecin[d__];
9965         vaux2[d__ - 1] = vecin[d__];
9966     }
9967     colin = TRUE_;
9968     d__ = 0;
9969     while(colin) {
9970         ++d__;
9971         if (d__ > 3) {
9972             goto L9101;
9973         }
9974         vaux2[d__ - 1] += 1;
9975         valaux = vaux1[1] * vaux2[2] - vaux1[2] * vaux2[1];
9976         if (valaux == 0.) {
9977             valaux = vaux1[2] * vaux2[0] - vaux1[0] * vaux2[2];
9978             if (valaux == 0.) {
9979                 valaux = vaux1[0] * vaux2[1] - vaux1[1] * vaux2[0];
9980                 if (valaux != 0.) {
9981                     colin = FALSE_;
9982                 }
9983             } else {
9984                 colin = FALSE_;
9985             }
9986         } else {
9987             colin = FALSE_;
9988         }
9989     }
9990     if (colin) {
9991         goto L9101;
9992     }
9993     i__1 = *ndimen;
9994     for (d__ = 1; d__ <= i__1; ++d__) {
9995         vecout[d__] = vaux2[d__ - 1];
9996     }
9997
9998     goto L9999;
9999
10000 /* ***********************************************************************
10001  */
10002 /*                   ERROR PROCESSING */
10003 /* ***********************************************************************
10004  */
10005
10006
10007 L9101:
10008     *iercod = 1;
10009     goto L9999;
10010
10011
10012 /* ***********************************************************************
10013  */
10014 /*                   RETURN CALLING PROGRAM */
10015 /* ***********************************************************************
10016  */
10017
10018 L9999:
10019
10020
10021     AdvApp2Var_SysBase::maermsg_("MMVNCOL", iercod, 7L);
10022     if (ldbg) {
10023         AdvApp2Var_SysBase::mgsomsg_("MMVNCOL", 7L);
10024     }
10025  return 0 ;
10026 } /* mmvncol_ */
10027
10028 //=======================================================================
10029 //function : AdvApp2Var_MathBase::mmwprcs_
10030 //purpose  :
10031 //=======================================================================
10032 void AdvApp2Var_MathBase::mmwprcs_(doublereal *epsil1,
10033                                    doublereal *epsil2,
10034                                    doublereal *epsil3,
10035                                    doublereal *epsil4,
10036                                    integer *niter1,
10037                                    integer *niter2)
10038
10039 {
10040
10041
10042 /* ***********************************************************************
10043  */
10044
10045 /*     FUNCTION : */
10046 /*     ---------- */
10047 /*     ACCESS IN WRITING FOR COMMON MPRCSN */
10048
10049 /*     KEYWORDS : */
10050 /*     ----------- */
10051 /*     WRITING */
10052
10053 /*     INPUT ARGUMENTS : */
10054 /*     -------------------- */
10055 /*     EPSIL1  : TOLERANCE OF 3D NULL DISTANCE */
10056 /*     EPSIL2  : TOLERANCE OF PARAMETRIC NULL DISTANCE */
10057 /*     EPSIL3  : TOLERANCE TO AVOID DIVISION BY 0.. */
10058 /*     EPSIL4  : ANGULAR TOLERANCE */
10059 /*     NITER1  : MAX NB OF ITERATIONS */
10060 /*     NITER2  : NB OF RAPID ITERATIONS */
10061
10062 /*     OUTPUT ARGUMENTS : */
10063 /*     --------------------- */
10064 /*     NONE */
10065
10066 /*     COMMONS USED : */
10067 /*     ------------------ */
10068
10069
10070 /*     REFERENCES CALLED : */
10071 /*     --------------------- */
10072
10073
10074 /*     DESCRIPTION/NOTES/LIMITATIONS : */
10075 /*     ----------------------------------- */
10076
10077 /* > */
10078 /* ***********************************************************************
10079  */
10080 /*                            DECLARATIONS */
10081 /* ***********************************************************************
10082  */
10083
10084
10085 /* ***********************************************************************
10086  */
10087 /*                      INITIALIZATIONS */
10088 /* ***********************************************************************
10089  */
10090
10091 /* ***********************************************************************
10092  */
10093 /*                      PROCESSING */
10094 /* ***********************************************************************
10095  */
10096
10097 /* ***********************************************************************
10098  */
10099
10100 /*     FUNCTION : */
10101 /*     ---------- */
10102 /*          GIVES TOLERANCES OF NULLITY IN STRIM */
10103 /*          AND  LIMITS OF ITERATIVE PROCESSES */
10104
10105 /*          GENERAL CONTEXT, MODIFIABLE BY THE UTILISER */
10106
10107 /*     KEYWORDS : */
10108 /*     ----------- */
10109 /*          PARAMETER , TOLERANCE */
10110
10111 /*     DESCRIPTION/NOTES/LIMITATIONS : */
10112 /*     ----------------------------------- */
10113 /*       INITIALISATION   :  PROFILE , **VIA MPRFTX** AT INPUT IN STRIM*/
10114 /*       LOADING OF DEFAULT VALUES OF THE PROFILE IN MPRFTX AT INPUT*/
10115 /*       IN STRIM. THEY ARE PRESERVED IN THE LOCAL VARIABLES OF MPRFTX */
10116
10117 /*        RESET DEFAULT VALUES                   : MDFINT */
10118 /*        MODIFICATION INTERACTIVE BY THE USER   : MDBINT */
10119
10120 /*        ACCESS FUNCTION  :  MMEPS1  ...  EPS1 */
10121 /*                            MEPSPB  ...  EPS3,EPS4 */
10122 /*                            MEPSLN  ...  EPS2, NITERM , NITERR */
10123 /*                            MEPSNR  ...  EPS2 , NITERM */
10124 /*                            MITERR  ...  NITERR */
10125
10126 /* > */
10127 /* ***********************************************************************
10128  */
10129
10130 /*     NITERM : MAX NB OF ITERATIONS */
10131 /*     NITERR : NB OF RAPID ITERATIONS */
10132 /*     EPS1   : TOLERANCE OF 3D NULL DISTANCE */
10133 /*     EPS2   : TOLERANCE OF ZERO PARAMETRIC DISTANCE */
10134 /*     EPS3   : TOLERANCE TO AVOID DIVISION BY 0.. */
10135 /*     EPS4   : TOLERANCE ANGULAR */
10136
10137
10138 /* ***********************************************************************
10139  */
10140     mmprcsn_.eps1 = *epsil1;
10141     mmprcsn_.eps2 = *epsil2;
10142     mmprcsn_.eps3 = *epsil3;
10143     mmprcsn_.eps4 = *epsil4;
10144     mmprcsn_.niterm = *niter1;
10145     mmprcsn_.niterr = *niter2;
10146  return ;
10147 } /* mmwprcs_  */
10148
10149
10150 //=======================================================================
10151 //function : AdvApp2Var_MathBase::pow__di
10152 //purpose  :
10153 //=======================================================================
10154  doublereal AdvApp2Var_MathBase::pow__di (doublereal *x,
10155                                    integer *n)
10156 {
10157
10158   register integer ii ;
10159   doublereal result ;
10160   integer    absolute ;
10161   result = 1.0e0 ;
10162   if ( *n > 0 ) {absolute = *n;}
10163   else {absolute = -*n;}
10164     /* System generated locals */
10165   for(ii = 0 ; ii < absolute ; ii++) {
10166       result *=  *x ;
10167    }
10168   if (*n < 0) {
10169    result = 1.0e0 / result ;
10170  }
10171  return result ;
10172 }
10173
10174
10175 /* **********************************************************************
10176 */
10177
10178 /*     FUNCTION : */
10179 /*     ---------- */
10180 /*        Calculate integer function power not obligatory in the most efficient way ;
10181 */
10182
10183 /*     KEYWORDS : */
10184 /*     ----------- */
10185 /*       POWER */
10186
10187 /*     INPUT ARGUMENTS : */
10188 /*     ------------------ */
10189 /*        X      :  argument of X**N */
10190 /*        N      :  power */
10191
10192 /*     OUTPUT ARGUMENTS : */
10193 /*     ------------------- */
10194 /*        return X**N */
10195
10196 /*     COMMONS USED   : */
10197 /*     ---------------- */
10198
10199 /*     REFERENCES CALLED   : */
10200 /*     ----------------------- */
10201
10202 /*     DESCRIPTION/NOTES/LIMITATIONS : */
10203 /*     ----------------------------------- */
10204
10205 /* > */
10206 /* ***********************************************************************/
10207
10208 //=======================================================================
10209 //function : pow__ii
10210 //purpose  :
10211 //=======================================================================
10212 integer pow__ii(integer *x,
10213                 integer *n)
10214
10215 {
10216   register integer ii ;
10217   integer result ;
10218   integer    absolute ;
10219   result = 1 ;
10220   if ( *n > 0 ) {absolute = *n;}
10221   else {absolute = -*n;}
10222     /* System generated locals */
10223   for(ii = 0 ; ii < absolute ; ii++) {
10224       result *=  *x ;
10225    }
10226   if (*n < 0) {
10227    result = 1 / result ;
10228  }
10229  return result ;
10230 }
10231
10232
10233 /* **********************************************************************
10234 */
10235 /* **********************************************************************
10236 */
10237
10238 /*     FUNCTION : */
10239 /*     ---------- */
10240 /*        Calculate integer function power not obligatory in the most efficient way ;
10241 */
10242
10243 /*     KEYWORDS : */
10244 /*     ----------- */
10245 /*       POWER */
10246
10247 /*     INPUT ARGUMENTS : */
10248 /*     ------------------ */
10249 /*        X      :  argument of X**N */
10250 /*        N      :  power */
10251
10252 /*     OUTPUT ARGUMENTS : */
10253 /*     ------------------- */
10254 /*        return X**N */
10255
10256 /*     COMMONS USED   : */
10257 /*     ---------------- */
10258
10259 /*     REFERENCES CALLED   : */
10260 /*     ----------------------- */
10261
10262 /*     DESCRIPTION/NOTES/LIMITATIONS : */
10263 /*     ----------------------------------- */
10264
10265 /* > */
10266 /* ***********************************************************************/
10267
10268 //=======================================================================
10269 //function : AdvApp2Var_MathBase::msc_
10270 //purpose  :
10271 //=======================================================================
10272  doublereal AdvApp2Var_MathBase::msc_(integer *ndimen,
10273                                doublereal *vecte1,
10274                                doublereal *vecte2)
10275
10276 {
10277   /* System generated locals */
10278   integer i__1;
10279   doublereal ret_val;
10280
10281   /* Local variables */
10282   static integer i__;
10283   static doublereal x;
10284
10285
10286
10287 /************************************************************************
10288 *******/
10289
10290 /*     FUNCTION : */
10291 /*     ---------- */
10292 /*        Calculate the scalar product of 2 vectors in the space */
10293 /*        of dimension NDIMEN. */
10294
10295 /*     KEYWORDS : */
10296 /*     ----------- */
10297 /*        PRODUCT MSCALAIRE. */
10298
10299 /*     INPUT ARGUMENTS  : */
10300 /*     ------------------ */
10301 /*        NDIMEN : Dimension of the space. */
10302 /*        VECTE1,VECTE2: Vectors. */
10303
10304 /*     OUTPUT ARGUMENTS : */
10305 /*     ------------------- */
10306
10307 /*     COMMONS USED     : */
10308 /*     ---------------- */
10309
10310 /*     REFERENCES CALLED : */
10311 /*     ----------------------- */
10312
10313 /*     DESCRIPTION/NOTES/LIMITATIONS : */
10314 /*     ----------------------------------- */
10315
10316 /* > */
10317 /* ***********************************************************************
10318  */
10319
10320
10321 /*     PRODUIT MSCALAIRE */
10322     /* Parameter adjustments */
10323     --vecte2;
10324     --vecte1;
10325
10326     /* Function Body */
10327     x = 0.;
10328
10329     i__1 = *ndimen;
10330     for (i__ = 1; i__ <= i__1; ++i__) {
10331         x += vecte1[i__] * vecte2[i__];
10332 /* L100: */
10333     }
10334     ret_val = x;
10335
10336 /* ----------------------------------- THE END --------------------------
10337 */
10338
10339     return ret_val;
10340 } /* msc_ */
10341
10342 //=======================================================================
10343 //function : mvcvin2_
10344 //purpose  :
10345 //=======================================================================
10346 int mvcvin2_(integer *ncoeff,
10347              doublereal *crvold,
10348              doublereal *crvnew,
10349              integer *iercod)
10350
10351 {
10352   /* System generated locals */
10353   integer i__1, i__2;
10354
10355   /* Local variables */
10356   static integer m1jm1, ncfm1, j, k;
10357   static doublereal bid;
10358   static doublereal cij1, cij2;
10359
10360
10361
10362 /************************************************************************
10363 *******/
10364
10365 /*     FONCTION : */
10366 /*     ---------- */
10367 /*        INVERSION OF THE PARAMETERS ON CURVE 2D. */
10368
10369 /*     KEYWORDS : */
10370 /*     ----------- */
10371 /*        CURVE,2D,INVERSION,PARAMETER. */
10372
10373 /*     INPUT ARGUMENTS : */
10374 /*     ------------------ */
10375 /*        NCOEFF   : NB OF COEFF OF THE CURVE. */
10376 /*        CRVOLD   : CURVE OF ORIGIN */
10377
10378 /*     OUTPUT ARGUMENTS : */
10379 /*     ------------------- */
10380 /*        CRVNEW   : THE RESULTING CURVE AFTER CHANGE OF T BY 1-T */
10381 /*        IERCOD   :  0 OK, */
10382 /*                   10 NB OF COEFF NULL OR TOO GREAT. */
10383
10384 /*     COMMONS USED   : */
10385 /*     ---------------- */
10386 /*    MCCNP */
10387
10388 /*     REFERENCES CALLED   : */
10389 /*     ---------------------- */
10390 /*            Neant */
10391 /*     DESCRIPTION/NOTES/LIMITATIONS : */
10392 /*     ----------------------------------- */
10393 /*     THE FOLLOWING CALL IS ABSOLUTELY LEGAL : */
10394 /*          CALL MVCVIN2(NCOEFF,CURVE,CURVE,IERCOD), THE TABLE CURVE */
10395 /*     BECOMES INPUT AND OUTPUT ARGUMENT (RBD). */
10396 /*     BECAUSE OF MCCNP, THE NB OF COEFF OF THE CURVE IS LIMITED TO */
10397 /*     NDGCNP+1 = 61. */
10398
10399 /* > */
10400 /* ***********************************************************************
10401  */
10402
10403
10404 /* **********************************************************************
10405 */
10406
10407 /*     FUNCTION : */
10408 /*     ---------- */
10409 /*      Serves to provide coefficients of the binome (triangle of Pascal). */
10410
10411 /*     KEYWORDS : */
10412 /*     ----------- */
10413 /*      Coeff of binome from 0 to 60. read only . init par block data */
10414
10415 /*     DEMSCRIPTION/NOTES/LIMITATIONS : */
10416 /*     ----------------------------------- */
10417 /*     The coefficients of the binome form a triangular matrix. */
10418 /*     This matrix is completed in table CNP by transposition. */
10419 /*     So: CNP(I,J) = CNP(J,I) for I and J = 0, ..., 60. */
10420
10421 /*     Initialization is done by block-data MMLLL09.RES, */
10422 /*     created by program MQINICNP.FOR (see the team (AC) ). */
10423
10424
10425 /* > */
10426 /* **********************************************************************
10427 */
10428
10429
10430
10431 /* ***********************************************************************
10432  */
10433
10434     /* Parameter adjustments */
10435     crvnew -= 3;
10436     crvold -= 3;
10437
10438     /* Function Body */
10439     if (*ncoeff < 1 || *ncoeff - 1 > 60) {
10440         *iercod = 10;
10441         goto L9999;
10442     }
10443     *iercod = 0;
10444
10445
10446 /* CONSTANT TERM OF THE NEW CURVE */
10447
10448     cij1 = crvold[3];
10449     cij2 = crvold[4];
10450     i__1 = *ncoeff;
10451     for (k = 2; k <= i__1; ++k) {
10452         cij1 += crvold[(k << 1) + 1];
10453         cij2 += crvold[(k << 1) + 2];
10454     }
10455     crvnew[3] = cij1;
10456     crvnew[4] = cij2;
10457     if (*ncoeff == 1) {
10458         goto L9999;
10459     }
10460
10461 /* INTERMEDIARY POWERS OF THE PARAMETER */
10462
10463     ncfm1 = *ncoeff - 1;
10464     m1jm1 = 1;
10465     i__1 = ncfm1;
10466     for (j = 2; j <= i__1; ++j) {
10467         m1jm1 = -m1jm1;
10468         cij1 = crvold[(j << 1) + 1];
10469         cij2 = crvold[(j << 1) + 2];
10470         i__2 = *ncoeff;
10471         for (k = j + 1; k <= i__2; ++k) {
10472             bid = mmcmcnp_.cnp[k - 1 + (j - 1) * 61];
10473             cij1 += crvold[(k << 1) + 1] * bid;
10474             cij2 += crvold[(k << 1) + 2] * bid;
10475         }
10476         crvnew[(j << 1) + 1] = cij1 * m1jm1;
10477         crvnew[(j << 1) + 2] = cij2 * m1jm1;
10478     }
10479
10480 /* TERM OF THE HIGHEST  DEGREE */
10481
10482     crvnew[(*ncoeff << 1) + 1] = -crvold[(*ncoeff << 1) + 1] * m1jm1;
10483     crvnew[(*ncoeff << 1) + 2] = -crvold[(*ncoeff << 1) + 2] * m1jm1;
10484
10485 L9999:
10486     if (*iercod > 0) {
10487         AdvApp2Var_SysBase::maermsg_("MVCVIN2", iercod, 7L);
10488     }
10489  return 0 ;
10490 } /* mvcvin2_ */
10491
10492 //=======================================================================
10493 //function : mvcvinv_
10494 //purpose  :
10495 //=======================================================================
10496 int mvcvinv_(integer *ncoeff,
10497              doublereal *crvold,
10498              doublereal *crvnew,
10499              integer *iercod)
10500
10501 {
10502   /* System generated locals */
10503   integer i__1, i__2;
10504
10505   /* Local variables */
10506   static integer m1jm1, ncfm1, j, k;
10507   static doublereal bid;
10508   //extern /* Subroutine */ int maermsg_();
10509   static doublereal cij1, cij2, cij3;
10510
10511
10512 /* **********************************************************************
10513 */
10514
10515 /*     FUNCTION : */
10516 /*     ---------- */
10517 /*        INVERSION OF THE PARAMETER ON A CURBE 3D (I.E. INVERSION */
10518 /*        OF THE DIRECTION OF PARSING). */
10519
10520 /*     KEYWORDS : */
10521 /*     ----------- */
10522 /*        CURVE,INVERSION,PARAMETER. */
10523
10524 /*     INPUT ARGUMENTS : */
10525 /*     ------------------ */
10526 /*        NCOEFF   : NB OF COEFF OF THE CURVE. */
10527 /*        CRVOLD   : CURVE OF ORIGIN */
10528
10529 /*     OUTPUT ARGUMENTS : */
10530 /*     ------------------- */
10531 /*        CRVNEW   : RESULTING CURVE AFTER CHANGE OF T INTO 1-T */
10532 /*        IERCOD   :  0 OK, */
10533 /*                   10 NB OF COEFF NULL OR TOO GREAT. */
10534
10535 /*     COMMONS USED   : */
10536 /*     ---------------- */
10537 /*    MCCNP */
10538
10539 /*     REFERENCES CALLED   : */
10540 /*     ---------------------- */
10541 /*            Neant */
10542 /*     DESCRIPTION/NOTES/LIMITATIONS : */
10543 /*     ----------------------------------- */
10544 /*     THE FOLLOWING CALL IS ABSOLUTELY LEGAL : */
10545 /*          CALL MVCVINV(NCOEFF,CURVE,CURVE,IERCOD), TABLE CURVE */
10546 /*     BECOMES INPUT AND OUTPUT ARGUMENT (RBD). */
10547 /*     THE NUMBER OF COEFF OF THE CURVE IS LIMITED TO NDGCNP+1 = 61 */
10548 /*     BECAUSE OF USE OF COMMON MCCNP. */
10549 /* > */
10550 /* ***********************************************************************
10551  */
10552
10553 /* **********************************************************************
10554 */
10555
10556 /*     FUNCTION : */
10557 /*     ---------- */
10558 /*      Serves to provide the binomial coefficients (triangle of Pascal). */
10559
10560 /*     KEYWORDS : */
10561 /*     ----------- */
10562 /*      Binomial Coeff from 0 to 60. read only . init par block data */
10563
10564 /*     DEMSCRIPTION/NOTES/LIMITATIONS : */
10565 /*     ----------------------------------- */
10566 /*     The binomial coefficients form a triangular matrix. */
10567 /*     This matrix is completed in table CNP by its transposition. */
10568 /*     So: CNP(I,J) = CNP(J,I) for I and J = 0, ..., 60. */
10569
10570 /*     Initialisation is done by block-data MMLLL09.RES, */
10571 /*     created by program MQINICNP.FOR (see the team (AC) ). */
10572 /* > */
10573 /* **********************************************************************
10574 */
10575
10576
10577
10578 /* ***********************************************************************
10579  */
10580
10581     /* Parameter adjustments */
10582     crvnew -= 4;
10583     crvold -= 4;
10584
10585     /* Function Body */
10586     if (*ncoeff < 1 || *ncoeff - 1 > 60) {
10587         *iercod = 10;
10588         goto L9999;
10589     }
10590     *iercod = 0;
10591
10592 /* CONSTANT TERM OF THE NEW CURVE */
10593
10594     cij1 = crvold[4];
10595     cij2 = crvold[5];
10596     cij3 = crvold[6];
10597     i__1 = *ncoeff;
10598     for (k = 2; k <= i__1; ++k) {
10599         cij1 += crvold[k * 3 + 1];
10600         cij2 += crvold[k * 3 + 2];
10601         cij3 += crvold[k * 3 + 3];
10602 /* L30: */
10603     }
10604     crvnew[4] = cij1;
10605     crvnew[5] = cij2;
10606     crvnew[6] = cij3;
10607     if (*ncoeff == 1) {
10608         goto L9999;
10609     }
10610
10611 /* INTERMEDIARY POWER OF THE PARAMETER */
10612
10613     ncfm1 = *ncoeff - 1;
10614     m1jm1 = 1;
10615     i__1 = ncfm1;
10616     for (j = 2; j <= i__1; ++j) {
10617         m1jm1 = -m1jm1;
10618         cij1 = crvold[j * 3 + 1];
10619         cij2 = crvold[j * 3 + 2];
10620         cij3 = crvold[j * 3 + 3];
10621         i__2 = *ncoeff;
10622         for (k = j + 1; k <= i__2; ++k) {
10623             bid = mmcmcnp_.cnp[k - 1 + (j - 1) * 61];
10624             cij1 += crvold[k * 3 + 1] * bid;
10625             cij2 += crvold[k * 3 + 2] * bid;
10626             cij3 += crvold[k * 3 + 3] * bid;
10627 /* L40: */
10628         }
10629         crvnew[j * 3 + 1] = cij1 * m1jm1;
10630         crvnew[j * 3 + 2] = cij2 * m1jm1;
10631         crvnew[j * 3 + 3] = cij3 * m1jm1;
10632 /* L50: */
10633     }
10634
10635     /* TERM OF THE HIGHEST DEGREE */
10636
10637     crvnew[*ncoeff * 3 + 1] = -crvold[*ncoeff * 3 + 1] * m1jm1;
10638     crvnew[*ncoeff * 3 + 2] = -crvold[*ncoeff * 3 + 2] * m1jm1;
10639     crvnew[*ncoeff * 3 + 3] = -crvold[*ncoeff * 3 + 3] * m1jm1;
10640
10641 L9999:
10642     AdvApp2Var_SysBase::maermsg_("MVCVINV", iercod, 7L);
10643     return 0;
10644 } /* mvcvinv_ */
10645
10646 //=======================================================================
10647 //function : mvgaus0_
10648 //purpose  :
10649 //=======================================================================
10650 int mvgaus0_(integer *kindic,
10651              doublereal *urootl,
10652              doublereal *hiltab,
10653              integer *nbrval,
10654              integer *iercod)
10655
10656 {
10657     /* System generated locals */
10658     integer i__1;
10659
10660     /* Local variables */
10661     static doublereal tamp[40];
10662     static integer ndegl, kg, ii;
10663
10664 /* **********************************************************************
10665 */
10666
10667 /*      FUNCTION : */
10668 /*      -------- */
10669 /*  Loading of a degree gives roots of LEGENDRE polynom */
10670 /*  DEFINED on [-1,1] and weights of Gauss quadrature formulas */
10671 /*  (based on corresponding LAGRANGIAN interpolators). */
10672 /*  The symmetry relative to 0 is used between [-1,0] and [0,1]. */
10673
10674 /*      KEYWORDS : */
10675 /*      --------- */
10676 /*         . VOLUMIC, LEGENDRE, LAGRANGE, GAUSS */
10677
10678 /*      INPUT ARGUMENTSE : */
10679 /*      ------------------ */
10680
10681 /*  KINDIC : Takes values from 1 to 10 depending of the degree */
10682 /*           of the used polynom. */
10683 /*           The degree of the polynom is equal to 4 k, i.e. 4, 8, */
10684 /*           12, 16, 20, 24, 28, 32, 36 and 40. */
10685
10686 /*      OUTPUT ARGUMENTS : */
10687 /*      ------------------- */
10688
10689 /*  UROOTL : Roots of LEGENDRE polynom in domain [1,0] */
10690 /*           given in decreasing order. For domain [-1,0], it is */
10691 /*           necessary to take the opposite values. */
10692 /*  HILTAB : LAGRANGE interpolators associated to roots. For */
10693 /*           opposed roots, interpolatorsare equal. */
10694 /*  NBRVAL : Nb of coefficients. Is equal to the half of degree */
10695 /*           depending on the symmetry (i.e. 2*KINDIC). */
10696
10697 /*  IERCOD  :  Error code: */
10698 /*          < 0 ==> Attention - Warning */
10699 /*          =-1 ==> Value of false KINDIC. NBRVAL is forced to 20 */
10700 /*                  (order 40) */
10701 /*          = 0 ==> Everything is OK */
10702
10703 /*      COMMON USED : */
10704 /*      ---------------- */
10705
10706 /*      REFERENCES CALLED : */
10707 /*      ------------------- */
10708
10709 /*      DESCRIPTION/NOTES/LIMITATIONS : */
10710 /*      --------------------------------- */
10711 /*      If KINDIC is not correct (i.e < 1 or > 10), the degree is set */
10712 /*      to 40 directly (ATTENTION to overload - to avoid it, */
10713 /*      preview UROOTL and HILTAB dimensioned at least to 20). */
10714
10715 /*      The value of coefficients was calculated with quadruple precision
10716 /*      by JJM with help of GD. */
10717 /*      Checking of roots was done by GD. */
10718
10719 /*      See detailed explications on the listing */
10720 /* > */
10721 /* **********************************************************************
10722 */
10723
10724
10725 /* ------------------------------------ */
10726 /* ****** Test  validity of KINDIC ** */
10727 /* ------------------------------------ */
10728
10729     /* Parameter adjustments */
10730     --hiltab;
10731     --urootl;
10732
10733     /* Function Body */
10734     *iercod = 0;
10735     kg = *kindic;
10736     if (kg < 1 || kg > 10) {
10737         kg = 10;
10738         *iercod = -1;
10739     }
10740     *nbrval = kg << 1;
10741     ndegl = *nbrval << 1;
10742
10743 /* ----------------------------------------------------------------------
10744 */
10745 /* ****** Load NBRVAL positive roots depending on the degree **
10746 */
10747 /* ----------------------------------------------------------------------
10748 */
10749 /* ATTENTION : Sign minus (-) in the loop is intentional. */
10750
10751     mmextrl_(&ndegl, tamp);
10752     i__1 = *nbrval;
10753     for (ii = 1; ii <= i__1; ++ii) {
10754         urootl[ii] = -tamp[ii - 1];
10755 /* L100: */
10756     }
10757
10758 /* ------------------------------------------------------------------- */
10759 /* ****** Loading of NBRVAL Gauss weight depending on the degree ** */
10760 /* ------------------------------------------------------------------- */
10761
10762     mmexthi_(&ndegl, tamp);
10763     i__1 = *nbrval;
10764     for (ii = 1; ii <= i__1; ++ii) {
10765         hiltab[ii] = tamp[ii - 1];
10766 /* L200: */
10767     }
10768
10769 /* ------------------------------- */
10770 /* ****** End of sub-program ** */
10771 /* ------------------------------- */
10772
10773     return 0;
10774 } /* mvgaus0_ */
10775
10776 //=======================================================================
10777 //function : mvpscr2_
10778 //purpose  :
10779 //=======================================================================
10780 int mvpscr2_(integer *ncoeff,
10781              doublereal *curve2,
10782              doublereal *tparam,
10783              doublereal *pntcrb)
10784 {
10785   /* System generated locals */
10786   integer i__1;
10787
10788   /* Local variables */
10789   static integer ndeg, kk;
10790   static doublereal xxx, yyy;
10791
10792
10793
10794 /* **********************************************************************
10795 */
10796
10797 /*     FUNCTION : */
10798 /*     ---------- */
10799 /*  POSITIONING ON CURVE (NCF,2) IN SPACE OF DIMENSION 2. */
10800
10801 /*     KEYWORDS : */
10802 /*     ----------- */
10803 /*     TOUS,MATH_ACCES:: COURBE&,POSITIONNEMENT,&POINT. */
10804
10805 /*     INPUT ARGUMENTS : */
10806 /*     ------------------ */
10807 /*     NCOEFF : NUMBER OF COEFFICIENTS OF THE CURVE */
10808 /*     CURVE2 : EQUATION OF CURVE 2D */
10809 /*     TPARAM : VALUE OF PARAMETER AT GIVEN POINT */
10810
10811 /*     OUTPUT ARGUMENTS : */
10812 /*     ------------------- */
10813 /*     PNTCRB : COORDINATES OF POINT CORRESPONDING TO PARAMETER */
10814 /*              TPARAM ON CURVE 2D CURVE2. */
10815
10816 /*     COMMONS USED   : */
10817 /*     ---------------- */
10818
10819 /*     REFERENCES CALLED   : */
10820 /*     ---------------------- */
10821
10822 /*     DESCRIPTION/NOTES/LIMITATIONS : */
10823 /*     ----------------------------------- */
10824 /*     MSCHEMA OF HORNER. */
10825
10826 /* > */
10827 /* **********************************************************************
10828 */
10829
10830
10831 /* -------- INITIALIZATIONS AND PROCESSING OF PARTICULAR CASES ----------
10832 */
10833
10834 /* ---> Cas when NCOEFF > 1 (case STANDARD). */
10835     /* Parameter adjustments */
10836     --pntcrb;
10837     curve2 -= 3;
10838
10839     /* Function Body */
10840     if (*ncoeff >= 2) {
10841         goto L1000;
10842     }
10843 /* ---> Case when NCOEFF <= 1. */
10844     if (*ncoeff <= 0) {
10845         pntcrb[1] = 0.;
10846         pntcrb[2] = 0.;
10847         goto L9999;
10848     } else if (*ncoeff == 1) {
10849         pntcrb[1] = curve2[3];
10850         pntcrb[2] = curve2[4];
10851         goto L9999;
10852     }
10853
10854 /* -------------------- MSCHEMA OF HORNER (PARTICULAR CASE) --------------
10855  */
10856
10857 L1000:
10858
10859     if (*tparam == 1.) {
10860         xxx = 0.;
10861         yyy = 0.;
10862         i__1 = *ncoeff;
10863         for (kk = 1; kk <= i__1; ++kk) {
10864             xxx += curve2[(kk << 1) + 1];
10865             yyy += curve2[(kk << 1) + 2];
10866 /* L100: */
10867         }
10868         goto L5000;
10869     } else if (*tparam == 0.) {
10870         pntcrb[1] = curve2[3];
10871         pntcrb[2] = curve2[4];
10872         goto L9999;
10873     }
10874
10875 /* ---------------------------- MSCHEMA OF HORNER ------------------------
10876  */
10877 /* ---> TPARAM is different from 1.D0 and 0.D0. */
10878
10879     ndeg = *ncoeff - 1;
10880     xxx = curve2[(*ncoeff << 1) + 1];
10881     yyy = curve2[(*ncoeff << 1) + 2];
10882     for (kk = ndeg; kk >= 1; --kk) {
10883         xxx = xxx * *tparam + curve2[(kk << 1) + 1];
10884         yyy = yyy * *tparam + curve2[(kk << 1) + 2];
10885 /* L200: */
10886     }
10887     goto L5000;
10888
10889 /* ------------------------ RECOVER THE CALCULATED POINT ---------------
10890 */
10891
10892 L5000:
10893     pntcrb[1] = xxx;
10894     pntcrb[2] = yyy;
10895
10896 /* ------------------------------ THE END -------------------------------
10897 */
10898
10899 L9999:
10900     return 0;
10901 } /* mvpscr2_ */
10902
10903 //=======================================================================
10904 //function : mvpscr3_
10905 //purpose  :
10906 //=======================================================================
10907 int mvpscr3_(integer *ncoeff,
10908              doublereal *curve3,
10909              doublereal *tparam,
10910              doublereal *pntcrb)
10911
10912 {
10913   /* System generated locals */
10914   integer i__1;
10915
10916   /* Local variables */
10917   static integer ndeg, kk;
10918   static doublereal xxx, yyy, zzz;
10919
10920
10921
10922 /* **********************************************************************
10923 */
10924
10925 /*     FUNCTION : */
10926 /*     ---------- */
10927 /* POSITIONING ON A CURVE (3,NCF) IN THE SPACE OF DIMENSION 3. */
10928
10929 /*     KEYWORDS : */
10930 /*     ----------- */
10931 /*     TOUS, MATH_ACCES:: COURBE&,POSITIONNEMENT,&POINT. */
10932
10933 /*     INPUT ARGUMENTS  : */
10934 /*     ------------------ */
10935 /*     NCOEFF : NB OF COEFFICIENTS OF THE CURVE */
10936 /*     CURVE3 : EQUATION OF CURVE 3D */
10937 /*     TPARAM : VALUE OF THE PARAMETER AT THE GIVEN POINT */
10938
10939 /*     OUTPUT ARGUMENTS : */
10940 /*     ------------------- */
10941 /*     PNTCRB : COORDINATES OF THE POINT CORRESPONDING TO PARAMETER */
10942 /*              TPARAM ON CURVE 3D CURVE3. */
10943
10944 /*     COMMONS USED   : */
10945 /*     ---------------- */
10946
10947 /*     REFERENCES CALLED   : */
10948 /*     ---------------------- */
10949 /*            Neant */
10950
10951 /*     DESCRIPTION/NOTES/LIMITATIONS : */
10952 /*     ----------------------------------- */
10953 /*     MSCHEMA OF HORNER. */
10954 /* > */
10955 /* **********************************************************************
10956 */
10957 /*                           DECLARATIONS */
10958 /* **********************************************************************
10959 */
10960
10961
10962 /* -------- INITIALISATIONS AND PROCESSING OF PARTICULAR CASES ----------
10963 */
10964
10965 /* ---> Case when NCOEFF > 1 (cas STANDARD). */
10966     /* Parameter adjustments */
10967     --pntcrb;
10968     curve3 -= 4;
10969
10970     /* Function Body */
10971     if (*ncoeff >= 2) {
10972         goto L1000;
10973     }
10974 /* ---> Case when NCOEFF <= 1. */
10975     if (*ncoeff <= 0) {
10976         pntcrb[1] = 0.;
10977         pntcrb[2] = 0.;
10978         pntcrb[3] = 0.;
10979         goto L9999;
10980     } else if (*ncoeff == 1) {
10981         pntcrb[1] = curve3[4];
10982         pntcrb[2] = curve3[5];
10983         pntcrb[3] = curve3[6];
10984         goto L9999;
10985     }
10986
10987 /* -------------------- MSCHEMA OF HORNER (PARTICULAR CASE) --------------
10988  */
10989
10990 L1000:
10991
10992     if (*tparam == 1.) {
10993         xxx = 0.;
10994         yyy = 0.;
10995         zzz = 0.;
10996         i__1 = *ncoeff;
10997         for (kk = 1; kk <= i__1; ++kk) {
10998             xxx += curve3[kk * 3 + 1];
10999             yyy += curve3[kk * 3 + 2];
11000             zzz += curve3[kk * 3 + 3];
11001 /* L100: */
11002         }
11003         goto L5000;
11004     } else if (*tparam == 0.) {
11005         pntcrb[1] = curve3[4];
11006         pntcrb[2] = curve3[5];
11007         pntcrb[3] = curve3[6];
11008         goto L9999;
11009     }
11010
11011 /* ---------------------------- MSCHEMA OF HORNER ------------------------
11012  */
11013 /* ---> Here TPARAM is different from 1.D0 and 0.D0. */
11014
11015     ndeg = *ncoeff - 1;
11016     xxx = curve3[*ncoeff * 3 + 1];
11017     yyy = curve3[*ncoeff * 3 + 2];
11018     zzz = curve3[*ncoeff * 3 + 3];
11019     for (kk = ndeg; kk >= 1; --kk) {
11020         xxx = xxx * *tparam + curve3[kk * 3 + 1];
11021         yyy = yyy * *tparam + curve3[kk * 3 + 2];
11022         zzz = zzz * *tparam + curve3[kk * 3 + 3];
11023 /* L200: */
11024     }
11025     goto L5000;
11026
11027 /* ------------------------ RETURN THE CALCULATED POINT ------------------
11028 */
11029
11030 L5000:
11031     pntcrb[1] = xxx;
11032     pntcrb[2] = yyy;
11033     pntcrb[3] = zzz;
11034
11035 /* ------------------------------ THE END -------------------------------
11036 */
11037
11038 L9999:
11039     return 0;
11040 } /* mvpscr3_ */
11041
11042 //=======================================================================
11043 //function : AdvApp2Var_MathBase::mvsheld_
11044 //purpose  :
11045 //=======================================================================
11046  int AdvApp2Var_MathBase::mvsheld_(integer *n,
11047                             integer *is,
11048                             doublereal *dtab,
11049                             integer *icle)
11050
11051 {
11052   /* System generated locals */
11053   integer dtab_dim1, dtab_offset, i__1, i__2;
11054
11055   /* Local variables */
11056   static integer incr;
11057   static doublereal dsave;
11058   static integer i3, i4, i5, incrp1;
11059
11060
11061 /************************************************************************
11062 *******/
11063
11064 /*     FUNCTION : */
11065 /*     ---------- */
11066 /*       PARSING OF COLUMNS OF TABLE OF REAL*8 BY SHELL METHOD*/
11067 /*        (IN INCREASING ORDER) */
11068
11069 /*     KEYWORDS : */
11070 /*     ----------- */
11071 /*        POINT-ENTRY, PARSING, SHELL */
11072
11073 /*     INPUT ARGUMENTS : */
11074 /*     ------------------ */
11075 /*        N      : NUMBER OF COLUMNS OF THE TABLE */
11076 /*        IS     : NUMBER OF LINE OF THE TABLE */
11077 /*        DTAB   : TABLE OF REAL*8 TO BE PARSED */
11078 /*        ICLE   : POSITION OF THE KEY ON THE COLUMN */
11079
11080 /*     OUTPUT ARGUMENTS : */
11081 /*     ------------------- */
11082 /*        DTAB   : PARSED TABLE */
11083
11084 /*     COMMONS USED   : */
11085 /*     ---------------- */
11086
11087
11088 /*     REFERENCES CALLED   : */
11089 /*     ---------------------- */
11090 /*            Neant */
11091
11092 /*     DESCRIPTION/NOTES/LIMITATIONS : */
11093 /*     ----------------------------------- */
11094 /*     CLASSIC SHELL METHOD : PARSING BY SERIES */
11095 /*     Declaration DTAB(IS, 1) corresponds to DTAB(IS, *) */
11096 /* > */
11097 /* ***********************************************************************
11098  */
11099
11100
11101     /* Parameter adjustments */
11102     dtab_dim1 = *is;
11103     dtab_offset = dtab_dim1 + 1;
11104     dtab -= dtab_offset;
11105
11106     /* Function Body */
11107     if (*n <= 1) {
11108         goto L9900;
11109     }
11110 /*     ------------------------ */
11111
11112 /*  INITIALIZATION OF THE SEQUENCE OF INCREMENTS */
11113 /*  FIND THE GREATEST INCREMENT SO THAT INCR < N/9 */
11114
11115     incr = 1;
11116 L1001:
11117     if (incr >= *n / 9) {
11118         goto L1002;
11119     }
11120 /*     ----------------------------- */
11121     incr = incr * 3 + 1;
11122     goto L1001;
11123
11124 /*  LOOP ON INCREMENTS TILL INCR = 1 */
11125 /*  PARSING BY SERIES DISTANT FROM INCR */
11126
11127 L1002:
11128     incrp1 = incr + 1;
11129 /*     ----------------- */
11130     i__1 = *n;
11131     for (i3 = incrp1; i3 <= i__1; ++i3) {
11132 /*        ---------------------- */
11133
11134 /*  SET ELEMENT I3 AT ITS PLACE IN THE SERIES */
11135
11136         i4 = i3 - incr;
11137 L1004:
11138         if (i4 < 1) {
11139             goto L1003;
11140         }
11141 /*           ------------------------- */
11142         if (dtab[*icle + i4 * dtab_dim1] <= dtab[*icle + (i4 + incr) *
11143                 dtab_dim1]) {
11144             goto L1003;
11145         }
11146
11147         i__2 = *is;
11148         for (i5 = 1; i5 <= i__2; ++i5) {
11149 /*              ------------------ */
11150             dsave = dtab[i5 + i4 * dtab_dim1];
11151             dtab[i5 + i4 * dtab_dim1] = dtab[i5 + (i4 + incr) * dtab_dim1];
11152             dtab[i5 + (i4 + incr) * dtab_dim1] = dsave;
11153         }
11154 /*              -------- */
11155         i4 -= incr;
11156         goto L1004;
11157
11158 L1003:
11159         ;
11160     }
11161 /*           -------- */
11162
11163 /*  PASSAGE TO THE NEXT INCREMENT */
11164
11165     incr /= 3;
11166     if (incr >= 1) {
11167         goto L1002;
11168     }
11169
11170 L9900:
11171  return 0   ;
11172 } /* mvsheld_ */
11173
11174 //=======================================================================
11175 //function : AdvApp2Var_MathBase::mzsnorm_
11176 //purpose  :
11177 //=======================================================================
11178  doublereal AdvApp2Var_MathBase::mzsnorm_(integer *ndimen,
11179                                    doublereal *vecteu)
11180
11181 {
11182   /* System generated locals */
11183   integer i__1;
11184   doublereal ret_val, d__1, d__2;
11185
11186   /* Local variables */
11187   static doublereal xsom;
11188   static integer i__, irmax;
11189
11190
11191
11192 /* ***********************************************************************
11193  */
11194
11195 /*     FUNCTION : */
11196 /*     ---------- */
11197 /*        SERVES to calculate the euclidian norm of a vector : */
11198 /*                       ____________________________ */
11199 /*                  Z = V  V(1)**2 + V(2)**2 + ... */
11200
11201 /*     KEYWORDS : */
11202 /*     ----------- */
11203 /*        SURMFACIQUE, */
11204
11205 /*     INPUT ARGUMENTS : */
11206 /*     ------------------ */
11207 /*        NDIMEN : Dimension of the vector */
11208 /*        VECTEU : vector of dimension NDIMEN */
11209
11210 /*     OUTPUT ARGUMENTS : */
11211 /*     ------------------- */
11212 /*        MZSNORM : Value of the euclidian norm of vector VECTEU */
11213
11214 /*     COMMONS USED   : */
11215 /*     ---------------- */
11216
11217 /*      .Neant. */
11218
11219 /*     REFERENCES CALLED   : */
11220 /*     ---------------------- */
11221 /*     Type  Name */
11222 /*      R*8  ABS            R*8  SQRT */
11223
11224 /*     DESCRIPTION/NOTESS/LIMITATIONS : */
11225 /*     ----------------------------------- */
11226 /*     To limit the risks of overflow, */
11227 /*     the term of the strongest absolute value is factorized : */
11228 /*                                _______________________ */
11229 /*                  Z = !V(1)! * V  1 + (V(2)/V(1))**2 + ... */
11230
11231 /* > */
11232 /* ***********************************************************************
11233  */
11234 /*                      DECLARATIONS */
11235 /* ***********************************************************************
11236  */
11237
11238
11239 /* ***********************************************************************
11240  */
11241 /*                     PROCESSING */
11242 /* ***********************************************************************
11243  */
11244
11245 /* ___ Find the strongest absolute value term */
11246
11247     /* Parameter adjustments */
11248     --vecteu;
11249
11250     /* Function Body */
11251     irmax = 1;
11252     i__1 = *ndimen;
11253     for (i__ = 2; i__ <= i__1; ++i__) {
11254         if ((d__1 = vecteu[irmax], abs(d__1)) < (d__2 = vecteu[i__], abs(d__2)
11255                 )) {
11256             irmax = i__;
11257         }
11258 /* L100: */
11259     }
11260
11261 /* ___ Calculate the norme */
11262
11263     if ((d__1 = vecteu[irmax], abs(d__1)) < 1.) {
11264         xsom = 0.;
11265         i__1 = *ndimen;
11266         for (i__ = 1; i__ <= i__1; ++i__) {
11267 /* Computing 2nd power */
11268             d__1 = vecteu[i__];
11269             xsom += d__1 * d__1;
11270 /* L200: */
11271         }
11272         ret_val = sqrt(xsom);
11273     } else {
11274         xsom = 0.;
11275         i__1 = *ndimen;
11276         for (i__ = 1; i__ <= i__1; ++i__) {
11277             if (i__ == irmax) {
11278                 xsom += 1.;
11279             } else {
11280 /* Computing 2nd power */
11281                 d__1 = vecteu[i__] / vecteu[irmax];
11282                 xsom += d__1 * d__1;
11283             }
11284 /* L300: */
11285         }
11286         ret_val = (d__1 = vecteu[irmax], abs(d__1)) * sqrt(xsom);
11287     }
11288
11289 /* ***********************************************************************
11290  */
11291 /*                   RETURN CALLING PROGRAM */
11292 /* ***********************************************************************
11293  */
11294
11295     return ret_val;
11296 } /* mzsnorm_ */
11297