src/AdvApp2Var/AdvApp2Var_MathBase.cxx

   1 // Copyright (c) 1999-2012 OPEN CASCADE SAS
   2 //
   3 // The content of this file is subject to the Open CASCADE Technology Public
   4 // License Version 6.5 (the "License"). You may not use the content of this file
   5 // except in compliance with the License. Please obtain a copy of the License
   6 // at http://www.opencascade.org and read it completely before using this file.
   7 //
   8 // The Initial Developer of the Original Code is Open CASCADE S.A.S., having its
   9 // main offices at: 1, place des Freres Montgolfier, 78280 Guyancourt, France.
  10 //
  11 // The Original Code and all software distributed under the License is
  12 // distributed on an "AS IS" basis, without warranty of any kind, and the
  13 // Initial Developer hereby disclaims all such warranties, including without
  14 // limitation, any warranties of merchantability, fitness for a particular
  15 // purpose or non-infringement. Please see the License for the specific terms
  16 // and conditions governing the rights and limitations under the License.
  17
  18 // AdvApp2Var_MathBase.cxx
  19 #include <math.h>
  20 #include <AdvApp2Var_SysBase.hxx>
  21 #include <AdvApp2Var_Data_f2c.hxx>
  22 #include <AdvApp2Var_MathBase.hxx>
  23 #include <AdvApp2Var_Data.hxx>
  24
  25 // statics
  26 static
  27 int mmchole_(integer *mxcoef,
  28              integer *dimens,
  29              doublereal *amatri,
  30              integer *aposit,
  31              integer *posuiv,
  32              doublereal *chomat,
  33              integer *iercod);
  34
  35
  36
  37
  38 static
  39 int mmrslss_(integer *mxcoef,
  40              integer *dimens,
  41              doublereal *smatri,
  42              integer *sposit,
  43              integer *posuiv,
  44              doublereal *mscnmbr,
  45              doublereal *soluti,
  46              integer *iercod);
  47
  48 static
  49 int mfac_(doublereal *f,
  50           integer *n);
  51
  52 static
  53 int mmaper0_(integer *ncofmx,
  54              integer *ndimen,
  55              integer *ncoeff,
  56              doublereal *crvlgd,
  57              integer *ncfnew,
  58              doublereal *ycvmax,
  59              doublereal *errmax);
  60 static
  61 int mmaper2_(integer *ncofmx,
  62              integer *ndimen,
  63              integer *ncoeff,
  64              doublereal *crvjac,
  65              integer *ncfnew,
  66              doublereal *ycvmax,
  67              doublereal *errmax);
  68
  69 static
  70 int mmaper4_(integer *ncofmx,
  71              integer *ndimen,
  72              integer *ncoeff,
  73              doublereal *crvjac,
  74              integer *ncfnew,
  75              doublereal *ycvmax,
  76              doublereal *errmax);
  77
  78 static
  79 int mmaper6_(integer *ncofmx,
  80              integer *ndimen,
  81              integer *ncoeff,
  82              doublereal *crvjac,
  83              integer *ncfnew,
  84              doublereal *ycvmax,
  85              doublereal *errmax);
  86
  87 static
  88 int mmarc41_(integer *ndimax,
  89              integer *ndimen,
  90              integer *ncoeff,
  91              doublereal *crvold,
  92              doublereal *upara0,
  93              doublereal *upara1,
  94              doublereal *crvnew,
  95              integer *iercod);
  96
  97 static
  98 int mmatvec_(integer *nligne,
  99              integer *ncolon,
 100              integer *gposit,
 101              integer *gnstoc,
 102              doublereal *gmatri,
 103              doublereal *vecin,
 104              integer *deblig,
 105              doublereal *vecout,
 106              integer *iercod);
 107
 108 static
 109 int mmcvstd_(integer *ncofmx,
 110              integer *ndimax,
 111              integer *ncoeff,
 112              integer *ndimen,
 113              doublereal *crvcan,
 114              doublereal *courbe);
 115
 116 static
 117 int mmdrvcb_(integer *ideriv,
 118              integer *ndim,
 119              integer *ncoeff,
 120              doublereal *courbe,
 121              doublereal *tparam,
 122              doublereal *tabpnt,
 123              integer *iercod);
 124
 125 static
 126 int mmexthi_(integer *ndegre,
 127              doublereal *hwgaus);
 128
 129 static
 130 int mmextrl_(integer *ndegre,
 131              doublereal *rootlg);
 132
 133
 134
 135 static
 136 int mmherm0_(doublereal *debfin,
 137              integer *iercod);
 138
 139 static
 140 int mmherm1_(doublereal *debfin,
 141              integer *ordrmx,
 142              integer *iordre,
 143              doublereal *hermit,
 144              integer *iercod);
 145 static
 146 int mmloncv_(integer *ndimax,
 147              integer *ndimen,
 148              integer *ncoeff,
 149              doublereal *courbe,
 150              doublereal *tdebut,
 151              doublereal *tfinal,
 152              doublereal *xlongc,
 153              integer *iercod);
 154 static
 155 int mmpojac_(doublereal *tparam,
 156              integer *iordre,
 157              integer *ncoeff,
 158              integer *nderiv,
 159              doublereal *valjac,
 160              integer *iercod);
 161
 162 static
 163 int mmrslw_(integer *normax,
 164             integer *nordre,
 165             integer *ndimen,
 166             doublereal *epspiv,
 167             doublereal *abmatr,
 168             doublereal *xmatri,
 169             integer *iercod);
 170 static
 171 int mmtmave_(integer *nligne,
 172              integer *ncolon,
 173              integer *gposit,
 174              integer *gnstoc,
 175              doublereal *gmatri,
 176              doublereal *vecin,
 177              doublereal *vecout,
 178              integer *iercod);
 179 static
 180 int mmtrpj0_(integer *ncofmx,
 181              integer *ndimen,
 182              integer *ncoeff,
 183              doublereal *epsi3d,
 184              doublereal *crvlgd,
 185              doublereal *ycvmax,
 186              doublereal *epstrc,
 187              integer *ncfnew);
 188 static
 189 int mmtrpj2_(integer *ncofmx,
 190              integer *ndimen,
 191              integer *ncoeff,
 192              doublereal *epsi3d,
 193              doublereal *crvlgd,
 194              doublereal *ycvmax,
 195              doublereal *epstrc,
 196              integer *ncfnew);
 197
 198 static
 199 int mmtrpj4_(integer *ncofmx,
 200              integer *ndimen,
 201              integer *ncoeff,
 202              doublereal *epsi3d,
 203              doublereal *crvlgd,
 204              doublereal *ycvmax,
 205              doublereal *epstrc,
 206              integer *ncfnew);
 207 static
 208 int mmtrpj6_(integer *ncofmx,
 209              integer *ndimen,
 210              integer *ncoeff,
 211              doublereal *epsi3d,
 212              doublereal *crvlgd,
 213              doublereal *ycvmax,
 214              doublereal *epstrc,
 215              integer *ncfnew);
 216 static
 217 integer  pow__ii(integer *x,
 218                  integer *n);
 219
 220 static
 221 int mvcvin2_(integer *ncoeff,
 222              doublereal *crvold,
 223              doublereal *crvnew,
 224              integer *iercod);
 225
 226 static
 227 int mvcvinv_(integer *ncoeff,
 228              doublereal *crvold,
 229              doublereal *crvnew,
 230              integer *iercod);
 231
 232 static
 233 int mvgaus0_(integer *kindic,
 234              doublereal *urootl,
 235              doublereal *hiltab,
 236              integer *nbrval,
 237              integer *iercod);
 238 static
 239 int mvpscr2_(integer *ncoeff,
 240              doublereal *curve2,
 241              doublereal *tparam,
 242              doublereal *pntcrb);
 243
 244 static
 245 int mvpscr3_(integer *ncoeff,
 246              doublereal *curve2,
 247              doublereal *tparam,
 248              doublereal *pntcrb);
 249
 250 static struct {
 251     doublereal eps1, eps2, eps3, eps4;
 252     integer niterm, niterr;
 253 } mmprcsn_;
 254
 255 static struct {
 256     doublereal tdebut, tfinal, verifi, cmherm[576];
 257 } mmcmher_;
 258
 259 //=======================================================================
 260 //function : AdvApp2Var_MathBase::mdsptpt_
 261 //purpose  :
 262 //=======================================================================
 263 int AdvApp2Var_MathBase::mdsptpt_(integer *ndimen,
 264                                   doublereal *point1,
 265                                   doublereal *point2,
 266                                   doublereal *distan)
 267
 268 {
 269   integer c__8 = 8;
 270   /* System generated locals */
 271   integer i__1;
 272   doublereal d__1;
 273
 274   /* Local variables */
 275   integer i__;
 276   doublereal* differ = 0;
 277   integer  ier;
 278   intptr_t iofset, j;
 279
 280 /* **********************************************************************
 281 */
 282
 283 /*     FUNCTION : */
 284 /*     ---------- */
 285 /*        CALCULATE DISTANCE BETWEEN TWO POINTS */
 286
 287 /*     KEYWORDS : */
 288 /*     ----------- */
 289 /*        DISTANCE,POINT. */
 290
 291 /*     INPUT ARGUMENTS : */
 292 /*     ------------------ */
 293 /*        NDIMEN: Space Dimension. */
 294 /*        POINT1: Table of coordinates of the 1st point. */
 295 /*        POINT2: Table of coordinates of the 2nd point. */
 296
 297 /*     OUTPUT ARGUMENTS : */
 298 /*     ------------------- */
 299 /*        DISTAN: Distance between 2 points. */
 300
 301 /*     COMMONS USED   : */
 302 /*     ---------------- */
 303
 304 /*     REFERENCES CALLED   : */
 305 /*     ----------------------- */
 306
 307 /*     DESCRIPTION/NOTES/LIMITATIONS : */
 308 /*     ----------------------------------- */
 309 /* > */
 310 /* **********************************************************************
 311 */
 312
 313
 314 /* ***********************************************************************
 315  */
 316 /*                      INITIALISATION */
 317 /* ***********************************************************************
 318  */
 319
 320     /* Parameter adjustment */
 321     --point2;
 322     --point1;
 323
 324     /* Function Body */
 325     iofset = 0;
 326     ier = 0;
 327
 328 /* ***********************************************************************
 329  */
 330 /*                     TRAITEMENT */
 331 /* ***********************************************************************
 332  */
 333
 334     AdvApp2Var_SysBase anAdvApp2Var_SysBase;
 335     if (*ndimen > 100) {
 336         anAdvApp2Var_SysBase.mcrrqst_(&c__8, ndimen, differ, &iofset, &ier);
 337     }
 338
 339 /* --- If allocation is refused, the trivial method is applied. */
 340
 341     if (ier > 0) {
 342
 343         *distan = 0.;
 344         i__1 = *ndimen;
 345         for (i__ = 1; i__ <= i__1; ++i__) {
 346 /* Computing 2nd power */
 347             d__1 = point1[i__] - point2[i__];
 348             *distan += d__1 * d__1;
 349         }
 350         *distan = sqrt(*distan);
 351
 352 /* --- Otherwise MZSNORM is used to minimize the risks of overflow
 353 */
 354
 355     } else {
 356         i__1 = *ndimen;
 357         for (i__ = 1; i__ <= i__1; ++i__) {
 358             j=iofset + i__ - 1;
 359             differ[j] = point2[i__] - point1[i__];
 360         }
 361
 362         *distan = AdvApp2Var_MathBase::mzsnorm_(ndimen, &differ[iofset]);
 363
 364     }
 365
 366 /* ***********************************************************************
 367  */
 368 /*                   RETURN CALLING PROGRAM */
 369 /* ***********************************************************************
 370  */
 371
 372 /* --- Dynamic Desallocation */
 373
 374     if (iofset != 0) {
 375         anAdvApp2Var_SysBase.mcrdelt_(&c__8, ndimen, differ, &iofset, &ier);
 376     }
 377
 378  return 0 ;
 379 } /* mdsptpt_ */
 380
 381 //=======================================================================
 382 //function : mfac_
 383 //purpose  :
 384 //=======================================================================
 385 int mfac_(doublereal *f,
 386           integer *n)
 387
 388 {
 389     /* System generated locals */
 390     integer i__1;
 391
 392     /* Local variables */
 393     integer i__;
 394
 395 /*    FORTRAN CONFORME AU TEXT */
 396 /*     CALCUL DE MFACTORIEL N */
 397     /* Parameter adjustments */
 398     --f;
 399
 400     /* Function Body */
 401     f[1] = (float)1.;
 402     i__1 = *n;
 403     for (i__ = 2; i__ <= i__1; ++i__) {
 404 /* L10: */
 405         f[i__] = i__ * f[i__ - 1];
 406     }
 407     return 0;
 408 } /* mfac_ */
 409
 410 //=======================================================================
 411 //function : AdvApp2Var_MathBase::mmapcmp_
 412 //purpose  :
 413 //=======================================================================
 414 int AdvApp2Var_MathBase::mmapcmp_(integer *ndim,
 415                                   integer *ncofmx,
 416                                   integer *ncoeff,
 417                                   doublereal *crvold,
 418                                   doublereal *crvnew)
 419
 420 {
 421   /* System generated locals */
 422   integer crvold_dim1, crvold_offset, crvnew_dim1, crvnew_offset, i__1,
 423   i__2;
 424
 425   /* Local variables */
 426   integer ipair, nd, ndegre, impair, ibb, idg;
 427   //extern  int  mgsomsg_();//mgenmsg_(),
 428
 429 /* **********************************************************************
 430 */
 431
 432 /*     FUNCTION : */
 433 /*     ---------- */
 434 /*        Compression of curve CRVOLD in a table of  */
 435 /*        coeff. of even : CRVNEW(*,0,*) */
 436 /*        and uneven range : CRVNEW(*,1,*). */
 437
 438 /*     KEYWORDS : */
 439 /*     ----------- */
 440 /*        COMPRESSION,CURVE. */
 441
 442 /*     INPUT ARGUMENTS : */
 443 /*     ------------------ */
 444 /*     NDIM   : Space Dimension. */
 445 /*     NCOFMX : Max nb of coeff. of the curve to compress. */
 446 /*     NCOEFF : Max nb of coeff. of the compressed curve. */
 447 /*     CRVOLD : The curve (0:NCOFMX-1,NDIM) to compress. */
 448
 449 /*     OUTPUT ARGUMENTS : */
 450 /*     ------------------- */
 451 /*     CRVNEW : Curve compacted in (0:(NCOEFF-1)/2,0,NDIM) (containing
 452 */
 453 /*              even terms) and in (0:(NCOEFF-1)/2,1,NDIM) */
 454 /*              (containing uneven terms). */
 455
 456 /*     COMMONS USED   : */
 457 /*     ---------------- */
 458
 459 /*     REFERENCES CALLED   : */
 460 /*     ----------------------- */
 461
 462 /*     DESCRIPTION/NOTES/LIMITATIONS : */
 463 /*     ----------------------------------- */
 464 /*     This routine is useful to prepare coefficients of a */
 465 /*     curve in an orthogonal base (Legendre or Jacobi) before */
 466 /*     calculating the coefficients in the canonical; base [-1,1] by */
 467 /*     MMJACAN. */
 468 /* ***********************************************************************
 469  */
 470
 471 /*   Name of the routine */
 472
 473     /* Parameter adjustments */
 474     crvold_dim1 = *ncofmx;
 475     crvold_offset = crvold_dim1;
 476     crvold -= crvold_offset;
 477     crvnew_dim1 = (*ncoeff - 1) / 2 + 1;
 478     crvnew_offset = crvnew_dim1 << 1;
 479     crvnew -= crvnew_offset;
 480
 481     /* Function Body */
 482     ibb = AdvApp2Var_SysBase::mnfndeb_();
 483     if (ibb >= 3) {
 484         AdvApp2Var_SysBase::mgenmsg_("MMAPCMP", 7L);
 485     }
 486
 487     ndegre = *ncoeff - 1;
 488     i__1 = *ndim;
 489     for (nd = 1; nd <= i__1; ++nd) {
 490         ipair = 0;
 491         i__2 = ndegre / 2;
 492         for (idg = 0; idg <= i__2; ++idg) {
 493             crvnew[idg + (nd << 1) * crvnew_dim1] = crvold[ipair + nd *
 494                     crvold_dim1];
 495             ipair += 2;
 496 /* L200: */
 497         }
 498         if (ndegre < 1) {
 499             goto L400;
 500         }
 501         impair = 1;
 502         i__2 = (ndegre - 1) / 2;
 503         for (idg = 0; idg <= i__2; ++idg) {
 504             crvnew[idg + ((nd << 1) + 1) * crvnew_dim1] = crvold[impair + nd *
 505                      crvold_dim1];
 506             impair += 2;
 507 /* L300: */
 508         }
 509
 510 L400:
 511 /* L100: */
 512         ;
 513     }
 514
 515 /* ---------------------------------- The end ---------------------------
 516 */
 517
 518     if (ibb >= 3) {
 519         AdvApp2Var_SysBase::mgsomsg_("MMAPCMP", 7L);
 520     }
 521     return 0;
 522 } /* mmapcmp_ */
 523
 524 //=======================================================================
 525 //function : mmaper0_
 526 //purpose  :
 527 //=======================================================================
 528 int mmaper0_(integer *ncofmx,
 529              integer *ndimen,
 530              integer *ncoeff,
 531              doublereal *crvlgd,
 532              integer *ncfnew,
 533              doublereal *ycvmax,
 534              doublereal *errmax)
 535
 536 {
 537   /* System generated locals */
 538   integer crvlgd_dim1, crvlgd_offset, i__1, i__2;
 539   doublereal d__1;
 540
 541   /* Local variables */
 542   integer ncut;
 543   doublereal bidon;
 544   integer ii, nd;
 545
 546 /* ***********************************************************************
 547  */
 548
 549 /*     FUNCTION : */
 550 /*     ---------- */
 551 /*        Calculate the max error of approximation done when */
 552 /*        only the first NCFNEW coefficients of a curve are preserved.
 553 */
 554 /*        Degree NCOEFF-1 written in the base of Legendre (Jacobi */
 555 /*        of  order 0). */
 556
 557 /*     KEYWORDS : */
 558 /*     ----------- */
 559 /*        LEGENDRE,POLYGON,APPROXIMATION,ERROR. */
 560
 561 /*     INPUT ARGUMENTS : */
 562 /*     ------------------ */
 563 /*        NCOFMX : Max. degree of the curve. */
 564 /*        NDIMEN : Space dimension. */
 565 /*        NCOEFF : Degree +1 of the curve. */
 566 /*        CRVLGD : Curve the degree which of should be lowered. */
 567 /*        NCFNEW : Degree +1 of the resulting polynom. */
 568
 569 /*     OUTPUT ARGUMENTS : */
 570 /*     ------------------- */
 571 /*        YCVMAX : Auxiliary Table (max error on each dimension).
 572 */
 573 /*        ERRMAX : Precision of the approximation. */
 574
 575 /*     COMMONS USED   : */
 576 /*     ---------------- */
 577
 578 /*     REFERENCES CALLED   : */
 579 /*     ----------------------- */
 580
 581 /*     DESCRIPTION/NOTES/LIMITATIONS : */
 582 /*     ----------------------------------- */
 583 /* ***********************************************************************
 584  */
 585
 586
 587 /* ------------------- Init to calculate an error -----------------------
 588 */
 589
 590     /* Parameter adjustments */
 591     --ycvmax;
 592     crvlgd_dim1 = *ncofmx;
 593     crvlgd_offset = crvlgd_dim1 + 1;
 594     crvlgd -= crvlgd_offset;
 595
 596     /* Function Body */
 597     i__1 = *ndimen;
 598     for (ii = 1; ii <= i__1; ++ii) {
 599         ycvmax[ii] = 0.;
 600 /* L100: */
 601     }
 602
 603 /* ------ Minimum that can be reached : Stop at 1 or NCFNEW ------
 604 */
 605
 606     ncut = 1;
 607     if (*ncfnew + 1 > ncut) {
 608         ncut = *ncfnew + 1;
 609     }
 610
 611 /* -------------- Elimination of high degree coefficients-----------
 612 */
 613 /* ----------- Loop on the series of Legendre: NCUT --> NCOEFF --------
 614 */
 615
 616     i__1 = *ncoeff;
 617     for (ii = ncut; ii <= i__1; ++ii) {
 618 /*   Factor of renormalization (Maximum of Li(t)). */
 619         bidon = ((ii - 1) * 2. + 1.) / 2.;
 620         bidon = sqrt(bidon);
 621
 622         i__2 = *ndimen;
 623         for (nd = 1; nd <= i__2; ++nd) {
 624             ycvmax[nd] += (d__1 = crvlgd[ii + nd * crvlgd_dim1], advapp_abs(d__1)) *
 625                     bidon;
 626 /* L310: */
 627         }
 628 /* L300: */
 629     }
 630
 631 /* -------------- The error is the norm of the vector error ---------------
 632 */
 633
 634     *errmax = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
 635
 636 /* --------------------------------- Fin --------------------------------
 637 */
 638
 639     return 0;
 640 } /* mmaper0_ */
 641
 642 //=======================================================================
 643 //function : mmaper2_
 644 //purpose  :
 645 //=======================================================================
 646 int mmaper2_(integer *ncofmx,
 647              integer *ndimen,
 648              integer *ncoeff,
 649              doublereal *crvjac,
 650              integer *ncfnew,
 651              doublereal *ycvmax,
 652              doublereal *errmax)
 653
 654 {
 655   /* Initialized data */
 656
 657     static doublereal xmaxj[57] = { .9682458365518542212948163499456,
 658             .986013297183269340427888048593603,
 659             1.07810420343739860362585159028115,
 660             1.17325804490920057010925920756025,
 661             1.26476561266905634732910520370741,
 662             1.35169950227289626684434056681946,
 663             1.43424378958284137759129885012494,
 664             1.51281316274895465689402798226634,
 665             1.5878364329591908800533936587012,
 666             1.65970112228228167018443636171226,
 667             1.72874345388622461848433443013543,
 668             1.7952515611463877544077632304216,
 669             1.85947199025328260370244491818047,
 670             1.92161634324190018916351663207101,
 671             1.98186713586472025397859895825157,
 672             2.04038269834980146276967984252188,
 673             2.09730119173852573441223706382076,
 674             2.15274387655763462685970799663412,
 675             2.20681777186342079455059961912859,
 676             2.25961782459354604684402726624239,
 677             2.31122868752403808176824020121524,
 678             2.36172618435386566570998793688131,
 679             2.41117852396114589446497298177554,
 680             2.45964731268663657873849811095449,
 681             2.50718840313973523778244737914028,
 682             2.55385260994795361951813645784034,
 683             2.59968631659221867834697883938297,
 684             2.64473199258285846332860663371298,
 685             2.68902863641518586789566216064557,
 686             2.73261215675199397407027673053895,
 687             2.77551570192374483822124304745691,
 688             2.8177699459714315371037628127545,
 689             2.85940333797200948896046563785957,
 690             2.90044232019793636101516293333324,
 691             2.94091151970640874812265419871976,
 692             2.98083391718088702956696303389061,
 693             3.02023099621926980436221568258656,
 694             3.05912287574998661724731962377847,
 695             3.09752842783622025614245706196447,
 696             3.13546538278134559341444834866301,
 697             3.17295042316122606504398054547289,
 698             3.2099992681699613513775259670214,
 699             3.24662674946606137764916854570219,
 700             3.28284687953866689817670991319787,
 701             3.31867291347259485044591136879087,
 702             3.35411740487202127264475726990106,
 703             3.38919225660177218727305224515862,
 704             3.42390876691942143189170489271753,
 705             3.45827767149820230182596660024454,
 706             3.49230918177808483937957161007792,
 707             3.5260130200285724149540352829756,
 708             3.55939845146044235497103883695448,
 709             3.59247431368364585025958062194665,
 710             3.62524904377393592090180712976368,
 711             3.65773070318071087226169680450936,
 712             3.68992700068237648299565823810245,
 713             3.72184531357268220291630708234186 };
 714
 715     /* System generated locals */
 716     integer crvjac_dim1, crvjac_offset, i__1, i__2;
 717     doublereal d__1;
 718
 719     /* Local variables */
 720     integer idec, ncut;
 721     doublereal bidon;
 722     integer ii, nd;
 723
 724
 725
 726 /* ***********************************************************************
 727  */
 728
 729 /*     FONCTION : */
 730 /*     ---------- */
 731 /*        Calculate max approximation error i faite lorsque l' on */
 732 /*        ne conserve que les premiers NCFNEW coefficients d' une courbe
 733 */
 734 /*        de degre NCOEFF-1 ecrite dans la base de Jacobi d' ordre 2. */
 735
 736 /*     KEYWORDS : */
 737 /*     ----------- */
 738 /*        JACOBI, POLYGON, APPROXIMATION, ERROR. */
 739 /*
 740 /*  INPUT ARGUMENTS : */
 741 /*     ------------------ */
 742 /*        NCOFMX : Max. degree of the curve. */
 743 /*        NDIMEN : Space dimension. */
 744 /*        NCOEFF : Degree +1 of the curve. */
 745 /*        CRVLGD : Curve the degree which of should be lowered. */
 746 /*        NCFNEW : Degree +1 of the resulting polynom. */
 747
 748 /*     OUTPUT ARGUMENTS : */
 749 /*     ------------------- */
 750 /*        YCVMAX : Auxiliary Table (max error on each dimension).
 751 */
 752 /*        ERRMAX : Precision of the approximation. */
 753
 754 /*     COMMONS USED   : */
 755 /*     ---------------- */
 756
 757 /*     REFERENCES CALLED   : */
 758 /*     ----------------------- */
 759 /*     DESCRIPTION/NOTES/LIMITATIONS : */
 760 /*     ----------------------------------- */
 761
 762
 763
 764 /* ------------------ Table of maximums of (1-t2)*Ji(t) ----------------
 765 */
 766
 767     /* Parameter adjustments */
 768     --ycvmax;
 769     crvjac_dim1 = *ncofmx;
 770     crvjac_offset = crvjac_dim1 + 1;
 771     crvjac -= crvjac_offset;
 772
 773     /* Function Body */
 774
 775
 776
 777 /* ------------------- Init for error  calculation -----------------------
 778 */
 779
 780     i__1 = *ndimen;
 781     for (ii = 1; ii <= i__1; ++ii) {
 782         ycvmax[ii] = 0.;
 783 /* L100: */
 784     }
 785
 786 /* ------ Min. Degree that can be attained : Stop at 3 or NCFNEW ------
 787 */
 788
 789     idec = 3;
 790 /* Computing MAX */
 791     i__1 = idec, i__2 = *ncfnew + 1;
 792     ncut = advapp_max(i__1,i__2);
 793
 794 /* -------------- Removal of coefficients of high degree -----------
 795 */
 796 /* ----------- Loop on the series of Jacobi :NCUT --> NCOEFF ----------
 797 */
 798
 799     i__1 = *ncoeff;
 800     for (ii = ncut; ii <= i__1; ++ii) {
 801 /*   Factor of renormalization. */
 802         bidon = xmaxj[ii - idec];
 803         i__2 = *ndimen;
 804         for (nd = 1; nd <= i__2; ++nd) {
 805             ycvmax[nd] += (d__1 = crvjac[ii + nd * crvjac_dim1], advapp_abs(d__1)) *
 806                     bidon;
 807 /* L310: */
 808         }
 809 /* L300: */
 810     }
 811
 812 /* -------------- The error is the norm of the vector error ---------------
 813 */
 814
 815     *errmax = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
 816
 817 /* --------------------------------- Fin --------------------------------
 818 */
 819
 820     return 0;
 821 } /* mmaper2_ */
 822
 823 /* MAPER4.f -- translated by f2c (version 19960827).
 824    You must link the resulting object file with the libraries:
 825         -lf2c -lm   (in that order)
 826 */
 827
 828 /* Subroutine */
 829 //=======================================================================
 830 //function : mmaper4_
 831 //purpose  :
 832 //=======================================================================
 833 int mmaper4_(integer *ncofmx,
 834              integer *ndimen,
 835              integer *ncoeff,
 836              doublereal *crvjac,
 837              integer *ncfnew,
 838              doublereal *ycvmax,
 839              doublereal *errmax)
 840 {
 841     /* Initialized data */
 842
 843     static doublereal xmaxj[55] = { 1.1092649593311780079813740546678,
 844             1.05299572648705464724876659688996,
 845             1.0949715351434178709281698645813,
 846             1.15078388379719068145021100764647,
 847             1.2094863084718701596278219811869,
 848             1.26806623151369531323304177532868,
 849             1.32549784426476978866302826176202,
 850             1.38142537365039019558329304432581,
 851             1.43575531950773585146867625840552,
 852             1.48850442653629641402403231015299,
 853             1.53973611681876234549146350844736,
 854             1.58953193485272191557448229046492,
 855             1.63797820416306624705258190017418,
 856             1.68515974143594899185621942934906,
 857             1.73115699602477936547107755854868,
 858             1.77604489805513552087086912113251,
 859             1.81989256661534438347398400420601,
 860             1.86276344480103110090865609776681,
 861             1.90471563564740808542244678597105,
 862             1.94580231994751044968731427898046,
 863             1.98607219357764450634552790950067,
 864             2.02556989246317857340333585562678,
 865             2.06433638992049685189059517340452,
 866             2.10240936014742726236706004607473,
 867             2.13982350649113222745523925190532,
 868             2.17661085564771614285379929798896,
 869             2.21280102016879766322589373557048,
 870             2.2484214321456956597803794333791,
 871             2.28349755104077956674135810027654,
 872             2.31805304852593774867640120860446,
 873             2.35210997297725685169643559615022,
 874             2.38568889602346315560143377261814,
 875             2.41880904328694215730192284109322,
 876             2.45148841120796359750021227795539,
 877             2.48374387161372199992570528025315,
 878             2.5155912654873773953959098501893,
 879             2.54704548720896557684101746505398,
 880             2.57812056037881628390134077704127,
 881             2.60882970619319538196517982945269,
 882             2.63918540521920497868347679257107,
 883             2.66919945330942891495458446613851,
 884             2.69888301230439621709803756505788,
 885             2.72824665609081486737132853370048,
 886             2.75730041251405791603760003778285,
 887             2.78605380158311346185098508516203,
 888             2.81451587035387403267676338931454,
 889             2.84269522483114290814009184272637,
 890             2.87060005919012917988363332454033,
 891             2.89823818258367657739520912946934,
 892             2.92561704377132528239806135133273,
 893             2.95274375377994262301217318010209,
 894             2.97962510678256471794289060402033,
 895             3.00626759936182712291041810228171,
 896             3.03267744830655121818899164295959,
 897             3.05886060707437081434964933864149 };
 898
 899     /* System generated locals */
 900     integer crvjac_dim1, crvjac_offset, i__1, i__2;
 901     doublereal d__1;
 902
 903     /* Local variables */
 904     integer idec, ncut;
 905     doublereal bidon;
 906     integer ii, nd;
 907
 908
 909
 910 /* ***********************************************************************
 911  */
 912
 913 /*     FUNCTION : */
 914 /*     ---------- */
 915 /*        Calculate the max. error of approximation made when  */
 916 /*        only first NCFNEW coefficients of a curve are preserved
 917 */
 918 /*        degree NCOEFF-1 is written in the base of Jacobi of order 4. */
 919 /*        KEYWORDS : */
 920 /*     ----------- */
 921 /*        LEGENDRE,POLYGON,APPROXIMATION,ERROR. */
 922
 923 /*     INPUT ARGUMENTS : */
 924 /*     ------------------ */
 925 /*        NCOFMX : Max. degree of the curve. */
 926 /*        NDIMEN : Space dimension. */
 927 /*        NCOEFF : Degree +1 of the curve. */
 928 /*        CRVJAC : Curve the degree which of should be lowered. */
 929 /*        NCFNEW : Degree +1 of the resulting polynom. */
 930
 931 /*     OUTPUT ARGUMENTS : */
 932 /*     ------------------- */
 933 /*        YCVMAX : Auxiliary Table (max error on each dimension).
 934 */
 935 /*        ERRMAX : Precision of the approximation. */
 936
 937 /*     COMMONS USED   : */
 938 /*     ---------------- */
 939
 940 /*     REFERENCES CALLED   : */
 941 /*     ----------------------- */
 942
 943 /*     DESCRIPTION/NOTES/LIMITATIONS : */
 944
 945
 946 /* ***********************************************************************
 947  */
 948
 949
 950 /* ---------------- Table of maximums of ((1-t2)2)*Ji(t) ---------------
 951 */
 952
 953     /* Parameter adjustments */
 954     --ycvmax;
 955     crvjac_dim1 = *ncofmx;
 956     crvjac_offset = crvjac_dim1 + 1;
 957     crvjac -= crvjac_offset;
 958
 959     /* Function Body */
 960
 961
 962
 963 /* ------------------- Init for error calculation -----------------------
 964 */
 965
 966     i__1 = *ndimen;
 967     for (ii = 1; ii <= i__1; ++ii) {
 968         ycvmax[ii] = 0.;
 969 /* L100: */
 970     }
 971
 972 /* ------ Min. Degree that can be attained : Stop at 5 or NCFNEW ------
 973 */
 974
 975     idec = 5;
 976 /* Computing MAX */
 977     i__1 = idec, i__2 = *ncfnew + 1;
 978     ncut = advapp_max(i__1,i__2);
 979
 980 /* -------------- Removal of high degree coefficients -----------
 981 */
 982 /* ----------- Loop on the series of Jacobi :NCUT --> NCOEFF ----------
 983 */
 984
 985     i__1 = *ncoeff;
 986     for (ii = ncut; ii <= i__1; ++ii) {
 987 /*   Factor of renormalisation. */
 988         bidon = xmaxj[ii - idec];
 989         i__2 = *ndimen;
 990         for (nd = 1; nd <= i__2; ++nd) {
 991             ycvmax[nd] += (d__1 = crvjac[ii + nd * crvjac_dim1], advapp_abs(d__1)) *
 992                     bidon;
 993 /* L310: */
 994         }
 995 /* L300: */
 996     }
 997
 998 /* -------------- The error is the norm of the error vector ---------------
 999 */
1000
1001     *errmax = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
1002
1003 /* --------------------------------- End --------------------------------
1004 */
1005
1006     return 0;
1007 } /* mmaper4_ */
1008
1009 //=======================================================================
1010 //function : mmaper6_
1011 //purpose  :
1012 //=======================================================================
1013 int mmaper6_(integer *ncofmx,
1014              integer *ndimen,
1015              integer *ncoeff,
1016              doublereal *crvjac,
1017              integer *ncfnew,
1018              doublereal *ycvmax,
1019              doublereal *errmax)
1020
1021 {
1022     /* Initialized data */
1023
1024     static doublereal xmaxj[53] = { 1.21091229812484768570102219548814,
1025             1.11626917091567929907256116528817,
1026             1.1327140810290884106278510474203,
1027             1.1679452722668028753522098022171,
1028             1.20910611986279066645602153641334,
1029             1.25228283758701572089625983127043,
1030             1.29591971597287895911380446311508,
1031             1.3393138157481884258308028584917,
1032             1.3821288728999671920677617491385,
1033             1.42420414683357356104823573391816,
1034             1.46546895108549501306970087318319,
1035             1.50590085198398789708599726315869,
1036             1.54550385142820987194251585145013,
1037             1.58429644271680300005206185490937,
1038             1.62230484071440103826322971668038,
1039             1.65955905239130512405565733793667,
1040             1.69609056468292429853775667485212,
1041             1.73193098017228915881592458573809,
1042             1.7671112206990325429863426635397,
1043             1.80166107681586964987277458875667,
1044             1.83560897003644959204940535551721,
1045             1.86898184653271388435058371983316,
1046             1.90180515174518670797686768515502,
1047             1.93410285411785808749237200054739,
1048             1.96589749778987993293150856865539,
1049             1.99721027139062501070081653790635,
1050             2.02806108474738744005306947877164,
1051             2.05846864831762572089033752595401,
1052             2.08845055210580131460156962214748,
1053             2.11802334209486194329576724042253,
1054             2.14720259305166593214642386780469,
1055             2.17600297710595096918495785742803,
1056             2.20443832785205516555772788192013,
1057             2.2325216999457379530416998244706,
1058             2.2602654243075083168599953074345,
1059             2.28768115912702794202525264301585,
1060             2.3147799369092684021274946755348,
1061             2.34157220782483457076721300512406,
1062             2.36806787963276257263034969490066,
1063             2.39427635443992520016789041085844,
1064             2.42020656255081863955040620243062,
1065             2.44586699364757383088888037359254,
1066             2.47126572552427660024678584642791,
1067             2.49641045058324178349347438430311,
1068             2.52130850028451113942299097584818,
1069             2.54596686772399937214920135190177,
1070             2.5703922285006754089328998222275,
1071             2.59459096001908861492582631591134,
1072             2.61856915936049852435394597597773,
1073             2.64233265984385295286445444361827,
1074             2.66588704638685848486056711408168,
1075             2.68923766976735295746679957665724,
1076             2.71238965987606292679677228666411 };
1077
1078     /* System generated locals */
1079     integer crvjac_dim1, crvjac_offset, i__1, i__2;
1080     doublereal d__1;
1081
1082     /* Local variables */
1083     integer idec, ncut;
1084     doublereal bidon;
1085     integer ii, nd;
1086
1087
1088
1089 /* ***********************************************************************
1090  */
1091 /*     FUNCTION : */
1092 /*     ---------- */
1093 /*        Calculate the max. error of approximation made when  */
1094 /*        only first NCFNEW coefficients of a curve are preserved
1095 */
1096 /*        degree NCOEFF-1 is written in the base of Jacobi of order 6. */
1097 /*        KEYWORDS : */
1098 /*     ----------- */
1099 /*        JACOBI,POLYGON,APPROXIMATION,ERROR. */
1100
1101 /*     INPUT ARGUMENTS : */
1102 /*     ------------------ */
1103 /*        NCOFMX : Max. degree of the curve. */
1104 /*        NDIMEN : Space dimension. */
1105 /*        NCOEFF : Degree +1 of the curve. */
1106 /*        CRVJAC : Curve the degree which of should be lowered. */
1107 /*        NCFNEW : Degree +1 of the resulting polynom. */
1108
1109 /*     OUTPUT ARGUMENTS : */
1110 /*     ------------------- */
1111 /*        YCVMAX : Auxiliary Table (max error on each dimension).
1112 */
1113 /*        ERRMAX : Precision of the approximation. */
1114
1115 /*     COMMONS USED   : */
1116 /*     ---------------- */
1117
1118 /*     REFERENCES CALLED   : */
1119 /*     ----------------------- */
1120
1121 /*     DESCRIPTION/NOTES/LIMITATIONS : */
1122 /* > */
1123 /* ***********************************************************************
1124  */
1125
1126
1127 /* ---------------- Table of maximums of ((1-t2)3)*Ji(t) ---------------
1128 */
1129
1130     /* Parameter adjustments */
1131     --ycvmax;
1132     crvjac_dim1 = *ncofmx;
1133     crvjac_offset = crvjac_dim1 + 1;
1134     crvjac -= crvjac_offset;
1135
1136     /* Function Body */
1137
1138
1139
1140 /* ------------------- Init for error calculation -----------------------
1141 */
1142
1143     i__1 = *ndimen;
1144     for (ii = 1; ii <= i__1; ++ii) {
1145         ycvmax[ii] = 0.;
1146 /* L100: */
1147     }
1148
1149 /* ------ Min Degree that can be attained : Stop at 3 or NCFNEW ------
1150 */
1151
1152     idec = 7;
1153 /* Computing MAX */
1154     i__1 = idec, i__2 = *ncfnew + 1;
1155     ncut = advapp_max(i__1,i__2);
1156
1157 /* -------------- Removal of high degree coefficients -----------
1158 */
1159 /* ----------- Loop on the series of Jacobi :NCUT --> NCOEFF ----------
1160 */
1161
1162     i__1 = *ncoeff;
1163     for (ii = ncut; ii <= i__1; ++ii) {
1164 /*   Factor of renormalization. */
1165         bidon = xmaxj[ii - idec];
1166         i__2 = *ndimen;
1167         for (nd = 1; nd <= i__2; ++nd) {
1168             ycvmax[nd] += (d__1 = crvjac[ii + nd * crvjac_dim1], advapp_abs(d__1)) *
1169                     bidon;
1170 /* L310: */
1171         }
1172 /* L300: */
1173     }
1174
1175 /* -------------- The error is the norm of the vector error ---------------
1176 */
1177
1178     *errmax = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
1179
1180 /* --------------------------------- END --------------------------------
1181 */
1182
1183     return 0;
1184 } /* mmaper6_ */
1185
1186 //=======================================================================
1187 //function : AdvApp2Var_MathBase::mmaperx_
1188 //purpose  :
1189 //=======================================================================
1190 int AdvApp2Var_MathBase::mmaperx_(integer *ncofmx,
1191                                   integer *ndimen,
1192                                   integer *ncoeff,
1193                                   integer *iordre,
1194                                   doublereal *crvjac,
1195                                   integer *ncfnew,
1196                                   doublereal *ycvmax,
1197                                   doublereal *errmax,
1198                                   integer *iercod)
1199
1200 {
1201   /* System generated locals */
1202   integer crvjac_dim1, crvjac_offset;
1203
1204   /* Local variables */
1205   integer jord;
1206
1207 /* **********************************************************************
1208 */
1209 /*     FUNCTION : */
1210 /*     ---------- */
1211 /*        Calculate the max. error of approximation made when  */
1212 /*        only first NCFNEW coefficients of a curve are preserved
1213 */
1214 /*        degree NCOEFF-1 is written in the base of Jacobi of order IORDRE. */
1215 /*        KEYWORDS : */
1216 /*     ----------- */
1217 /*        JACOBI,LEGENDRE,POLYGON,APPROXIMATION,ERROR. */
1218
1219 /*     INPUT ARGUMENTS : */
1220 /*     ------------------ */
1221 /*        NCOFMX : Max. degree of the curve. */
1222 /*        NDIMEN : Space dimension. */
1223 /*        NCOEFF : Degree +1 of the curve. */
1224 /*        IORDRE : Order of continuity at the extremities. */
1225 /*        CRVJAC : Curve the degree which of should be lowered. */
1226 /*        NCFNEW : Degree +1 of the resulting polynom. */
1227
1228 /*     OUTPUT ARGUMENTS : */
1229 /*     ------------------- */
1230 /*        YCVMAX : Auxiliary Table (max error on each dimension).
1231 */
1232 /*        ERRMAX : Precision of the approximation. */
1233 /*        IERCOD = 0, OK */
1234 /*               = 1, order of constraints (IORDRE) is not within the */
1235 /*                    autorized values. */
1236 /*     COMMONS USED   : */
1237 /*     ---------------- */
1238
1239 /*     REFERENCES CALLED   : */
1240 /*     ----------------------- */
1241
1242 /*     DESCRIPTION/NOTES/LIMITATIONS : */
1243 /*     ----------------------------------- */
1244 /*     Canceled and replaced MMAPERR. */
1245 /* ***********************************************************************
1246  */
1247
1248
1249     /* Parameter adjustments */
1250     --ycvmax;
1251     crvjac_dim1 = *ncofmx;
1252     crvjac_offset = crvjac_dim1 + 1;
1253     crvjac -= crvjac_offset;
1254
1255     /* Function Body */
1256     *iercod = 0;
1257 /* --> Order of Jacobi polynoms */
1258     jord = ( *iordre + 1) << 1;
1259
1260     if (jord == 0) {
1261         mmaper0_(ncofmx, ndimen, ncoeff, &crvjac[crvjac_offset], ncfnew, &
1262                 ycvmax[1], errmax);
1263     } else if (jord == 2) {
1264         mmaper2_(ncofmx, ndimen, ncoeff, &crvjac[crvjac_offset], ncfnew, &
1265                 ycvmax[1], errmax);
1266     } else if (jord == 4) {
1267         mmaper4_(ncofmx, ndimen, ncoeff, &crvjac[crvjac_offset], ncfnew, &
1268                 ycvmax[1], errmax);
1269     } else if (jord == 6) {
1270         mmaper6_(ncofmx, ndimen, ncoeff, &crvjac[crvjac_offset], ncfnew, &
1271                 ycvmax[1], errmax);
1272     } else {
1273         *iercod = 1;
1274     }
1275
1276 /* ----------------------------------- Fin ------------------------------
1277 */
1278
1279     return 0;
1280 } /* mmaperx_ */
1281
1282 //=======================================================================
1283 //function : mmarc41_
1284 //purpose  :
1285 //=======================================================================
1286  int mmarc41_(integer *ndimax,
1287               integer *ndimen,
1288               integer *ncoeff,
1289               doublereal *crvold,
1290               doublereal *upara0,
1291               doublereal *upara1,
1292               doublereal *crvnew,
1293               integer *iercod)
1294
1295 {
1296   /* System generated locals */
1297     integer crvold_dim1, crvold_offset, crvnew_dim1, crvnew_offset, i__1,
1298     i__2, i__3;
1299
1300     /* Local variables */
1301     integer nboct;
1302     doublereal tbaux[61];
1303     integer nd;
1304     doublereal bid;
1305     integer ncf, ncj;
1306
1307
1308 /*      IMPLICIT DOUBLE PRECISION(A-H,O-Z) */
1309 /*      IMPLICIT INTEGER (I-N) */
1310
1311 /* ***********************************************************************
1312  */
1313
1314 /*     FUNCTION : */
1315 /*     ---------- */
1316 /*     Creation of curve C2(v) defined on (0,1) identic to */
1317 /*     curve C1(u) defined on (U0,U1) (change of parameter */
1318 /*     of a curve). */
1319
1320 /*     KEYWORDS : */
1321 /*     ----------- */
1322 /*        LIMITATION, RESTRICTION, CURVE */
1323
1324 /*     INPUT ARGUMENTS : */
1325 /*     ------------------ */
1326 /*   NDIMAX : Space Dimensioning. */
1327 /*   NDIMEN : Curve Dimension. */
1328 /*   NCOEFF : Nb of coefficients of the curve. */
1329 /*   CRVOLD : Curve to be limited. */
1330 /*   UPARA0     : Min limit of the interval limiting the curve.
1331 */
1332 /*   UPARA1     : Max limit of the interval limiting the curve.
1333 */
1334
1335 /*     OUTPUT ARGUMENTS : */
1336 /*     ------------------- */
1337 /*   CRVNEW : Relimited curve, defined on (0,1) and equal to */
1338 /*            CRVOLD defined on (U0,U1). */
1339 /*   IERCOD : = 0, OK */
1340 /*            =10, Nb of coeff. <1 or > 61. */
1341
1342 /*     COMMONS USED   : */
1343 /*     ---------------- */
1344 /*     REFERENCES CALLED   : */
1345 /*     ---------------------- */
1346 /*     Type  Name */
1347 /*           MAERMSG              MCRFILL              MVCVIN2 */
1348 /*           MVCVINV */
1349
1350 /*     DESCRIPTION/NOTES/LIMITATIONS : */
1351 /*     ----------------------------------- */
1352 /* ---> Algorithm used in this general case is based on the */
1353 /*     following principle  : */
1354 /*        Let S(t) = a0 + a1*t + a2*t**2 + ... of degree NCOEFF-1, and */
1355 /*               U(t) = b0 + b1*t, then the coeff. of */
1356 /*        S(U(t)) are calculated step by step with help of table TBAUX. */
1357 /*        At each step number N (N=2 to NCOEFF), TBAUX(n) contains */
1358 /*        the n-th coefficient of U(t)**N for n=1 to N. (RBD) */
1359 /* ---> Reference : KNUTH, 'The Art of Computer Programming', */
1360 /*                        Vol. 2/'Seminumerical Algorithms', */
1361 /*                        Ex. 11 p:451 et solution p:562. (RBD) */
1362
1363 /* ---> Removal of the input argument CRVOLD by CRVNEW is */
1364 /*     possible, which means that the call : */
1365 /*       CALL MMARC41(NDIMAX,NDIMEN,NCOEFF,CURVE,UPARA0,UPARA1 */
1366 /*                  ,CURVE,IERCOD) */
1367 /*     is absolutely LEGAL. (RBD) */
1368
1369 /* > */
1370 /* **********************************************************************
1371 */
1372
1373 /*   Name of the routine */
1374
1375 /*   Auxiliary table of coefficients of (UPARA1-UPARA0)T+UPARA0  */
1376 /*   with power N=1 to NCOEFF-1. */
1377
1378
1379     /* Parameter adjustments */
1380     crvnew_dim1 = *ndimax;
1381     crvnew_offset = crvnew_dim1 + 1;
1382     crvnew -= crvnew_offset;
1383     crvold_dim1 = *ndimax;
1384     crvold_offset = crvold_dim1 + 1;
1385     crvold -= crvold_offset;
1386
1387     /* Function Body */
1388     *iercod = 0;
1389 /* **********************************************************************
1390 */
1391 /*                CASE WHEN PROCESSING CAN'T BE DONE */
1392 /* **********************************************************************
1393 */
1394     if (*ncoeff > 61 || *ncoeff < 1) {
1395         *iercod = 10;
1396         goto L9999;
1397     }
1398 /* **********************************************************************
1399 */
1400 /*                         IF NO CHANGES */
1401 /* **********************************************************************
1402 */
1403     if (*ndimen == *ndimax && *upara0 == 0. && *upara1 == 1.) {
1404         nboct = (*ndimax << 3) * *ncoeff;
1405         AdvApp2Var_SysBase::mcrfill_(&nboct,
1406                  &crvold[crvold_offset],
1407                  &crvnew[crvnew_offset]);
1408         goto L9999;
1409     }
1410 /* **********************************************************************
1411 */
1412 /*                    INVERSION 3D : FAST PROCESSING */
1413 /* **********************************************************************
1414 */
1415     if (*upara0 == 1. && *upara1 == 0.) {
1416         if (*ndimen == 3 && *ndimax == 3 && *ncoeff <= 21) {
1417             mvcvinv_(ncoeff, &crvold[crvold_offset], &crvnew[crvnew_offset],
1418                     iercod);
1419             goto L9999;
1420         }
1421 /* ******************************************************************
1422 **** */
1423 /*                    INVERSION 2D : FAST PROCESSING */
1424 /* ******************************************************************
1425 **** */
1426         if (*ndimen == 2 && *ndimax == 2 && *ncoeff <= 21) {
1427             mvcvin2_(ncoeff, &crvold[crvold_offset], &crvnew[crvnew_offset],
1428                     iercod);
1429             goto L9999;
1430         }
1431     }
1432 /* **********************************************************************
1433 */
1434 /*                          GENERAL PROCESSING */
1435 /* **********************************************************************
1436 */
1437 /* -------------------------- Initializations ---------------------------
1438 */
1439
1440     i__1 = *ndimen;
1441     for (nd = 1; nd <= i__1; ++nd) {
1442         crvnew[nd + crvnew_dim1] = crvold[nd + crvold_dim1];
1443 /* L100: */
1444     }
1445     if (*ncoeff == 1) {
1446         goto L9999;
1447     }
1448     tbaux[0] = *upara0;
1449     tbaux[1] = *upara1 - *upara0;
1450
1451 /* ----------------------- Calculation of coeff. of CRVNEW ------------------
1452 */
1453
1454     i__1 = *ncoeff - 1;
1455     for (ncf = 2; ncf <= i__1; ++ncf) {
1456
1457 /* ------------ Take into account NCF-th coeff. of CRVOLD --------
1458 ---- */
1459
1460         i__2 = ncf - 1;
1461         for (ncj = 1; ncj <= i__2; ++ncj) {
1462             bid = tbaux[ncj - 1];
1463             i__3 = *ndimen;
1464             for (nd = 1; nd <= i__3; ++nd) {
1465                 crvnew[nd + ncj * crvnew_dim1] += crvold[nd + ncf *
1466                         crvold_dim1] * bid;
1467 /* L400: */
1468             }
1469 /* L300: */
1470         }
1471
1472         bid = tbaux[ncf - 1];
1473         i__2 = *ndimen;
1474         for (nd = 1; nd <= i__2; ++nd) {
1475             crvnew[nd + ncf * crvnew_dim1] = crvold[nd + ncf * crvold_dim1] *
1476                     bid;
1477 /* L500: */
1478         }
1479
1480 /* --------- Calculate (NCF+1) coeff. of ((U1-U0)*t + U0)**(NCF) ---
1481 ---- */
1482
1483         bid = *upara1 - *upara0;
1484         tbaux[ncf] = tbaux[ncf - 1] * bid;
1485         for (ncj = ncf; ncj >= 2; --ncj) {
1486             tbaux[ncj - 1] = tbaux[ncj - 1] * *upara0 + tbaux[ncj - 2] * bid;
1487 /* L600: */
1488         }
1489         tbaux[0] *= *upara0;
1490
1491 /* L200: */
1492     }
1493
1494 /* -------------- Take into account the last coeff. of CRVOLD -----------
1495 */
1496
1497     i__1 = *ncoeff - 1;
1498     for (ncj = 1; ncj <= i__1; ++ncj) {
1499         bid = tbaux[ncj - 1];
1500         i__2 = *ndimen;
1501         for (nd = 1; nd <= i__2; ++nd) {
1502             crvnew[nd + ncj * crvnew_dim1] += crvold[nd + *ncoeff *
1503                     crvold_dim1] * bid;
1504 /* L800: */
1505         }
1506 /* L700: */
1507     }
1508     i__1 = *ndimen;
1509     for (nd = 1; nd <= i__1; ++nd) {
1510         crvnew[nd + *ncoeff * crvnew_dim1] = crvold[nd + *ncoeff *
1511                 crvold_dim1] * tbaux[*ncoeff - 1];
1512 /* L900: */
1513     }
1514
1515 /* ---------------------------- The end ---------------------------------
1516 */
1517
1518 L9999:
1519     if (*iercod != 0) {
1520         AdvApp2Var_SysBase::maermsg_("MMARC41", iercod, 7L);
1521     }
1522
1523  return 0 ;
1524 } /* mmarc41_ */
1525
1526 //=======================================================================
1527 //function : AdvApp2Var_MathBase::mmarcin_
1528 //purpose  :
1529 //=======================================================================
1530 int AdvApp2Var_MathBase::mmarcin_(integer *ndimax,
1531                                   integer *ndim,
1532                                   integer *ncoeff,
1533                                   doublereal *crvold,
1534                                   doublereal *u0,
1535                                   doublereal *u1,
1536                                   doublereal *crvnew,
1537                                   integer *iercod)
1538
1539 {
1540   /* System generated locals */
1541   integer crvold_dim1, crvold_offset, crvnew_dim1, crvnew_offset, i__1,
1542   i__2, i__3;
1543   doublereal d__1;
1544
1545   /* Local variables */
1546   doublereal x0, x1;
1547   integer nd;
1548   doublereal tabaux[61];
1549   integer ibb;
1550   doublereal bid;
1551   integer ncf;
1552   integer ncj;
1553   doublereal eps3;
1554
1555
1556
1557 /* **********************************************************************
1558 *//*     FUNCTION : */
1559 /*     ---------- */
1560 /*     Creation of curve C2(v) defined on [U0,U1] identic to */
1561 /*     curve C1(u) defined on [-1,1] (change of parameter */
1562 /*     of a curve) with INVERSION of indices of the resulting table. */
1563
1564 /*     KEYWORDS : */
1565 /*     ----------- */
1566 /*        GENERALIZED LIMITATION, RESTRICTION, INVERSION, CURVE */
1567
1568 /*     INPUT ARGUMENTS : */
1569 /*     ------------------ */
1570 /*   NDIMAX : Maximum Space Dimensioning. */
1571 /*   NDIMEN : Curve Dimension. */
1572 /*   NCOEFF : Nb of coefficients of the curve. */
1573 /*   CRVOLD : Curve to be limited. */
1574 /*   U0     : Min limit of the interval limiting the curve.
1575 */
1576 /*   U1     : Max limit of the interval limiting the curve.
1577 */
1578
1579 /*     OUTPUT ARGUMENTS : */
1580 /*     ------------------- */
1581 /*   CRVNEW : Relimited curve, defined on  [U0,U1] and equal to */
1582 /*            CRVOLD defined on [-1,1]. */
1583 /*   IERCOD : = 0, OK */
1584 /*            =10, Nb of coeff. <1 or > 61. */
1585 /*            =13, the requested interval of variation is null. */
1586 /*     COMMONS USED   : */
1587 /*     ---------------- */
1588 /*     REFERENCES CALLED   : */
1589 /*     ---------------------- */
1590 /*     DESCRIPTION/NOTES/LIMITATIONS : */
1591 /*     ----------------------------------- */
1592 /* > */
1593 /* **********************************************************************
1594 */
1595
1596 /*   Name of the routine */
1597
1598 /*   Auxiliary table of coefficients of X1*T+X0 */
1599 /*   with power N=1 to NCOEFF-1. */
1600
1601
1602     /* Parameter adjustments */
1603     crvnew_dim1 = *ndimax;
1604     crvnew_offset = crvnew_dim1 + 1;
1605     crvnew -= crvnew_offset;
1606     crvold_dim1 = *ncoeff;
1607     crvold_offset = crvold_dim1 + 1;
1608     crvold -= crvold_offset;
1609
1610     /* Function Body */
1611     ibb = AdvApp2Var_SysBase::mnfndeb_();
1612     if (ibb >= 2) {
1613         AdvApp2Var_SysBase::mgenmsg_("MMARCIN", 7L);
1614     }
1615
1616 /* At zero machine it is tested if the output interval is not null */
1617
1618     AdvApp2Var_MathBase::mmveps3_(&eps3);
1619     if ((d__1 = *u1 - *u0, advapp_abs(d__1)) < eps3) {
1620         *iercod = 13;
1621         goto L9999;
1622     }
1623     *iercod = 0;
1624
1625 /* **********************************************************************
1626 */
1627 /*                CASE WHEN THE PROCESSING IS IMPOSSIBLE */
1628 /* **********************************************************************
1629 */
1630     if (*ncoeff > 61 || *ncoeff < 1) {
1631         *iercod = 10;
1632         goto L9999;
1633     }
1634 /* **********************************************************************
1635 */
1636 /*          IF NO CHANGE OF THE INTERVAL OF DEFINITION */
1637 /*          (ONLY INVERSION OF INDICES OF TABLE CRVOLD) */
1638 /* **********************************************************************
1639 */
1640     if (*ndim == *ndimax && *u0 == -1. && *u1 == 1.) {
1641         AdvApp2Var_MathBase::mmcvinv_(ndim, ncoeff, ndim, &crvold[crvold_offset], &crvnew[
1642                 crvnew_offset]);
1643         goto L9999;
1644     }
1645 /* **********************************************************************
1646 */
1647 /*          CASE WHEN THE NEW INTERVAL OF DEFINITION IS [0,1] */
1648 /* **********************************************************************
1649 */
1650     if (*u0 == 0. && *u1 == 1.) {
1651         mmcvstd_(ncoeff, ndimax, ncoeff, ndim, &crvold[crvold_offset], &
1652                 crvnew[crvnew_offset]);
1653         goto L9999;
1654     }
1655 /* **********************************************************************
1656 */
1657 /*                          GENERAL PROCESSING */
1658 /* **********************************************************************
1659 */
1660 /* -------------------------- Initialization ---------------------------
1661 */
1662
1663     x0 = -(*u1 + *u0) / (*u1 - *u0);
1664     x1 = 2. / (*u1 - *u0);
1665     i__1 = *ndim;
1666     for (nd = 1; nd <= i__1; ++nd) {
1667         crvnew[nd + crvnew_dim1] = crvold[nd * crvold_dim1 + 1];
1668 /* L100: */
1669     }
1670     if (*ncoeff == 1) {
1671         goto L9999;
1672     }
1673     tabaux[0] = x0;
1674     tabaux[1] = x1;
1675
1676 /* ----------------------- Calculation of coeff. of CRVNEW ------------------
1677 */
1678
1679     i__1 = *ncoeff - 1;
1680     for (ncf = 2; ncf <= i__1; ++ncf) {
1681
1682 /* ------------ Take into account the NCF-th coeff. of CRVOLD --------
1683 ---- */
1684
1685         i__2 = ncf - 1;
1686         for (ncj = 1; ncj <= i__2; ++ncj) {
1687             bid = tabaux[ncj - 1];
1688             i__3 = *ndim;
1689             for (nd = 1; nd <= i__3; ++nd) {
1690                 crvnew[nd + ncj * crvnew_dim1] += crvold[ncf + nd *
1691                         crvold_dim1] * bid;
1692 /* L400: */
1693             }
1694 /* L300: */
1695         }
1696
1697         bid = tabaux[ncf - 1];
1698         i__2 = *ndim;
1699         for (nd = 1; nd <= i__2; ++nd) {
1700             crvnew[nd + ncf * crvnew_dim1] = crvold[ncf + nd * crvold_dim1] *
1701                     bid;
1702 /* L500: */
1703         }
1704
1705 /* --------- Calculation of (NCF+1) coeff. of [X1*t + X0]**(NCF) --------
1706 ---- */
1707
1708         tabaux[ncf] = tabaux[ncf - 1] * x1;
1709         for (ncj = ncf; ncj >= 2; --ncj) {
1710             tabaux[ncj - 1] = tabaux[ncj - 1] * x0 + tabaux[ncj - 2] * x1;
1711 /* L600: */
1712         }
1713         tabaux[0] *= x0;
1714
1715 /* L200: */
1716     }
1717
1718 /* -------------- Take into account the last coeff. of CRVOLD -----------
1719 */
1720
1721     i__1 = *ncoeff - 1;
1722     for (ncj = 1; ncj <= i__1; ++ncj) {
1723         bid = tabaux[ncj - 1];
1724         i__2 = *ndim;
1725         for (nd = 1; nd <= i__2; ++nd) {
1726             crvnew[nd + ncj * crvnew_dim1] += crvold[*ncoeff + nd *
1727                     crvold_dim1] * bid;
1728 /* L800: */
1729         }
1730 /* L700: */
1731     }
1732     i__1 = *ndim;
1733     for (nd = 1; nd <= i__1; ++nd) {
1734         crvnew[nd + *ncoeff * crvnew_dim1] = crvold[*ncoeff + nd *
1735                 crvold_dim1] * tabaux[*ncoeff - 1];
1736 /* L900: */
1737     }
1738
1739 /* ---------------------------- The end ---------------------------------
1740 */
1741
1742 L9999:
1743     if (*iercod > 0) {
1744         AdvApp2Var_SysBase::maermsg_("MMARCIN", iercod, 7L);
1745     }
1746     if (ibb >= 2) {
1747         AdvApp2Var_SysBase::mgsomsg_("MMARCIN", 7L);
1748     }
1749     return 0;
1750 } /* mmarcin_ */
1751
1752 //=======================================================================
1753 //function : mmatvec_
1754 //purpose  :
1755 //=======================================================================
1756 int mmatvec_(integer *nligne,
1757              integer *,//ncolon,
1758              integer *gposit,
1759              integer *,//gnstoc,
1760              doublereal *gmatri,
1761              doublereal *vecin,
1762              integer *deblig,
1763              doublereal *vecout,
1764              integer *iercod)
1765
1766 {
1767   /* System generated locals */
1768   integer i__1, i__2;
1769
1770   /* Local variables */
1771     logical ldbg;
1772   integer jmin, jmax, i__, j, k;
1773   doublereal somme;
1774   integer aux;
1775
1776
1777 /* ***********************************************************************
1778  */
1779
1780 /*     FUNCTION : */
1781 /*     ---------- */
1782 /*      Produce vector matrix in form of profile */
1783
1784
1785 /*     MOTS CLES : */
1786 /*     ----------- */
1787 /*      RESERVE, MATRIX, PRODUCT, VECTOR, PROFILE */
1788
1789 /*     INPUT ARGUMENTS : */
1790 /*     -------------------- */
1791 /*       NLIGNE : Line number of the matrix of constraints */
1792 /*       NCOLON : Number of column of the matrix of constraints */
1793 /*       GNSTOC: Number of coefficients in the profile of matrix GMATRI */
1794
1795 /*       GPOSIT: Table of positioning of terms of storage */
1796 /*               GPOSIT(1,I) contains the number of terms-1 on the line I
1797 /*               in the profile of the matrix. */
1798 /*              GPOSIT(2,I) contains the index of storage of diagonal term*/
1799 /*               of line I */
1800 /*               GPOSIT(3,I) contains the index of column of the first term of */
1801 /*                           profile of line I */
1802 /*       GNSTOC: Number of coefficients in the profile of matrix */
1803 /*               GMATRI */
1804 /*       GMATRI : Matrix of constraints in form of profile */
1805 /*       VECIN  : Input vector */
1806 /*       DEBLIG : Line indexusing which the vector matrix is calculated */
1807 /*
1808 /*     OUTPUT ARGUMENTS */
1809 /*     --------------------- */
1810 /*       VECOUT : VECTOR PRODUCT */
1811
1812 /*       IERCOD : ERROR CODE */
1813
1814
1815 /*     COMMONS USED : */
1816 /*     ------------------ */
1817
1818
1819 /*     REFERENCES CALLED : */
1820 /*     --------------------- */
1821
1822
1823 /*     DESCRIPTION/NOTES/LIMITATIONS : */
1824 /*     ----------------------------------- */
1825
1826 /* ***********************************************************************
1827  */
1828 /*                            DECLARATIONS */
1829 /* ***********************************************************************
1830  */
1831
1832
1833
1834 /* ***********************************************************************
1835  */
1836 /*                      INITIALISATIONS */
1837 /* ***********************************************************************
1838  */
1839
1840     /* Parameter adjustments */
1841     --vecout;
1842     gposit -= 4;
1843     --vecin;
1844     --gmatri;
1845
1846     /* Function Body */
1847     ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 2;
1848     if (ldbg) {
1849         AdvApp2Var_SysBase::mgenmsg_("MMATVEC", 7L);
1850     }
1851     *iercod = 0;
1852
1853 /* ***********************************************************************
1854  */
1855 /*                    Processing */
1856 /* ***********************************************************************
1857  */
1858     AdvApp2Var_SysBase::mvriraz_(nligne,
1859              &vecout[1]);
1860     i__1 = *nligne;
1861     for (i__ = *deblig; i__ <= i__1; ++i__) {
1862         somme = 0.;
1863         jmin = gposit[i__ * 3 + 3];
1864         jmax = gposit[i__ * 3 + 1] + gposit[i__ * 3 + 3] - 1;
1865         aux = gposit[i__ * 3 + 2] - gposit[i__ * 3 + 1] - jmin + 1;
1866         i__2 = jmax;
1867         for (j = jmin; j <= i__2; ++j) {
1868             k = j + aux;
1869             somme += gmatri[k] * vecin[j];
1870         }
1871         vecout[i__] = somme;
1872     }
1873
1874
1875
1876
1877
1878     goto L9999;
1879
1880 /* ***********************************************************************
1881  */
1882 /*                   ERROR PROCESSING */
1883 /* ***********************************************************************
1884  */
1885
1886
1887
1888
1889 /* ***********************************************************************
1890  */
1891 /*                   RETURN CALLING PROGRAM */
1892 /* ***********************************************************************
1893  */
1894
1895 L9999:
1896
1897 /* ___ DESALLOCATION, ... */
1898
1899     AdvApp2Var_SysBase::maermsg_("MMATVEC", iercod, 7L);
1900     if (ldbg) {
1901         AdvApp2Var_SysBase::mgsomsg_("MMATVEC", 7L);
1902     }
1903
1904  return 0 ;
1905 } /* mmatvec_ */
1906
1907 //=======================================================================
1908 //function : mmbulld_
1909 //purpose  :
1910 //=======================================================================
1911 int AdvApp2Var_MathBase::mmbulld_(integer *nbcoln,
1912                                   integer *nblign,
1913                                   doublereal *dtabtr,
1914                                   integer *numcle)
1915
1916 {
1917   /* System generated locals */
1918   integer dtabtr_dim1, dtabtr_offset, i__1, i__2;
1919
1920   /* Local variables */
1921   logical ldbg;
1922   doublereal daux;
1923   integer nite1, nite2, nchan, i1, i2;
1924
1925 /* ***********************************************************************
1926  */
1927
1928 /*     FUNCTION : */
1929 /*     ---------- */
1930 /*        Parsing of columns of a table of integers in increasing order */
1931 /*     KEYWORDS : */
1932 /*     ----------- */
1933 /*     POINT-ENTRY, PARSING */
1934 /*     INPUT ARGUMENTS : */
1935 /*     -------------------- */
1936 /*       - NBCOLN : Number of columns in the table */
1937 /*       - NBLIGN : Number of lines in the table */
1938 /*       - DTABTR : Table of integers to be parsed */
1939 /*       - NUMCLE : Position of the key on the column */
1940
1941 /*     OUTPUT ARGUMENTS : */
1942 /*     --------------------- */
1943 /*       - DTABTR : Parsed table */
1944
1945 /*     COMMONS USED : */
1946 /*     ------------------ */
1947
1948
1949 /*     REFERENCES CALLED : */
1950 /*     --------------------- */
1951
1952
1953 /*     DESCRIPTION/NOTES/LIMITATIONS : */
1954 /*     ----------------------------------- */
1955 /*     Particularly performant if the table is almost parsed */
1956 /*     In the opposite case it is better to use MVSHELD */
1957 /* ***********************************************************************
1958  */
1959
1960     /* Parameter adjustments */
1961     dtabtr_dim1 = *nblign;
1962     dtabtr_offset = dtabtr_dim1 + 1;
1963     dtabtr -= dtabtr_offset;
1964
1965     /* Function Body */
1966     ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 2;
1967     if (ldbg) {
1968         AdvApp2Var_SysBase::mgenmsg_("MMBULLD", 7L);
1969     }
1970     nchan = 1;
1971     nite1 = *nbcoln;
1972     nite2 = 2;
1973
1974 /* ***********************************************************************
1975  */
1976 /*                     PROCESSING */
1977 /* ***********************************************************************
1978  */
1979
1980 /* ---->ALGORITHM in N^2 / 2 additional iteration */
1981
1982     while(nchan != 0) {
1983
1984 /* ----> Parsing from left to the right */
1985
1986         nchan = 0;
1987         i__1 = nite1;
1988         for (i1 = nite2; i1 <= i__1; ++i1) {
1989             if (dtabtr[*numcle + i1 * dtabtr_dim1] < dtabtr[*numcle + (i1 - 1)
1990                      * dtabtr_dim1]) {
1991                 i__2 = *nblign;
1992                 for (i2 = 1; i2 <= i__2; ++i2) {
1993                     daux = dtabtr[i2 + (i1 - 1) * dtabtr_dim1];
1994                     dtabtr[i2 + (i1 - 1) * dtabtr_dim1] = dtabtr[i2 + i1 *
1995                             dtabtr_dim1];
1996                     dtabtr[i2 + i1 * dtabtr_dim1] = daux;
1997                 }
1998                 if (nchan == 0) {
1999                     nchan = 1;
2000                 }
2001             }
2002         }
2003         --nite1;
2004
2005 /* ----> Parsing from right to the left */
2006
2007         if (nchan != 0) {
2008             nchan = 0;
2009             i__1 = nite2;
2010             for (i1 = nite1; i1 >= i__1; --i1) {
2011                 if (dtabtr[*numcle + i1 * dtabtr_dim1] < dtabtr[*numcle + (i1
2012                         - 1) * dtabtr_dim1]) {
2013                     i__2 = *nblign;
2014                     for (i2 = 1; i2 <= i__2; ++i2) {
2015                         daux = dtabtr[i2 + (i1 - 1) * dtabtr_dim1];
2016                         dtabtr[i2 + (i1 - 1) * dtabtr_dim1] = dtabtr[i2 + i1 *
2017                                  dtabtr_dim1];
2018                         dtabtr[i2 + i1 * dtabtr_dim1] = daux;
2019                     }
2020                     if (nchan == 0) {
2021                         nchan = 1;
2022                     }
2023                 }
2024             }
2025             ++nite2;
2026         }
2027     }
2028
2029
2030     goto L9999;
2031
2032 /* ***********************************************************************
2033  */
2034 /*                   ERROR PROCESSING */
2035 /* ***********************************************************************
2036  */
2037
2038 /* ----> No errors at calling functions, only tests and loops. */
2039
2040 /* ***********************************************************************
2041  */
2042 /*                   RETURN CALLING PROGRAM */
2043 /* ***********************************************************************
2044  */
2045
2046 L9999:
2047
2048     if (ldbg) {
2049         AdvApp2Var_SysBase::mgsomsg_("MMBULLD", 7L);
2050     }
2051
2052  return 0 ;
2053 } /* mmbulld_ */
2054
2055
2056 //=======================================================================
2057 //function : AdvApp2Var_MathBase::mmcdriv_
2058 //purpose  :
2059 //=======================================================================
2060 int AdvApp2Var_MathBase::mmcdriv_(integer *ndimen,
2061                                   integer *ncoeff,
2062                                   doublereal *courbe,
2063                                   integer *ideriv,
2064                                   integer *ncofdv,
2065                                   doublereal *crvdrv)
2066
2067
2068 {
2069   /* System generated locals */
2070   integer courbe_dim1, courbe_offset, crvdrv_dim1, crvdrv_offset, i__1,
2071   i__2;
2072
2073   /* Local variables */
2074   integer i__, j, k;
2075   doublereal mfactk, bid;
2076
2077
2078 /* ***********************************************************************
2079  */
2080
2081 /*     FUNCTION : */
2082 /*     ---------- */
2083 /*     Calculate matrix of a derivate curve of order IDERIV. */
2084 /*     with input parameters other than output parameters. */
2085
2086
2087 /*     KEYWORDS : */
2088 /*     ----------- */
2089 /*     COEFFICIENTS,CURVE,DERIVATE I-EME. */
2090
2091 /*     INPUT ARGUMENTS : */
2092 /*     ------------------ */
2093 /*   NDIMEN  : Space dimension (2 or 3 in general) */
2094 /*   NCOEFF  : Degree +1 of the curve. */
2095 /*   COURBE  : Table of coefficients of the curve. */
2096 /*   IDERIV  : Required order of derivation : 1=1st derivate, etc... */
2097
2098 /*     OUTPUT ARGUMENTS : */
2099 /*     ------------------- */
2100 /*   NCOFDV  : Degree +1 of the derivative of order IDERIV of the curve. */
2101 /*   CRVDRV  : Table of coefficients of the derivative of order IDERIV */
2102 /*            of the curve. */
2103
2104 /*     COMMONS USED   : */
2105 /*     ---------------- */
2106
2107 /*     REFERENCES CALLED   : */
2108 /*     ----------------------- */
2109
2110 /*     DESCRIPTION/NOTES/LIMITATIONS : */
2111 /*     ----------------------------------- */
2112
2113 /* ---> It is possible to take as output argument the curve */
2114 /*     and the number of coeff passed at input by making : */
2115 /*        CALL MMCDRIV(NDIMEN,NCOEFF,COURBE,IDERIV,NCOEFF,COURBE). */
2116 /*     After this call, NCOEFF does the number of coeff of the derived */
2117 /*     curve the coefficients which of are stored in CURVE. */
2118 /*     Attention to the coefficients of CURVE of rank superior to */
2119 /*     NCOEFF : they are not set to zero. */
2120
2121 /* ---> Algorithm : */
2122 /*     The code below was written basing on the following algorithm:
2123 */
2124
2125 /*     Let P(t) = a1 + a2*t + ... an*t**n. Derivate of order k of P */
2126 /*     (containing n-k coefficients) is calculated as follows : */
2127
2128 /*       Pk(t) = a(k+1)*CNP(k,k)*k! */
2129 /*             + a(k+2)*CNP(k+1,k)*k! * t */
2130 /*             . */
2131 /*             . */
2132 /*             . */
2133 /*             + a(n)*CNP(n-1,k)*k! * t**(n-k-1). */
2134 /* ***********************************************************************
2135  */
2136
2137
2138 /* -------------- Case when the order of derivative is  -------------------
2139 */
2140 /* ---------------- greater than the degree of the curve ---------------------
2141 */
2142
2143 /* **********************************************************************
2144 */
2145
2146 /*     FUNCTION : */
2147 /*     ---------- */
2148 /*      Serves to provide the coefficients of binome (Pascal's triangle). */
2149
2150 /*     KEYWORDS : */
2151 /*     ----------- */
2152 /*      Binomial coeff from 0 to 60. read only . init par block data */
2153
2154 /*     DEMSCRIPTION/NOTES/LIMITATIONS : */
2155 /*     ----------------------------------- */
2156 /*     Binomial coefficients form a triangular matrix. */
2157 /*     This matrix is completed in table CNP by its transposition. */
2158 /*     So: CNP(I,J) = CNP(J,I) for I and J = 0, ..., 60. */
2159
2160 /*     Initialization is done by block-data MMLLL09.RES, */
2161 /*     created by program MQINICNP.FOR). */
2162 /* **********************************************************************
2163 */
2164
2165
2166
2167 /* ***********************************************************************
2168  */
2169
2170     /* Parameter adjustments */
2171     crvdrv_dim1 = *ndimen;
2172     crvdrv_offset = crvdrv_dim1 + 1;
2173     crvdrv -= crvdrv_offset;
2174     courbe_dim1 = *ndimen;
2175     courbe_offset = courbe_dim1 + 1;
2176     courbe -= courbe_offset;
2177
2178     /* Function Body */
2179     if (*ideriv >= *ncoeff) {
2180         i__1 = *ndimen;
2181         for (i__ = 1; i__ <= i__1; ++i__) {
2182             crvdrv[i__ + crvdrv_dim1] = 0.;
2183 /* L10: */
2184         }
2185         *ncofdv = 1;
2186         goto L9999;
2187     }
2188 /* **********************************************************************
2189 */
2190 /*                        General processing */
2191 /* **********************************************************************
2192 */
2193 /* --------------------- Calculation of Factorial(IDERIV) ------------------
2194 */
2195
2196     k = *ideriv;
2197     mfactk = 1.;
2198     i__1 = k;
2199     for (i__ = 2; i__ <= i__1; ++i__) {
2200         mfactk *= i__;
2201 /* L50: */
2202     }
2203
2204 /* ------------ Calculation of coeff of the derived of order IDERIV ----------
2205 */
2206 /* ---> Attention :  coefficient binomial C(n,m) is represented in */
2207 /*                 MCCNP by CNP(N+1,M+1). */
2208
2209     i__1 = *ncoeff;
2210     for (j = k + 1; j <= i__1; ++j) {
2211         bid = mmcmcnp_.cnp[j - 1 + k * 61] * mfactk;
2212         i__2 = *ndimen;
2213         for (i__ = 1; i__ <= i__2; ++i__) {
2214             crvdrv[i__ + (j - k) * crvdrv_dim1] = bid * courbe[i__ + j *
2215                     courbe_dim1];
2216 /* L200: */
2217         }
2218 /* L100: */
2219     }
2220
2221     *ncofdv = *ncoeff - *ideriv;
2222
2223 /* -------------------------------- The end -----------------------------
2224 */
2225
2226 L9999:
2227     return 0;
2228 } /* mmcdriv_ */
2229
2230 //=======================================================================
2231 //function : AdvApp2Var_MathBase::mmcglc1_
2232 //purpose  :
2233 //=======================================================================
2234 int AdvApp2Var_MathBase::mmcglc1_(integer *ndimax,
2235                                   integer *ndimen,
2236                                   integer *ncoeff,
2237                                   doublereal *courbe,
2238                                   doublereal *tdebut,
2239                                   doublereal *tfinal,
2240                                   doublereal *epsiln,
2241                                   doublereal *xlongc,
2242                                   doublereal *erreur,
2243                                   integer *iercod)
2244
2245
2246 {
2247   /* System generated locals */
2248   integer courbe_dim1, courbe_offset, i__1;
2249   doublereal d__1;
2250
2251   /* Local variables */
2252   integer ndec;
2253   doublereal tdeb, tfin;
2254   integer iter;
2255   doublereal oldso;
2256   integer itmax;
2257   doublereal sottc;
2258   integer kk, ibb;
2259   doublereal dif, pas;
2260   doublereal som;
2261
2262
2263 /* ***********************************************************************
2264  */
2265
2266 /*     FUNCTION : */
2267 /*     ---------- */
2268 /*      Allows calculating the length of an arc of curve POLYNOMIAL */
2269 /*      on an interval [A,B]. */
2270
2271 /*     KEYWORDS : */
2272 /*     ----------- */
2273 /*        LENGTH,CURVE,GAUSS,PRIVATE. */
2274
2275 /*     INPUT ARGUMENTS : */
2276 /*     ------------------ */
2277 /*      NDIMAX : Max. number of lines of tables */
2278 /*               (i.e. max. nb of polynoms). */
2279 /*      NDIMEN : Dimension of the space (nb of polynoms). */
2280 /*      NCOEFF : Nb of coefficients of the polynom. This is degree + 1.
2281 */
2282 /*      COURBE(NDIMAX,NCOEFF) : Coefficients of the curve. */
2283 /*      TDEBUT : Lower limit of the interval of integration for  */
2284 /*               length calculation. */
2285 /*      TFINAL : Upper limit of the interval of integration for */
2286 /*               length calculation. */
2287 /*      EPSILN : REQIRED precision for length calculation. */
2288
2289 /*     OUTPUT ARGUMENTS : */
2290 /*     ------------------- */
2291 /*      XLONGC : Length of the arc of curve */
2292 /*      ERREUR : Precision OBTAINED for the length calculation. */
2293 /*      IERCOD : Error code, 0 OK, >0 Serious error. */
2294 /*               = 1 Too much iterations, the best calculated resultat */
2295 /*                   (is almost ERROR) */
2296 /*               = 2 Pb MMLONCV (no result) */
2297 /*               = 3 NDIM or NCOEFF invalid (no result) */
2298
2299 /*     COMMONS USED : */
2300 /*     ---------------- */
2301
2302 /*     REFERENCES CALLED : */
2303 /*     ----------------------- */
2304
2305 /*     DESCRIPTION/NOTES/LIMITATIONS : */
2306 /*     ----------------------------------- */
2307 /*      The polynom is actually a set of polynoms with */
2308 /*      coefficients arranged in a table of 2 indices, */
2309 /*      each line relative to the polynom. */
2310 /*      The polynom is defined by these coefficients ordered */
2311 /*      by increasing power of the variable. */
2312 /*      All polynoms have the same number of coefficients (the */
2313 /*      same degree). */
2314
2315 /*      This program cancels and replaces LENGCV, MLONGC and MLENCV. */
2316
2317 /*      ATTENTION : if TDEBUT > TFINAL, the length is NEGATIVE. */
2318
2319 /* > */
2320 /* ***********************************************************************
2321  */
2322
2323 /*   Name of the routine */
2324
2325
2326 /* ------------------------ General Initialization ---------------------
2327 */
2328
2329     /* Parameter adjustments */
2330     courbe_dim1 = *ndimax;
2331     courbe_offset = courbe_dim1 + 1;
2332     courbe -= courbe_offset;
2333
2334     /* Function Body */
2335     ibb = AdvApp2Var_SysBase::mnfndeb_();
2336     if (ibb >= 2) {
2337         AdvApp2Var_SysBase::mgenmsg_("MMCGLC1", 7L);
2338     }
2339
2340     *iercod = 0;
2341     *xlongc = 0.;
2342     *erreur = 0.;
2343
2344 /* ------ Test of equity of limits */
2345
2346     if (*tdebut == *tfinal) {
2347         *iercod = 0;
2348         goto L9999;
2349     }
2350
2351 /* ------ Test of the dimension and the number of coefficients */
2352
2353     if (*ndimen <= 0 || *ncoeff <= 0) {
2354         goto L9003;
2355     }
2356
2357 /* ----- Nb of current cutting, nb of iteration, */
2358 /*       max nb of iterations */
2359
2360     ndec = 1;
2361     iter = 1;
2362
2363     itmax = 13;
2364
2365 /* ------ Variation of the nb of intervals */
2366 /*       Multiplied by 2 at each iteration */
2367
2368 L5000:
2369     pas = (*tfinal - *tdebut) / ndec;
2370     sottc = 0.;
2371
2372 /* ------ Loop on all current NDEC intervals */
2373
2374     i__1 = ndec;
2375     for (kk = 1; kk <= i__1; ++kk) {
2376
2377 /* ------ Limits of the current integration interval */
2378
2379         tdeb = *tdebut + (kk - 1) * pas;
2380         tfin = tdeb + pas;
2381         mmloncv_(ndimax, ndimen, ncoeff, &courbe[courbe_offset], &tdeb, &tfin,
2382                  &som, iercod);
2383         if (*iercod > 0) {
2384             goto L9002;
2385         }
2386
2387         sottc += som;
2388
2389 /* L100: */
2390     }
2391
2392
2393 /* ----------------- Test of the maximum number of iterations ------------
2394 */
2395
2396 /*  Test if passes at least once ** */
2397
2398     if (iter == 1) {
2399         oldso = sottc;
2400         ndec <<= 1;
2401         ++iter;
2402         goto L5000;
2403     } else {
2404
2405 /* ------ Take into account DIF - Test of convergence */
2406
2407         ++iter;
2408         dif = (d__1 = sottc - oldso, advapp_abs(d__1));
2409
2410 /* ------ If DIF is OK, leave..., otherwise: */
2411
2412         if (dif > *epsiln) {
2413
2414 /* ------ If nb iteration exceeded, leave */
2415
2416             if (iter > itmax) {
2417                 *iercod = 1;
2418                 goto L9000;
2419             } else {
2420
2421 /* ------ Otherwise continue by cutting the initial interval.
2422  */
2423
2424                 oldso = sottc;
2425                 ndec <<= 1;
2426                 goto L5000;
2427             }
2428         }
2429     }
2430
2431 /* ------------------------------ THE END -------------------------------
2432 */
2433
2434 L9000:
2435     *xlongc = sottc;
2436     *erreur = dif;
2437     goto L9999;
2438
2439 /* ---> PB in MMLONCV */
2440
2441 L9002:
2442     *iercod = 2;
2443     goto L9999;
2444
2445 /* ---> NCOEFF or NDIM invalid. */
2446
2447 L9003:
2448     *iercod = 3;
2449     goto L9999;
2450
2451 L9999:
2452     if (*iercod > 0) {
2453         AdvApp2Var_SysBase::maermsg_("MMCGLC1", iercod, 7L);
2454     }
2455     if (ibb >= 2) {
2456         AdvApp2Var_SysBase::mgsomsg_("MMCGLC1", 7L);
2457     }
2458     return 0;
2459 } /* mmcglc1_ */
2460
2461 //=======================================================================
2462 //function : mmchole_
2463 //purpose  :
2464 //=======================================================================
2465 int mmchole_(integer *,//mxcoef,
2466              integer *dimens,
2467              doublereal *amatri,
2468              integer *aposit,
2469              integer *posuiv,
2470              doublereal *chomat,
2471              integer *iercod)
2472
2473 {
2474   /* System generated locals */
2475   integer i__1, i__2, i__3;
2476   doublereal d__1;
2477
2478   /* Builtin functions */
2479   //double sqrt();
2480
2481     /* Local variables */
2482   logical ldbg;
2483   integer kmin, i__, j, k;
2484   doublereal somme;
2485   integer ptini, ptcou;
2486
2487
2488 /* ***********************************************************************
2489  */
2490
2491 /*     FUNCTION : */
2492 /*     ----------                                                  T */
2493 /*     Produce decomposition of choleski of matrix A in S.S */
2494 /*     Calculate inferior triangular matrix S. */
2495
2496 /*     KEYWORDS : */
2497 /*     ----------- */
2498 /*     RESOLUTION, MFACTORISATION, MATRIX_PROFILE, CHOLESKI */
2499
2500 /*     INPUT ARGUMENTS : */
2501 /*     -------------------- */
2502 /*     MXCOEF : Max number of terms in the hessian profile */
2503 /*     DIMENS : Dimension of the problem */
2504 /*     AMATRI(MXCOEF) : Coefficients of the matrix profile */
2505 /*        APOSIT(1,*) : Distance diagonal-left extremity of the line
2506 */
2507 /*        APOSIT(2,*) : Position of diagonal terms in HESSIE */
2508 /*     POSUIV(MXCOEF) :  first line inferior not out of profile */
2509
2510 /*     OUTPUT ARGUMENTS : */
2511 /*     --------------------- */
2512 /*      CHOMAT(MXCOEF) : Inferior triangular matrix preserving the */
2513 /*                       profile of AMATRI. */
2514 /*      IERCOD : error code */
2515 /*               = 0 : ok */
2516 /*               = 1 : non-defined positive matrix */
2517
2518 /*     COMMONS USED : */
2519 /*     ------------------ */
2520
2521 /*      .Neant. */
2522
2523 /*     REFERENCES CALLED   : */
2524 /*     ---------------------- */
2525
2526 /*     DESCRIPTION/NOTES/LIMITATIONS : */
2527 /*     ----------------------------------- */
2528 /*     DEBUG LEVEL = 4 */
2529 /* ***********************************************************************
2530  */
2531 /*                            DECLARATIONS */
2532 /* ***********************************************************************
2533  */
2534
2535
2536
2537 /* ***********************************************************************
2538  */
2539 /*                      INITIALISATIONS */
2540 /* ***********************************************************************
2541  */
2542
2543     /* Parameter adjustments */
2544     --chomat;
2545     --posuiv;
2546     --amatri;
2547     aposit -= 3;
2548
2549     /* Function Body */
2550     ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 4;
2551     if (ldbg) {
2552         AdvApp2Var_SysBase::mgenmsg_("MMCHOLE", 7L);
2553     }
2554     *iercod = 0;
2555
2556 /* ***********************************************************************
2557  */
2558 /*                    PROCESSING */
2559 /* ***********************************************************************
2560  */
2561
2562     i__1 = *dimens;
2563     for (j = 1; j <= i__1; ++j) {
2564
2565         ptini = aposit[(j << 1) + 2];
2566
2567         somme = 0.;
2568         i__2 = ptini - 1;
2569         for (k = ptini - aposit[(j << 1) + 1]; k <= i__2; ++k) {
2570 /* Computing 2nd power */
2571             d__1 = chomat[k];
2572             somme += d__1 * d__1;
2573         }
2574
2575         if (amatri[ptini] - somme < 1e-32) {
2576             goto L9101;
2577         }
2578         chomat[ptini] = sqrt(amatri[ptini] - somme);
2579
2580         ptcou = ptini;
2581
2582         while(posuiv[ptcou] > 0) {
2583
2584             i__ = posuiv[ptcou];
2585             ptcou = aposit[(i__ << 1) + 2] - (i__ - j);
2586
2587 /*           Calculate the sum of S  .S   for k =1 a j-1 */
2588 /*                               ik  jk */
2589             somme = 0.;
2590 /* Computing MAX */
2591             i__2 = i__ - aposit[(i__ << 1) + 1], i__3 = j - aposit[(j << 1) +
2592                     1];
2593             kmin = advapp_max(i__2,i__3);
2594             i__2 = j - 1;
2595             for (k = kmin; k <= i__2; ++k) {
2596                 somme += chomat[aposit[(i__ << 1) + 2] - (i__ - k)] * chomat[
2597                         aposit[(j << 1) + 2] - (j - k)];
2598             }
2599
2600             chomat[ptcou] = (amatri[ptcou] - somme) / chomat[ptini];
2601         }
2602     }
2603
2604     goto L9999;
2605
2606 /* ***********************************************************************
2607  */
2608 /*                   ERROR PROCESSING */
2609 /* ***********************************************************************
2610  */
2611
2612 L9101:
2613     *iercod = 1;
2614     goto L9999;
2615
2616 /* ***********************************************************************
2617  */
2618 /*                  RETURN CALLING PROGRAM */
2619 /* ***********************************************************************
2620  */
2621
2622 L9999:
2623
2624     AdvApp2Var_SysBase::maermsg_("MMCHOLE", iercod, 7L);
2625     if (ldbg) {
2626         AdvApp2Var_SysBase::mgsomsg_("MMCHOLE", 7L);
2627     }
2628
2629  return 0 ;
2630 } /* mmchole_ */
2631
2632 //=======================================================================
2633 //function : AdvApp2Var_MathBase::mmcvctx_
2634 //purpose  :
2635 //=======================================================================
2636 int AdvApp2Var_MathBase::mmcvctx_(integer *ndimen,
2637                                   integer *ncofmx,
2638                                   integer *nderiv,
2639                                   doublereal *ctrtes,
2640                                   doublereal *crvres,
2641                                   doublereal *tabaux,
2642                                   doublereal *xmatri,
2643                                   integer *iercod)
2644
2645 {
2646   /* System generated locals */
2647   integer ctrtes_dim1, ctrtes_offset, crvres_dim1, crvres_offset,
2648   xmatri_dim1, xmatri_offset, tabaux_dim1, tabaux_offset, i__1,
2649   i__2;
2650
2651   /* Local variables */
2652   integer moup1, nordr;
2653   integer nd;
2654   integer ibb, ncf, ndv;
2655   doublereal eps1;
2656
2657
2658 /* ***********************************************************************
2659  */
2660
2661 /*     FUNCTION : */
2662 /*     ---------- */
2663 /*        Calculate a polynomial curve checking the  */
2664 /*        passage constraints (interpolation) */
2665 /*        from first derivatives, etc... to extremities. */
2666 /*        Parameters at the extremities are supposed to be -1 and 1. */
2667
2668 /*     KEYWORDS : */
2669 /*     ----------- */
2670 /*     ALL, AB_SPECIFI::CONSTRAINTS&,INTERPOLATION,&CURVE */
2671
2672 /*     INPUT ARGUMENTS : */
2673 /*     ------------------ */
2674 /*     NDIMEN : Space Dimension. */
2675 /*     NCOFMX : Nb of coeff. of curve CRVRES on each */
2676 /*              dimension. */
2677 /*     NDERIV : Order of constraint with derivatives : */
2678 /*              0 --> interpolation simple. */
2679 /*              1 --> interpolation+constraints with 1st. */
2680 /*              2 --> cas (0)+ (1) +   "         "   2nd derivatives. */
2681 /*                 etc... */
2682 /*     CTRTES : Table of constraints. */
2683 /*              CTRTES(*,1,*) = contraints at -1. */
2684 /*              CTRTES(*,2,*) = contraints at  1. */
2685
2686 /*     OUTPUT ARGUMENTS : */
2687 /*     ------------------- */
2688 /*     CRVRES : Resulting curve defined on (-1,1). */
2689 /*     TABAUX : Auxilliary matrix. */
2690 /*     XMATRI : Auxilliary matrix. */
2691
2692 /*     COMMONS UTILISES   : */
2693 /*     ---------------- */
2694
2695 /*      .Neant. */
2696
2697 /*     REFERENCES CALLED   : */
2698 /*     ---------------------- */
2699 /*     Type  Name */
2700 /*           MAERMSG         R*8  DFLOAT              MGENMSG */
2701 /*           MGSOMSG              MMEPS1               MMRSLW */
2702 /*      I*4  MNFNDEB */
2703
2704 /*     DESCRIPTION/NOTES/LIMITATIONS : */
2705 /*     ----------------------------------- */
2706 /*        The polynom (or the curve) is calculated by solving a */
2707 /*        system of linear equations. If the imposed degree is great */
2708 /*        it is preferable to call a routine based on */
2709 /*        Lagrange or Hermite interpolation depending on the case. */
2710 /*        (for a high degree the matrix of the system can be badly */
2711 /*        conditionned). */
2712 /*        This routine returns a curve defined in (-1,1). */
2713 /*        In general case, it is necessary to use MCVCTG. */
2714 /* > */
2715 /* ***********************************************************************
2716  */
2717
2718 /*   Name of the routine */
2719
2720
2721     /* Parameter adjustments */
2722     crvres_dim1 = *ncofmx;
2723     crvres_offset = crvres_dim1 + 1;
2724     crvres -= crvres_offset;
2725     xmatri_dim1 = *nderiv + 1;
2726     xmatri_offset = xmatri_dim1 + 1;
2727     xmatri -= xmatri_offset;
2728     tabaux_dim1 = *nderiv + 1 + *ndimen;
2729     tabaux_offset = tabaux_dim1 + 1;
2730     tabaux -= tabaux_offset;
2731     ctrtes_dim1 = *ndimen;
2732     ctrtes_offset = ctrtes_dim1 * 3 + 1;
2733     ctrtes -= ctrtes_offset;
2734
2735     /* Function Body */
2736     ibb = AdvApp2Var_SysBase::mnfndeb_();
2737     if (ibb >= 3) {
2738         AdvApp2Var_SysBase::mgenmsg_("MMCVCTX", 7L);
2739     }
2740 /*   Precision. */
2741     AdvApp2Var_MathBase::mmeps1_(&eps1);
2742
2743 /* ****************** CALCULATION OF EVEN COEFFICIENTS *********************
2744 */
2745 /* ------------------------- Initialization -----------------------------
2746 */
2747
2748     nordr = *nderiv + 1;
2749     i__1 = nordr;
2750     for (ncf = 1; ncf <= i__1; ++ncf) {
2751         tabaux[ncf + tabaux_dim1] = 1.;
2752 /* L100: */
2753     }
2754
2755 /* ---------------- Calculation of terms corresponding to derivatives -------
2756 */
2757
2758     i__1 = nordr;
2759     for (ndv = 2; ndv <= i__1; ++ndv) {
2760         i__2 = nordr;
2761         for (ncf = 1; ncf <= i__2; ++ncf) {
2762             tabaux[ncf + ndv * tabaux_dim1] = tabaux[ncf + (ndv - 1) *
2763                     tabaux_dim1] * (doublereal) ((ncf << 1) - ndv);
2764 /* L300: */
2765         }
2766 /* L200: */
2767     }
2768
2769 /* ------------------ Writing the second member -----------------------
2770 */
2771
2772     moup1 = 1;
2773     i__1 = nordr;
2774     for (ndv = 1; ndv <= i__1; ++ndv) {
2775         i__2 = *ndimen;
2776         for (nd = 1; nd <= i__2; ++nd) {
2777             tabaux[nordr + nd + ndv * tabaux_dim1] = (ctrtes[nd + ((ndv << 1)
2778                     + 2) * ctrtes_dim1] + moup1 * ctrtes[nd + ((ndv << 1) + 1)
2779                      * ctrtes_dim1]) / 2.;
2780 /* L500: */
2781         }
2782         moup1 = -moup1;
2783 /* L400: */
2784     }
2785
2786 /* -------------------- Resolution of the system ---------------------------
2787 */
2788
2789     mmrslw_(&nordr, &nordr, ndimen, &eps1, &tabaux[tabaux_offset], &xmatri[
2790             xmatri_offset], iercod);
2791     if (*iercod > 0) {
2792         goto L9999;
2793     }
2794     i__1 = *ndimen;
2795     for (nd = 1; nd <= i__1; ++nd) {
2796         i__2 = nordr;
2797         for (ncf = 1; ncf <= i__2; ++ncf) {
2798             crvres[(ncf << 1) - 1 + nd * crvres_dim1] = xmatri[ncf + nd *
2799                     xmatri_dim1];
2800 /* L700: */
2801         }
2802 /* L600: */
2803     }
2804
2805 /* ***************** CALCULATION OF UNEVEN COEFFICIENTS ********************
2806 */
2807 /* ------------------------- Initialization -----------------------------
2808 */
2809
2810
2811     i__1 = nordr;
2812     for (ncf = 1; ncf <= i__1; ++ncf) {
2813         tabaux[ncf + tabaux_dim1] = 1.;
2814 /* L1100: */
2815     }
2816
2817 /* ---------------- Calculation of terms corresponding to derivatives -------
2818 */
2819
2820     i__1 = nordr;
2821     for (ndv = 2; ndv <= i__1; ++ndv) {
2822         i__2 = nordr;
2823         for (ncf = 1; ncf <= i__2; ++ncf) {
2824             tabaux[ncf + ndv * tabaux_dim1] = tabaux[ncf + (ndv - 1) *
2825                     tabaux_dim1] * (doublereal) ((ncf << 1) - ndv + 1);
2826 /* L1300: */
2827         }
2828 /* L1200: */
2829     }
2830
2831 /* ------------------ Writing of the second member -----------------------
2832 */
2833
2834     moup1 = -1;
2835     i__1 = nordr;
2836     for (ndv = 1; ndv <= i__1; ++ndv) {
2837         i__2 = *ndimen;
2838         for (nd = 1; nd <= i__2; ++nd) {
2839             tabaux[nordr + nd + ndv * tabaux_dim1] = (ctrtes[nd + ((ndv << 1)
2840                     + 2) * ctrtes_dim1] + moup1 * ctrtes[nd + ((ndv << 1) + 1)
2841                      * ctrtes_dim1]) / 2.;
2842 /* L1500: */
2843         }
2844         moup1 = -moup1;
2845 /* L1400: */
2846     }
2847
2848 /* -------------------- Solution of the system ---------------------------
2849 */
2850
2851     mmrslw_(&nordr, &nordr, ndimen, &eps1, &tabaux[tabaux_offset], &xmatri[
2852             xmatri_offset], iercod);
2853     if (*iercod > 0) {
2854         goto L9999;
2855     }
2856     i__1 = *ndimen;
2857     for (nd = 1; nd <= i__1; ++nd) {
2858         i__2 = nordr;
2859         for (ncf = 1; ncf <= i__2; ++ncf) {
2860             crvres[(ncf << 1) + nd * crvres_dim1] = xmatri[ncf + nd *
2861                     xmatri_dim1];
2862 /* L1700: */
2863         }
2864 /* L1600: */
2865     }
2866
2867 /* --------------------------- The end ----------------------------------
2868 */
2869
2870 L9999:
2871     if (*iercod != 0) {
2872         AdvApp2Var_SysBase::maermsg_("MMCVCTX", iercod, 7L);
2873     }
2874     if (ibb >= 3) {
2875         AdvApp2Var_SysBase::mgsomsg_("MMCVCTX", 7L);
2876     }
2877
2878  return 0 ;
2879 } /* mmcvctx_ */
2880
2881 //=======================================================================
2882 //function : AdvApp2Var_MathBase::mmcvinv_
2883 //purpose  :
2884 //=======================================================================
2885  int AdvApp2Var_MathBase::mmcvinv_(integer *ndimax,
2886                             integer *ncoef,
2887                             integer *ndim,
2888                             doublereal *curveo,
2889                             doublereal *curve)
2890
2891 {
2892   /* Initialized data */
2893
2894   static char nomprg[8+1] = "MMCVINV ";
2895
2896   /* System generated locals */
2897   integer curve_dim1, curve_offset, curveo_dim1, curveo_offset, i__1, i__2;
2898
2899   /* Local variables */
2900   integer i__, nd, ibb;
2901
2902
2903 /* ***********************************************************************
2904  */
2905
2906 /*     FUNCTION : */
2907 /*     ---------- */
2908 /*        Inversion of arguments of the final curve. */
2909
2910 /*     KEYWORDS : */
2911 /*     ----------- */
2912 /*        SMOOTHING,CURVE */
2913
2914
2915 /*     INPUT ARGUMENTS : */
2916 /*     ------------------ */
2917
2918 /*        NDIM: Space Dimension. */
2919 /*        NCOEF: Degree of the polynom. */
2920 /*        CURVEO: The curve before inversion. */
2921
2922 /*     OUTPUT ARGUMENTS : */
2923 /*     ------------------- */
2924 /*        CURVE: The curve after inversion. */
2925
2926 /*     COMMONS USED : */
2927 /*     ---------------- */
2928 /*     REFERENCES APPELEES   : */
2929 /*     ----------------------- */
2930 /*     DESCRIPTION/NOTES/LIMITATIONS : */
2931 /*     ----------------------------------- */
2932 /* ***********************************************************************
2933  */
2934
2935 /*   The name of the routine */
2936     /* Parameter adjustments */
2937     curve_dim1 = *ndimax;
2938     curve_offset = curve_dim1 + 1;
2939     curve -= curve_offset;
2940     curveo_dim1 = *ncoef;
2941     curveo_offset = curveo_dim1 + 1;
2942     curveo -= curveo_offset;
2943
2944     /* Function Body */
2945
2946     ibb = AdvApp2Var_SysBase::mnfndeb_();
2947     if (ibb >= 2) {
2948         AdvApp2Var_SysBase::mgenmsg_(nomprg, 6L);
2949     }
2950
2951     i__1 = *ncoef;
2952     for (i__ = 1; i__ <= i__1; ++i__) {
2953         i__2 = *ndim;
2954         for (nd = 1; nd <= i__2; ++nd) {
2955             curve[nd + i__ * curve_dim1] = curveo[i__ + nd * curveo_dim1];
2956 /* L300: */
2957         }
2958     }
2959
2960 /* L9999: */
2961     return 0;
2962 } /* mmcvinv_ */
2963
2964 //=======================================================================
2965 //function : mmcvstd_
2966 //purpose  :
2967 //=======================================================================
2968 int mmcvstd_(integer *ncofmx,
2969              integer *ndimax,
2970              integer *ncoeff,
2971              integer *ndimen,
2972              doublereal *crvcan,
2973              doublereal *courbe)
2974
2975 {
2976   /* System generated locals */
2977   integer courbe_dim1, crvcan_dim1, crvcan_offset, i__1, i__2, i__3;
2978
2979   /* Local variables */
2980   integer ndeg, i__, j, j1, nd, ibb;
2981   doublereal bid;
2982
2983
2984 /* ***********************************************************************
2985  */
2986
2987 /*     FUNCTION : */
2988 /*     ---------- */
2989 /*        Transform curve defined between [-1,1] into [0,1]. */
2990
2991 /*     KEYWORDS : */
2992 /*     ----------- */
2993 /*        LIMITATION,RESTRICTION,CURVE */
2994
2995 /*     INPUT ARGUMENTS : */
2996 /*     ------------------ */
2997 /*        NDIMAX : Dimension of the space. */
2998 /*        NDIMEN : Dimension of the curve. */
2999 /*        NCOEFF : Degree of the curve. */
3000 /*        CRVCAN(NCOFMX,NDIMEN): The curve is defined at the interval [-1,1]. */
3001
3002 /*     OUTPUT ARGUMENTS : */
3003 /*     ------------------- */
3004 /*        CURVE(NDIMAX,NCOEFF): Curve defined at the interval [0,1]. */
3005
3006 /*     COMMONS USED   : */
3007 /*     ---------------- */
3008
3009 /*     REFERENCES CALLED   : */
3010 /*     ----------------------- */
3011
3012 /*     DESCRIPTION/NOTES/LIMITATIONS : */
3013 /*     ----------------------------------- */
3014 /* > */
3015 /* ***********************************************************************
3016  */
3017
3018 /*   Name of the program. */
3019
3020
3021 /* **********************************************************************
3022 */
3023
3024 /*     FUNCTION : */
3025 /*     ---------- */
3026 /*      Provides binomial coefficients (Pascal triangle). */
3027
3028 /*     KEYWORDS : */
3029 /*     ----------- */
3030 /*      Binomial coefficient from 0 to 60. read only . init by block data */
3031
3032 /*     DEMSCRIPTION/NOTES/LIMITATIONS : */
3033 /*     ----------------------------------- */
3034 /*     Binomial coefficients form a triangular matrix. */
3035 /*     This matrix is completed in table CNP by its transposition. */
3036 /*     So: CNP(I,J) = CNP(J,I) for I and J = 0, ..., 60. */
3037
3038 /*     Initialization is done with block-data MMLLL09.RES, */
3039 /*     created by the program MQINICNP.FOR. */
3040 /* > */
3041 /* **********************************************************************
3042 */
3043
3044
3045
3046 /* ***********************************************************************
3047  */
3048
3049     /* Parameter adjustments */
3050     courbe_dim1 = *ndimax;
3051     --courbe;
3052     crvcan_dim1 = *ncofmx;
3053     crvcan_offset = crvcan_dim1;
3054     crvcan -= crvcan_offset;
3055
3056     /* Function Body */
3057     ibb = AdvApp2Var_SysBase::mnfndeb_();
3058     if (ibb >= 3) {
3059         AdvApp2Var_SysBase::mgenmsg_("MMCVSTD", 7L);
3060     }
3061     ndeg = *ncoeff - 1;
3062
3063 /* ------------------ Construction of the resulting curve ----------------
3064 */
3065
3066     i__1 = *ndimen;
3067     for (nd = 1; nd <= i__1; ++nd) {
3068         i__2 = ndeg;
3069         for (j = 0; j <= i__2; ++j) {
3070             bid = 0.;
3071             i__3 = ndeg;
3072             for (i__ = j; i__ <= i__3; i__ += 2) {
3073                 bid += crvcan[i__ + nd * crvcan_dim1] * mmcmcnp_.cnp[i__ + j
3074                         * 61];
3075 /* L410: */
3076             }
3077             courbe[nd + j * courbe_dim1] = bid;
3078
3079             bid = 0.;
3080             j1 = j + 1;
3081             i__3 = ndeg;
3082             for (i__ = j1; i__ <= i__3; i__ += 2) {
3083                 bid += crvcan[i__ + nd * crvcan_dim1] * mmcmcnp_.cnp[i__ + j
3084                         * 61];
3085 /* L420: */
3086             }
3087             courbe[nd + j * courbe_dim1] -= bid;
3088 /* L400: */
3089         }
3090 /* L300: */
3091     }
3092
3093 /* ------------------- Renormalization of the CURVE -------------------------
3094  */
3095
3096     bid = 1.;
3097     i__1 = ndeg;
3098     for (i__ = 0; i__ <= i__1; ++i__) {
3099         i__2 = *ndimen;
3100         for (nd = 1; nd <= i__2; ++nd) {
3101             courbe[nd + i__ * courbe_dim1] *= bid;
3102 /* L510: */
3103         }
3104         bid *= 2.;
3105 /* L500: */
3106     }
3107
3108 /* ----------------------------- The end --------------------------------
3109 */
3110
3111     if (ibb >= 3) {
3112         AdvApp2Var_SysBase::mgsomsg_("MMCVSTD", 7L);
3113     }
3114     return 0;
3115 } /* mmcvstd_ */
3116
3117 //=======================================================================
3118 //function : AdvApp2Var_MathBase::mmdrc11_
3119 //purpose  :
3120 //=======================================================================
3121 int AdvApp2Var_MathBase::mmdrc11_(integer *iordre,
3122                                   integer *ndimen,
3123                                   integer *ncoeff,
3124                                   doublereal *courbe,
3125                                   doublereal *points,
3126                                   doublereal *mfactab)
3127
3128 {
3129   /* System generated locals */
3130   integer courbe_dim1, courbe_offset, points_dim2, points_offset, i__1,
3131   i__2;
3132
3133   /* Local variables */
3134
3135   integer ndeg, i__, j, ndgcb, nd, ibb;
3136
3137
3138 /* **********************************************************************
3139 */
3140
3141 /*     FUNCTION : */
3142 /*     ---------- */
3143 /*        Calculation of successive derivatives of equation CURVE with */
3144 /*        parameters -1, 1 from order 0 to order IORDRE */
3145 /*        included. The calculation is produced without knowing the coefficients of */
3146 /*        derivatives of the curve. */
3147
3148 /*     KEYWORDS : */
3149 /*     ----------- */
3150 /*        POSITIONING,EXTREMITIES,CURVE,DERIVATIVE. */
3151
3152 /*     INPUT ARGUMENTS : */
3153 /*     ------------------ */
3154 /*        IORDRE  : Maximum order of calculation of derivatives. */
3155 /*        NDIMEN  : Dimension of the space. */
3156 /*        NCOEFF  : Number of coefficients of the curve (degree+1). */
3157 /*        COURBE  : Table of coefficients of the curve. */
3158
3159 /*     OUTPUT ARGUMENTS : */
3160 /*     ------------------- */
3161 /*        POINTS    : Table of values of consecutive derivatives */
3162 /*                 of parameters -1.D0 and 1.D0. */
3163 /*        MFACTAB : Auxiliary table for calculation of factorial(I).
3164 */
3165
3166 /*     COMMONS USED   : */
3167 /*     ---------------- */
3168 /*        None. */
3169
3170 /*     REFERENCES CALLED   : */
3171 /*     ----------------------- */
3172
3173 /*     DESCRIPTION/NOTES/LIMITATIONS : */
3174 /*     ----------------------------------- */
3175
3176 /* ---> ATTENTION, the coefficients of the curve are  */
3177 /*     in a reverse order. */
3178
3179 /* ---> The algorithm of calculation of derivatives is based on */
3180 /*     generalization of Horner scheme : */
3181 /*                          k             2 */
3182 /*          Let C(t) = uk.t  + ... + u2.t  + u1.t + u0 . */
3183
3184
3185 /*      a0 = uk, b0 = 0, c0 = 0 and for 1<=j<=k, it is calculated : */
3186
3187 /*          aj = a(j-1).x + u(k-j) */
3188 /*          bj = b(j-1).x + a(j-1) */
3189 /*          cj = c(j-1).x + b(j-1) */
3190
3191 /*     So : C(x) = ak, C'(x) = bk, C"(x) = 2.ck  . */
3192
3193 /*     The algorithm is generalized easily for calculation of */
3194
3195 /*               (n) */
3196 /*              C  (x)   . */
3197 /*             --------- */
3198 /*                n! */
3199
3200 /*      Reference : D. KNUTH, "The Art of Computer Programming" */
3201 /*      ---------              Vol. 2/Seminumerical Algorithms */
3202 /*                             Addison-Wesley Pub. Co. (1969) */
3203 /*                             pages 423-425. */
3204 /* > */
3205 /* **********************************************************************
3206 */
3207
3208 /*   Name of the routine */
3209
3210     /* Parameter adjustments */
3211     points_dim2 = *iordre + 1;
3212     points_offset = (points_dim2 << 1) + 1;
3213     points -= points_offset;
3214     courbe_dim1 = *ncoeff;
3215     courbe_offset = courbe_dim1;
3216     courbe -= courbe_offset;
3217
3218     /* Function Body */
3219     ibb = AdvApp2Var_SysBase::mnfndeb_();
3220     if (ibb >= 2) {
3221         AdvApp2Var_SysBase::mgenmsg_("MMDRC11", 7L);
3222     }
3223
3224     if (*iordre < 0 || *ncoeff < 1) {
3225         goto L9999;
3226     }
3227
3228 /* ------------------- Initialization of table POINTS -----------------
3229 */
3230
3231     ndgcb = *ncoeff - 1;
3232     i__1 = *ndimen;
3233     for (nd = 1; nd <= i__1; ++nd) {
3234         points[(nd * points_dim2 << 1) + 1] = courbe[ndgcb + nd * courbe_dim1]
3235                 ;
3236         points[(nd * points_dim2 << 1) + 2] = courbe[ndgcb + nd * courbe_dim1]
3237                 ;
3238 /* L100: */
3239     }
3240
3241     i__1 = *ndimen;
3242     for (nd = 1; nd <= i__1; ++nd) {
3243         i__2 = *iordre;
3244         for (j = 1; j <= i__2; ++j) {
3245             points[((j + nd * points_dim2) << 1) + 1] = 0.;
3246             points[((j + nd * points_dim2) << 1) + 2] = 0.;
3247 /* L400: */
3248         }
3249 /* L300: */
3250     }
3251
3252 /*    Calculation with parameter -1 and 1 */
3253
3254     i__1 = *ndimen;
3255     for (nd = 1; nd <= i__1; ++nd) {
3256         i__2 = ndgcb;
3257         for (ndeg = 1; ndeg <= i__2; ++ndeg) {
3258             for (i__ = *iordre; i__ >= 1; --i__) {
3259                 points[((i__ + nd * points_dim2) << 1) + 1] = -points[((i__ + nd
3260                         * points_dim2) << 1) + 1] + points[((i__ - 1 + nd *
3261                         points_dim2) << 1) + 1];
3262                 points[((i__ + nd * points_dim2) << 1) + 2] += points[((i__ - 1
3263                         + nd * points_dim2) << 1) + 2];
3264 /* L800: */
3265             }
3266             points[(nd * points_dim2 << 1) + 1] = -points[(nd * points_dim2 <<
3267                      1) + 1] + courbe[ndgcb - ndeg + nd * courbe_dim1];
3268             points[(nd * points_dim2 << 1) + 2] += courbe[ndgcb - ndeg + nd *
3269                     courbe_dim1];
3270 /* L700: */
3271         }
3272 /* L600: */
3273     }
3274
3275 /* --------------------- Multiplication by factorial(I) --------------
3276 */
3277
3278     if (*iordre > 1) {
3279         mfac_(&mfactab[1], iordre);
3280
3281         i__1 = *ndimen;
3282         for (nd = 1; nd <= i__1; ++nd) {
3283             i__2 = *iordre;
3284             for (i__ = 2; i__ <= i__2; ++i__) {
3285                 points[((i__ + nd * points_dim2) << 1) + 1] = mfactab[i__] *
3286                         points[((i__ + nd * points_dim2) << 1) + 1];
3287                 points[((i__ + nd * points_dim2) << 1) + 2] = mfactab[i__] *
3288                         points[((i__ + nd * points_dim2) << 1) + 2];
3289 /* L1000: */
3290             }
3291 /* L900: */
3292         }
3293     }
3294
3295 /* ---------------------------- End -------------------------------------
3296 */
3297
3298 L9999:
3299     if (ibb >= 2) {
3300         AdvApp2Var_SysBase::mgsomsg_("MMDRC11", 7L);
3301     }
3302     return 0;
3303 } /* mmdrc11_ */
3304
3305 //=======================================================================
3306 //function : mmdrvcb_
3307 //purpose  :
3308 //=======================================================================
3309 int mmdrvcb_(integer *ideriv,
3310              integer *ndim,
3311              integer *ncoeff,
3312              doublereal *courbe,
3313              doublereal *tparam,
3314              doublereal *tabpnt,
3315              integer *iercod)
3316
3317 {
3318   /* System generated locals */
3319   integer courbe_dim1, tabpnt_dim1, i__1, i__2, i__3;
3320
3321   /* Local variables */
3322   integer ndeg, i__, j, nd, ndgcrb, iptpnt, ibb;
3323
3324
3325 /* ***********************************************************************
3326 /*     FUNCTION : */
3327 /*     ---------- */
3328
3329 /*        Calculation of successive derivatives of equation CURVE with */
3330 /*        parameter TPARAM from order 0 to order IDERIV included. */
3331 /*        The calculation is produced without knowing the coefficients of */
3332 /*        derivatives of the CURVE. */
3333
3334 /*     KEYWORDS : */
3335 /*     ----------- */
3336 /*        POSITIONING,PARAMETER,CURVE,DERIVATIVE. */
3337
3338 /*     INPUT ARGUMENTS : */
3339 /*     ------------------ */
3340 /*        IORDRE  : Maximum order of calculation of derivatives. */
3341 /*        NDIMEN  : Dimension of the space. */
3342 /*        NCOEFF  : Number of coefficients of the curve (degree+1). */
3343 /*        COURBE  : Table of coefficients of the curve. */
3344 /*        TPARAM  : Value of the parameter where the curve should be evaluated. */
3345
3346 /*     OUTPUT ARGUMENTS : */
3347 /*     ------------------- */
3348 /*        TABPNT  : Table of values of consecutive derivatives */
3349 /*                  of parameter TPARAM. */
3350   /*        IERCOD  : 0 = OK, */
3351 /*                    1 = incoherent input. */
3352
3353 /*     COMMONS USED  : */
3354 /*     ---------------- */
3355 /*        None. */
3356
3357 /*     REFERENCES CALLED   : */
3358 /*     ----------------------- */
3359
3360 /*     DESCRIPTION/NOTES/LIMITATIONS : */
3361 /*     ----------------------------------- */
3362
3363 /*     The algorithm of  calculation of derivatives is based on */
3364 /*     generalization of the Horner scheme : */
3365 /*                          k             2 */
3366 /*          Let C(t) = uk.t  + ... + u2.t  + u1.t + u0 . */
3367
3368
3369 /*      a0 = uk, b0 = 0, c0 = 0 and for 1<=j<=k, it is calculated : */
3370
3371 /*          aj = a(j-1).x + u(k-j) */
3372 /*          bj = b(j-1).x + a(j-1) */
3373 /*          cj = c(j-1).x + b(j-1) */
3374
3375 /*     So, it is obtained : C(x) = ak, C'(x) = bk, C"(x) = 2.ck  . */
3376
3377 /*     The algorithm can be easily generalized for the calculation of */
3378
3379 /*               (n) */
3380 /*              C  (x)   . */
3381 /*             --------- */
3382 /*                n! */
3383
3384 /*      Reference : D. KNUTH, "The Art of Computer Programming" */
3385 /*      ---------              Vol. 2/Seminumerical Algorithms */
3386 /*                             Addison-Wesley Pub. Co. (1969) */
3387 /*                             pages 423-425. */
3388
3389 /* ---> To evaluare derivatives at 0 and 1, it is preferable */
3390 /*      to use routine MDRV01.FOR . */
3391 /* > */
3392 /* **********************************************************************
3393 */
3394
3395 /*   Name of the routine */
3396
3397     /* Parameter adjustments */
3398     tabpnt_dim1 = *ndim;
3399     --tabpnt;
3400     courbe_dim1 = *ndim;
3401     --courbe;
3402
3403     /* Function Body */
3404     ibb = AdvApp2Var_SysBase::mnfndeb_();
3405     if (ibb >= 2) {
3406         AdvApp2Var_SysBase::mgenmsg_("MMDRVCB", 7L);
3407     }
3408
3409     if (*ideriv < 0 || *ncoeff < 1) {
3410         *iercod = 1;
3411         goto L9999;
3412     }
3413     *iercod = 0;
3414
3415 /* ------------------- Initialization of table TABPNT -----------------
3416 */
3417
3418     ndgcrb = *ncoeff - 1;
3419     i__1 = *ndim;
3420     for (nd = 1; nd <= i__1; ++nd) {
3421         tabpnt[nd] = courbe[nd + ndgcrb * courbe_dim1];
3422 /* L100: */
3423     }
3424
3425     if (*ideriv < 1) {
3426         goto L200;
3427     }
3428     iptpnt = *ndim * *ideriv;
3429     AdvApp2Var_SysBase::mvriraz_(&iptpnt,
3430              &tabpnt[tabpnt_dim1 + 1]);
3431 L200:
3432
3433 /* ------------------------ Calculation of parameter TPARAM ------------------
3434 */
3435
3436     i__1 = ndgcrb;
3437     for (ndeg = 1; ndeg <= i__1; ++ndeg) {
3438         i__2 = *ndim;
3439         for (nd = 1; nd <= i__2; ++nd) {
3440             for (i__ = *ideriv; i__ >= 1; --i__) {
3441                 tabpnt[nd + i__ * tabpnt_dim1] = tabpnt[nd + i__ *
3442                         tabpnt_dim1] * *tparam + tabpnt[nd + (i__ - 1) *
3443                         tabpnt_dim1];
3444 /* L700: */
3445             }
3446             tabpnt[nd] = tabpnt[nd] * *tparam + courbe[nd + (ndgcrb - ndeg) *
3447                     courbe_dim1];
3448 /* L600: */
3449         }
3450 /* L500: */
3451     }
3452
3453 /* --------------------- Multiplication by factorial(I) -------------
3454 */
3455
3456     i__1 = *ideriv;
3457     for (i__ = 2; i__ <= i__1; ++i__) {
3458         i__2 = i__;
3459         for (j = 2; j <= i__2; ++j) {
3460             i__3 = *ndim;
3461             for (nd = 1; nd <= i__3; ++nd) {
3462                 tabpnt[nd + i__ * tabpnt_dim1] = (doublereal) j * tabpnt[nd +
3463                         i__ * tabpnt_dim1];
3464 /* L1200: */
3465             }
3466 /* L1100: */
3467         }
3468 /* L1000: */
3469     }
3470
3471 /* --------------------------- The end ---------------------------------
3472 */
3473
3474 L9999:
3475     if (*iercod > 0) {
3476         AdvApp2Var_SysBase::maermsg_("MMDRVCB", iercod, 7L);
3477     }
3478     return 0;
3479 } /* mmdrvcb_ */
3480
3481 //=======================================================================
3482 //function : AdvApp2Var_MathBase::mmdrvck_
3483 //purpose  :
3484 //=======================================================================
3485 int AdvApp2Var_MathBase::mmdrvck_(integer *ncoeff,
3486                                   integer *ndimen,
3487                                   doublereal *courbe,
3488                                   integer *ideriv,
3489                                   doublereal *tparam,
3490                                   doublereal *pntcrb)
3491
3492 {
3493   /* Initialized data */
3494
3495   static doublereal mmfack[21] = { 1.,2.,6.,24.,120.,720.,5040.,40320.,
3496             362880.,3628800.,39916800.,479001600.,6227020800.,87178291200.,
3497             1.307674368e12,2.0922789888e13,3.55687428096e14,6.402373705728e15,
3498             1.21645100408832e17,2.43290200817664e18,5.109094217170944e19 };
3499
3500   /* System generated locals */
3501   integer courbe_dim1, courbe_offset, i__1, i__2;
3502
3503   /* Local variables */
3504   integer i__, j, k, nd;
3505   doublereal mfactk, bid;
3506
3507
3508 /*      IMPLICIT INTEGER (I-N) */
3509 /*      IMPLICIT DOUBLE PRECISION(A-H,O-Z) */
3510
3511
3512 /* ***********************************************************************
3513  */
3514
3515 /*     FONCTION : */
3516 /*     ---------- */
3517 /*     Calculate the value of a derived curve of order IDERIV in */
3518 /*     a point of parameter TPARAM. */
3519
3520 /*     KEYWORDS : */
3521 /*     ----------- */
3522 /*     POSITIONING,CURVE,DERIVATIVE of ORDER K. */
3523
3524 /*     INPUT ARGUMENTS  : */
3525 /*     ------------------ */
3526 /*   NCOEFF  : Degree +1 of the curve. */
3527 /*   NDIMEN   : Dimension of the space (2 or 3 in general) */
3528 /*   COURBE  : Table of coefficients of the curve. */
3529 /*   IDERIV : Required order of derivation : 1=1st derivative, etc... */
3530 /*   TPARAM : Value of parameter of the curve. */
3531
3532 /*     OUTPUT ARGUMENTS  : */
3533 /*     ------------------- */
3534 /*   PNTCRB  : Point of parameter TPARAM on the derivative of order */
3535 /*            IDERIV of CURVE. */
3536
3537 /*     COMMONS USED   : */
3538 /*     ---------------- */
3539 /*    MMCMCNP */
3540
3541 /*     REFERENCES CALLED   : */
3542 /*     ---------------------- */
3543 /*      None. */
3544 /*     DESCRIPTION/NOTES/LIMITATIONS : */
3545 /*     ----------------------------------- */
3546
3547 /*    The code below was written basing on the following algorithm :
3548 */
3549
3550 /*    Let P(t) = a1 + a2*t + ... an*t**n. The derivative of order k of P */
3551 /*    (containing n-k coefficients) is calculated as follows : */
3552
3553 /*       Pk(t) = a(k+1)*CNP(k,k)*k! */
3554 /*             + a(k+2)*CNP(k+1,k)*k! * t */
3555 /*             . */
3556 /*             . */
3557 /*             . */
3558 /*             + a(n)*CNP(n-1,k)*k! * t**(n-k-1). */
3559
3560 /*    Evaluation is produced following the classic Horner scheme. */
3561 /* > */
3562 /* ***********************************************************************
3563  */
3564
3565
3566 /*     Factorials (1 to 21)  caculated on VAX in R*16 */
3567
3568
3569 /* **********************************************************************
3570 */
3571
3572 /*     FUNCTION : */
3573 /*     ---------- */
3574 /*      Serves to provide binomial coefficients (Pascal triangle). */
3575
3576 /*     KEYWORDS : */
3577 /*     ----------- */
3578 /*      Binomial Coeff from 0 to 60. read only . init by block data */
3579
3580 /*     DEMSCRIPTION/NOTES/LIMITATIONS : */
3581 /*     ----------------------------------- */
3582 /*     Binomial coefficients form a triangular matrix. */
3583 /*     This matrix is completed in table CNP by its transposition. */
3584 /*     So: CNP(I,J) = CNP(J,I) for I and J = 0, ..., 60. */
3585
3586 /*     Initialization is done by block-data MMLLL09.RES, */
3587 /*     created by program MQINICNP.FOR. */
3588 /* > */
3589 /* **********************************************************************
3590 */
3591
3592
3593
3594 /* ***********************************************************************
3595  */
3596
3597     /* Parameter adjustments */
3598     --pntcrb;
3599     courbe_dim1 = *ndimen;
3600     courbe_offset = courbe_dim1 + 1;
3601     courbe -= courbe_offset;
3602
3603     /* Function Body */
3604
3605 /* -------------- Case when the order of derivative is greater than -------------------
3606 */
3607 /* ---------------- the degree of the curve ---------------------
3608 */
3609
3610     if (*ideriv >= *ncoeff) {
3611         i__1 = *ndimen;
3612         for (nd = 1; nd <= i__1; ++nd) {
3613             pntcrb[nd] = 0.;
3614 /* L100: */
3615         }
3616         goto L9999;
3617     }
3618 /* **********************************************************************
3619 */
3620 /*                         General processing*/
3621 /* **********************************************************************
3622 */
3623 /* --------------------- Calculation of Factorial(IDERIV) ------------------
3624 */
3625
3626     k = *ideriv;
3627     if (*ideriv <= 21 && *ideriv > 0) {
3628         mfactk = mmfack[k - 1];
3629     } else {
3630         mfactk = 1.;
3631         i__1 = k;
3632         for (i__ = 2; i__ <= i__1; ++i__) {
3633             mfactk *= i__;
3634 /* L200: */
3635         }
3636     }
3637
3638 /* ------- Calculation of derivative of order IDERIV of CURVE in TPARAM -----
3639 */
3640 /* ---> Attention : binomial coefficient C(n,m) is represented in */
3641 /*                 MCCNP by CNP(N,M). */
3642
3643     i__1 = *ndimen;
3644     for (nd = 1; nd <= i__1; ++nd) {
3645         pntcrb[nd] = courbe[nd + *ncoeff * courbe_dim1] * mmcmcnp_.cnp[*
3646                 ncoeff - 1 + k * 61] * mfactk;
3647 /* L300: */
3648     }
3649
3650     i__1 = k + 1;
3651     for (j = *ncoeff - 1; j >= i__1; --j) {
3652         bid = mmcmcnp_.cnp[j - 1 + k * 61] * mfactk;
3653         i__2 = *ndimen;
3654         for (nd = 1; nd <= i__2; ++nd) {
3655             pntcrb[nd] = pntcrb[nd] * *tparam + courbe[nd + j * courbe_dim1] *
3656                      bid;
3657 /* L500: */
3658         }
3659 /* L400: */
3660     }
3661
3662 /* -------------------------------- The end -----------------------------
3663 */
3664
3665 L9999:
3666
3667  return 0   ;
3668
3669 } /* mmdrvck_ */
3670 //=======================================================================
3671 //function : AdvApp2Var_MathBase::mmeps1_
3672 //purpose  :
3673 //=======================================================================
3674 int AdvApp2Var_MathBase::mmeps1_(doublereal *epsilo)
3675
3676 {
3677 /* ***********************************************************************
3678  */
3679
3680 /*     FUNCTION : */
3681 /*     ---------- */
3682 /*        Extraction of EPS1 from COMMON MPRCSN. EPS1 is spatial zero  */
3683 /*     equal to 1.D-9 */
3684
3685 /*     KEYWORDS : */
3686 /*     ----------- */
3687 /*        MPRCSN,PRECISON,EPS1. */
3688
3689 /*     INPUT ARGUMENTS : */
3690 /*     ------------------ */
3691 /*        None */
3692
3693 /*     OUTPUT ARGUMENTS : */
3694 /*     ------------------- */
3695 /*        EPSILO : Value of EPS1 (spatial zero (10**-9)) */
3696
3697 /*     COMMONS USED   : */
3698 /*     ---------------- */
3699
3700 /*     REFERENCES CALLED   : */
3701 /*     ----------------------- */
3702
3703 /*     DESCRIPTION/NOTES/LIMITATIONS : */
3704 /*     ----------------------------------- */
3705 /*     EPS1 is ABSOLUTE spatial zero, so it is necessary */
3706 /*     to use it whenever it is necessary to test if a variable */
3707 /*     is null. For example, if the norm of a vector is lower than */
3708 /*     EPS1, this vector is NULL ! (when one works in */
3709 /*     REAL*8) It is absolutely not advised to test arguments  */
3710 /*     compared to EPS1**2. Taking into account the rounding errors inevitable */
3711 /*     during calculations, this causes testing compared to 0.D0. */
3712 /* > */
3713 /* ***********************************************************************
3714  */
3715
3716
3717
3718 /* ***********************************************************************
3719  */
3720
3721 /*     FUNCTION : */
3722 /*     ---------- */
3723 /*          Gives tolerances of invalidity in stream */
3724 /*          as well as limits of iterative processes */
3725
3726 /*          general context, modifiable by the user */
3727
3728 /*     KEYWORDS : */
3729 /*     ----------- */
3730 /*          PARAMETER , TOLERANCE */
3731
3732 /*     DEMSCRIPTION/NOTES/LIMITATIONS : */
3733 /*     ----------------------------------- */
3734 /*       INITIALISATION   :  profile , **VIA MPRFTX** at input in stream
3735 /*       loading of default values of the profile in MPRFTX at input */
3736 /*       in stream. They are preserved in local variables of MPRFTX */
3737
3738 /*        Reset of default values                  : MDFINT */
3739 /*        Interactive modification by the user   : MDBINT */
3740
3741 /*        ACCESS FUNCTION  :  MMEPS1   ...  EPS1 */
3742 /*                            MEPSPB  ...  EPS3,EPS4 */
3743 /*                            MEPSLN  ...  EPS2, NITERM , NITERR */
3744 /*                            MEPSNR  ...  EPS2 , NITERM */
3745 /*                            MITERR  ...  NITERR */
3746 /* > */
3747 /* ***********************************************************************
3748  */
3749
3750 /*     NITERM : max nb of iterations */
3751 /*     NITERR : nb of rapid iterations */
3752 /*     EPS1   : tolerance of 3D null distance */
3753 /*     EPS2   : tolerance of parametric null distance */
3754 /*     EPS3   : tolerance to avoid division by 0.. */
3755 /*     EPS4   : angular tolerance */
3756
3757
3758
3759 /* ***********************************************************************
3760  */
3761     *epsilo = mmprcsn_.eps1;
3762
3763  return 0 ;
3764 } /* mmeps1_ */
3765
3766 //=======================================================================
3767 //function : mmexthi_
3768 //purpose  :
3769 //=======================================================================
3770 int mmexthi_(integer *ndegre,
3771              doublereal *hwgaus)
3772
3773 {
3774   /* System generated locals */
3775   integer i__1;
3776
3777   /* Local variables */
3778   integer iadd, ideb, ndeg2, nmod2, ii, ibb;
3779   integer kpt;
3780
3781 /* **********************************************************************
3782 */
3783
3784 /*     FONCTION : */
3785 /*     ---------- */
3786 /*  Extract of common LDGRTL the weight of formulas of  */
3787 /*  Gauss quadrature on all roots of Legendre polynoms of degree */
3788 /*  NDEGRE defined on [-1,1]. */
3789
3790 /*     KEYWORDS : */
3791 /*     ----------- */
3792 /*     ALL, AB_SPECIFI::COMMON&, EXTRACTION, &WEIGHT, &GAUSS. */
3793
3794 /*     INPUT ARGUMENTS : */
3795 /*     ------------------ */
3796 /*   NDEGRE : Mathematic degree of Legendre polynom. It should have */
3797 /*            2 <= NDEGRE <= 61. */
3798
3799 /*     OUTPUT ARGUMENTS : */
3800 /*     ------------------- */
3801 /*   HWGAUS : The table of weights of Gauss quadrature formulas */
3802 /*            relative to NDEGRE roots of a polynome de Legendre de */
3803 /*            degre NDEGRE. */
3804
3805 /*     COMMONS UTILISES   : */
3806 /*     ---------------- */
3807 /*     MLGDRTL */
3808
3809 /*     REFERENCES CALLED   : */
3810 /*     ----------------------- */
3811
3812 /*     DESCRIPTION/NOTES/LIMITATIONS : */
3813 /*     ----------------------------------- */
3814 /*     ATTENTION: The condition on NDEGRE ( 2 <= NDEGRE <= 61) is not  */
3815 /*     tested. The caller should make the test.
3816
3817 /*   Name of the routine */
3818
3819
3820 /*   Common MLGDRTL: */
3821 /*   This common includes POSITIVE roots of Legendre polynims */
3822 /*   AND weights of Gauss quadrature formulas on all */
3823 /*   POSITIVE roots of Legendre polynoms. */
3824
3825
3826
3827 /* ***********************************************************************
3828  */
3829
3830 /*     FUNCTION : */
3831 /*     ---------- */
3832 /*   The common of Legendre roots. */
3833
3834 /*     KEYWORDS : */
3835 /*     ----------- */
3836 /*        BASE LEGENDRE */
3837
3838 /*     DESCRIPTION/NOTES/LIMITATIONS : */
3839 /*     ----------------------------------- */
3840 /* > */
3841 /* ***********************************************************************
3842  */
3843
3844
3845
3846
3847 /*   ROOTAB : Table of all roots of Legendre polynoms */
3848 /*   within the interval [0,1]. They are ranked for the degrees increasing from */
3849 /*   2 to 61. */
3850 /*   HILTAB : Table of Legendre interpolators concerning ROOTAB. */
3851 /*   The adressing is the same. */
3852 /*   HI0TAB : Table of Legendre interpolators for root x=0 */
3853 /*   of polynoms of UNEVEN degree. */
3854 /*   RTLTB0 : Table of Li(uk) where uk are the roots of */
3855 /*  Legendre polynom of EVEN degree. */
3856 /*   RTLTB1 : Table of Li(uk) where uk are the roots of */
3857 /*  Legendre polynom of UNEVEN degree. */
3858
3859
3860 /************************************************************************
3861 *****/
3862     /* Parameter adjustments */
3863     --hwgaus;
3864
3865     /* Function Body */
3866     ibb = AdvApp2Var_SysBase::mnfndeb_();
3867     if (ibb >= 3) {
3868         AdvApp2Var_SysBase::mgenmsg_("MMEXTHI", 7L);
3869     }
3870
3871     ndeg2 = *ndegre / 2;
3872     nmod2 = *ndegre % 2;
3873
3874 /*   Address of Gauss weight associated to the 1st strictly */
3875 /*   positive root of Legendre polynom of degree NDEGRE in MLGDRTL. */
3876
3877     iadd = ndeg2 * (ndeg2 - 1) / 2 + 1;
3878
3879 /*   Index of the 1st HWGAUS element associated to the 1st strictly  */
3880 /*   positive root of Legendre polynom of degree NDEGRE. */
3881
3882     ideb = (*ndegre + 1) / 2 + 1;
3883
3884 /*   Reading of weights associated to strictly positive roots. */
3885
3886     i__1 = *ndegre;
3887     for (ii = ideb; ii <= i__1; ++ii) {
3888         kpt = iadd + ii - ideb;
3889         hwgaus[ii] = mlgdrtl_.hiltab[kpt + nmod2 * 465 - 1];
3890 /* L100: */
3891     }
3892
3893 /*   For strictly negative roots, the weight is the same. */
3894 /*   i.e HW(1) = HW(NDEGRE), HW(2) = HW(NDEGRE-1), etc... */
3895
3896     i__1 = ndeg2;
3897     for (ii = 1; ii <= i__1; ++ii) {
3898         hwgaus[ii] = hwgaus[*ndegre + 1 - ii];
3899 /* L200: */
3900     }
3901
3902 /*   Case of uneven NDEGRE, 0 is root of Legendre polynom, */
3903 /*   associated Gauss weights are loaded. */
3904
3905     if (nmod2 == 1) {
3906         hwgaus[ndeg2 + 1] = mlgdrtl_.hi0tab[ndeg2];
3907     }
3908
3909 /* --------------------------- The end ----------------------------------
3910 */
3911
3912     if (ibb >= 3) {
3913         AdvApp2Var_SysBase::mgsomsg_("MMEXTHI", 7L);
3914     }
3915     return 0;
3916 } /* mmexthi_ */
3917
3918 //=======================================================================
3919 //function : mmextrl_
3920 //purpose  :
3921 //=======================================================================
3922 int mmextrl_(integer *ndegre,
3923              doublereal *rootlg)
3924 {
3925   /* System generated locals */
3926   integer i__1;
3927
3928   /* Local variables */
3929   integer iadd, ideb, ndeg2, nmod2, ii, ibb;
3930   integer kpt;
3931
3932
3933 /* **********************************************************************
3934 */
3935
3936 /*     FUNCTION : */
3937 /*     ---------- */
3938 /* Extract of the Common LDGRTL of Legendre polynom roots */
3939 /* of degree NDEGRE defined on [-1,1]. */
3940
3941 /*     KEYWORDS : */
3942 /*     ----------- */
3943 /*     ALL, AB_SPECIFI::COMMON&, EXTRACTION, &ROOT, &LEGENDRE. */
3944
3945 /*     INPUT ARGUMENTS : */
3946 /*     ------------------ */
3947 /*   NDEGRE : Mathematic degree of Legendre polynom.  */
3948 /*            It is required to have 2 <= NDEGRE <= 61. */
3949
3950 /*     OUTPUT ARGUMENTS : */
3951 /*     ------------------- */
3952 /*   ROOTLG : The table of roots of Legendre polynom of degree */
3953 /*            NDEGRE defined on [-1,1]. */
3954
3955 /*     COMMONS USED   : */
3956 /*     ---------------- */
3957 /*     MLGDRTL */
3958
3959 /*     REFERENCES CALLED   : */
3960 /*     ----------------------- */
3961
3962 /*     DESCRIPTION/NOTES/LIMITATIONS : */
3963 /*     ----------------------------------- */
3964 /*     ATTENTION: Condition of NDEGRE ( 2 <= NDEGRE <= 61) is not */
3965 /*     tested. The caller should make the test. */
3966 /* > */
3967 /* **********************************************************************
3968 */
3969
3970
3971 /*   Name of the routine */
3972
3973
3974 /*   Common MLGDRTL: */
3975 /*   This common includes POSITIVE roots of Legendre polynoms */
3976 /*   AND the weight of Gauss quadrature formulas on all */
3977 /*   POSITIVE roots of Legendre polynoms. */
3978
3979 /* ***********************************************************************
3980  */
3981
3982 /*     FUNCTION : */
3983 /*     ---------- */
3984 /*   The common of Legendre roots. */
3985
3986 /*     KEYWORDS : */
3987 /*     ----------- */
3988 /*        BASE LEGENDRE */
3989
3990
3991 /* ***********************************************************************
3992  */
3993
3994 /*   ROOTAB : Table of all roots of Legendre polynoms */
3995 /*   within the interval [0,1]. They are ranked for the degrees increasing from */
3996 /*   2 to 61. */
3997 /*   HILTAB : Table of Legendre interpolators concerning ROOTAB. */
3998 /*   The adressing is the same. */
3999 /*   HI0TAB : Table of Legendre interpolators for root x=0 */
4000 /*   of polynoms of UNEVEN degree. */
4001 /*   RTLTB0 : Table of Li(uk) where uk are the roots of */
4002 /*  Legendre polynom of EVEN degree. */
4003 /*   RTLTB1 : Table of Li(uk) where uk are the roots of */
4004 /*  Legendre polynom of UNEVEN degree. */
4005
4006
4007 /************************************************************************
4008 *****/
4009     /* Parameter adjustments */
4010     --rootlg;
4011
4012     /* Function Body */
4013     ibb = AdvApp2Var_SysBase::mnfndeb_();
4014     if (ibb >= 3) {
4015         AdvApp2Var_SysBase::mgenmsg_("MMEXTRL", 7L);
4016     }
4017
4018     ndeg2 = *ndegre / 2;
4019     nmod2 = *ndegre % 2;
4020
4021 /*   Address of the 1st strictly positive root of Legendre polynom */
4022 /*   of degree NDEGRE in MLGDRTL. */
4023
4024     iadd = ndeg2 * (ndeg2 - 1) / 2 + 1;
4025
4026 /*   Indice, in ROOTLG, of the 1st strictly positive root */
4027 /*   of Legendre polynom of degree NDEGRE. */
4028
4029     ideb = (*ndegre + 1) / 2 + 1;
4030
4031 /*   Reading of strictly positive roots. */
4032
4033     i__1 = *ndegre;
4034     for (ii = ideb; ii <= i__1; ++ii) {
4035         kpt = iadd + ii - ideb;
4036         rootlg[ii] = mlgdrtl_.rootab[kpt + nmod2 * 465 - 1];
4037 /* L100: */
4038     }
4039
4040 /*   Strictly negative roots are equal to positive roots
4041 */
4042 /*   to the sign i.e RT(1) = -RT(NDEGRE), RT(2) = -RT(NDEGRE-1), etc...
4043 */
4044
4045     i__1 = ndeg2;
4046     for (ii = 1; ii <= i__1; ++ii) {
4047         rootlg[ii] = -rootlg[*ndegre + 1 - ii];
4048 /* L200: */
4049     }
4050
4051 /*   Case NDEGRE uneven, 0 is root of Legendre polynom. */
4052
4053     if (nmod2 == 1) {
4054         rootlg[ndeg2 + 1] = 0.;
4055     }
4056
4057 /* -------------------------------- THE END -----------------------------
4058 */
4059
4060     if (ibb >= 3) {
4061         AdvApp2Var_SysBase::mgenmsg_("MMEXTRL", 7L);
4062     }
4063     return 0;
4064 } /* mmextrl_ */
4065
4066 //=======================================================================
4067 //function : AdvApp2Var_MathBase::mmfmca8_
4068 //purpose  :
4069 //=======================================================================
4070 int AdvApp2Var_MathBase::mmfmca8_(const integer *ndimen,
4071                                   const integer *ncoefu,
4072                                   const integer *ncoefv,
4073                                   const integer *ndimax,
4074                                   const integer *ncfumx,
4075                                   const integer *,//ncfvmx,
4076                                   doublereal *tabini,
4077                                   doublereal *tabres)
4078
4079 {
4080   /* System generated locals */
4081   integer tabini_dim1, tabini_dim2, tabini_offset, tabres_dim1, tabres_dim2,
4082   tabres_offset;
4083
4084   /* Local variables */
4085   integer i__, j, k, ilong;
4086
4087
4088
4089 /* **********************************************************************
4090 */
4091
4092 /*     FUNCTION : */
4093 /*     ---------- */
4094 /*        Expansion of a table containing only most important things into a  */
4095 /*        greater data table. */
4096
4097 /*     KEYWORDS : */
4098 /*     ----------- */
4099 /*     ALL, MATH_ACCES:: CARREAU&, DECOMPRESSION, &CARREAU */
4100
4101 /*     INPUT ARGUMENTS : */
4102 /*     ------------------ */
4103 /*        NDIMEN: Dimension of the workspace. */
4104 /*        NCOEFU: Degree +1 of the table by u. */
4105 /*        NCOEFV: Degree +1 of the table by v. */
4106 /*        NDIMAX: Max dimension of the space. */
4107 /*        NCFUMX: Max Degree +1 of the table by u. */
4108 /*        NCFVMX: Max Degree +1 of the table by v. */
4109 /*        TABINI: The table to be decompressed. */
4110
4111 /*     OUTPUT ARGUMENTS : */
4112 /*     ------------------- */
4113 /*        TABRES: Decompressed table. */
4114
4115 /*     COMMONS USED   : */
4116 /*     ---------------- */
4117
4118 /*     REFERENCES CALLED   : */
4119 /*     ----------------------- */
4120
4121 /*     DESCRIPTION/NOTES/LIMITATIONS : */
4122 /*     ----------------------------------- */
4123 /*     The following call : */
4124
4125 /*  CALL MMFMCA8(NDIMEN,NCOEFU,NCOEFV,NDIMAX,NCFUMX,NCFVMX,TABINI,TABINI)
4126 */
4127
4128 /*     where TABINI is input/output argument, is possible provided */
4129 /*     that the caller has declared TABINI in (NDIMAX,NCFUMX,NCFVMX) */
4130
4131 /*     ATTENTION : it is not checked that NDIMAX >= NDIMEN, */
4132 /*                 NCOEFU >= NCFMXU and NCOEFV >= NCFMXV. */
4133 /* > */
4134 /* **********************************************************************
4135 */
4136
4137
4138     /* Parameter adjustments */
4139     tabini_dim1 = *ndimen;
4140     tabini_dim2 = *ncoefu;
4141     tabini_offset = tabini_dim1 * (tabini_dim2 + 1) + 1;
4142     tabini -= tabini_offset;
4143     tabres_dim1 = *ndimax;
4144     tabres_dim2 = *ncfumx;
4145     tabres_offset = tabres_dim1 * (tabres_dim2 + 1) + 1;
4146     tabres -= tabres_offset;
4147
4148     /* Function Body */
4149     if (*ndimax == *ndimen) {
4150         goto L1000;
4151     }
4152
4153 /* ----------------------- decompression NDIMAX<>NDIMEN -----------------
4154 */
4155
4156     for (k = *ncoefv; k >= 1; --k) {
4157         for (j = *ncoefu; j >= 1; --j) {
4158             for (i__ = *ndimen; i__ >= 1; --i__) {
4159                 tabres[i__ + (j + k * tabres_dim2) * tabres_dim1] = tabini[
4160                         i__ + (j + k * tabini_dim2) * tabini_dim1];
4161 /* L300: */
4162             }
4163 /* L200: */
4164         }
4165 /* L100: */
4166     }
4167     goto L9999;
4168
4169 /* ----------------------- decompression NDIMAX=NDIMEN ------------------
4170 */
4171
4172 L1000:
4173     if (*ncoefu == *ncfumx) {
4174         goto L2000;
4175     }
4176     ilong = (*ndimen << 3) * *ncoefu;
4177     for (k = *ncoefv; k >= 1; --k) {
4178         AdvApp2Var_SysBase::mcrfill_(&ilong,
4179                  &tabini[(k * tabini_dim2 + 1) * tabini_dim1 + 1],
4180                  &tabres[(k * tabres_dim2 + 1) * tabres_dim1 + 1]);
4181 /* L500: */
4182     }
4183     goto L9999;
4184
4185 /* ----------------- decompression NDIMAX=NDIMEN,NCOEFU=NCFUMX ----------
4186 */
4187
4188 L2000:
4189     ilong = (*ndimen << 3) * *ncoefu * *ncoefv;
4190     AdvApp2Var_SysBase::mcrfill_(&ilong,
4191              &tabini[tabini_offset],
4192              &tabres[tabres_offset]);
4193     goto L9999;
4194
4195 /* ---------------------------- The end ---------------------------------
4196 */
4197
4198 L9999:
4199     return 0;
4200 } /* mmfmca8_ */
4201
4202 //=======================================================================
4203 //function : AdvApp2Var_MathBase::mmfmca9_
4204 //purpose  :
4205 //=======================================================================
4206  int AdvApp2Var_MathBase::mmfmca9_(integer *ndimax,
4207                                    integer *ncfumx,
4208                                    integer *,//ncfvmx,
4209                                    integer *ndimen,
4210                                    integer *ncoefu,
4211                                    integer *ncoefv,
4212                                    doublereal *tabini,
4213                                    doublereal *tabres)
4214
4215 {
4216   /* System generated locals */
4217   integer tabini_dim1, tabini_dim2, tabini_offset, tabres_dim1, tabres_dim2,
4218   tabres_offset, i__1, i__2, i__3;
4219
4220     /* Local variables */
4221   integer i__, j, k, ilong;
4222
4223
4224
4225 /* **********************************************************************
4226 */
4227
4228 /*     FUNCTION : */
4229 /*     ---------- */
4230 /*        Compression of a data table in a table */
4231 /*        containing only the main data (the input table is not removed). */
4232
4233 /*     KEYWORDS: */
4234 /*     ----------- */
4235 /*     ALL, MATH_ACCES:: CARREAU&, COMPRESSION, &CARREAU */
4236
4237 /*     INPUT ARGUMENTS : */
4238 /*     ------------------ */
4239 /*        NDIMAX: Max dimension of the space. */
4240 /*        NCFUMX: Max degree +1 of the table by u. */
4241 /*        NCFVMX: Max degree +1 of the table by v. */
4242 /*        NDIMEN: Dimension of the workspace. */
4243 /*        NCOEFU: Degree +1 of the table by u. */
4244 /*        NCOEFV: Degree +1 of the table by v. */
4245 /*        TABINI: The table to compress. */
4246
4247 /*     OUTPUT ARGUMENTS : */
4248 /*     ------------------- */
4249 /*        TABRES: The compressed table. */
4250
4251 /*     COMMONS USED   : */
4252 /*     ---------------- */
4253
4254 /*     REFERENCES CALLED   : */
4255 /*     ----------------------- */
4256
4257 /*     DESCRIPTION/NOTES/LIMITATIONS : */
4258 /*     ----------------------------------- */
4259 /*     The following call : */
4260
4261 /* CALL MMFMCA9(NDIMAX,NCFUMX,NCFVMX,NDIMEN,NCOEFU,NCOEFV,TABINI,TABINI)
4262 */
4263
4264 /*     where TABINI is input/output argument, is possible provided */
4265 /*     that the caller has checked that : */
4266
4267 /*            NDIMAX > NDIMEN, */
4268 /*         or NDIMAX = NDIMEN and NCFUMX > NCOEFU */
4269 /*         or  NDIMAX = NDIMEN, NCFUMX = NCOEFU and NCFVMX > NCOEFV */
4270
4271 /*     These conditions are not tested in the program. */
4272
4273 /* > */
4274 /* **********************************************************************
4275 */
4276
4277
4278     /* Parameter adjustments */
4279     tabini_dim1 = *ndimax;
4280     tabini_dim2 = *ncfumx;
4281     tabini_offset = tabini_dim1 * (tabini_dim2 + 1) + 1;
4282     tabini -= tabini_offset;
4283     tabres_dim1 = *ndimen;
4284     tabres_dim2 = *ncoefu;
4285     tabres_offset = tabres_dim1 * (tabres_dim2 + 1) + 1;
4286     tabres -= tabres_offset;
4287
4288     /* Function Body */
4289     if (*ndimen == *ndimax) {
4290         goto L1000;
4291     }
4292
4293 /* ----------------------- Compression NDIMEN<>NDIMAX -------------------
4294 */
4295
4296     i__1 = *ncoefv;
4297     for (k = 1; k <= i__1; ++k) {
4298         i__2 = *ncoefu;
4299         for (j = 1; j <= i__2; ++j) {
4300             i__3 = *ndimen;
4301             for (i__ = 1; i__ <= i__3; ++i__) {
4302                 tabres[i__ + (j + k * tabres_dim2) * tabres_dim1] = tabini[
4303                         i__ + (j + k * tabini_dim2) * tabini_dim1];
4304 /* L300: */
4305             }
4306 /* L200: */
4307         }
4308 /* L100: */
4309     }
4310     goto L9999;
4311
4312 /* ----------------------- Compression NDIMEN=NDIMAX --------------------
4313 */
4314
4315 L1000:
4316     if (*ncoefu == *ncfumx) {
4317         goto L2000;
4318     }
4319     ilong = (*ndimen << 3) * *ncoefu;
4320     i__1 = *ncoefv;
4321     for (k = 1; k <= i__1; ++k) {
4322         AdvApp2Var_SysBase::mcrfill_(&ilong,
4323                  &tabini[(k * tabini_dim2 + 1) * tabini_dim1 + 1],
4324                  &tabres[(k * tabres_dim2 + 1) * tabres_dim1 + 1]);
4325 /* L500: */
4326     }
4327     goto L9999;
4328
4329 /* ----------------- Compression NDIMEN=NDIMAX,NCOEFU=NCFUMX ------------
4330 */
4331
4332 L2000:
4333     ilong = (*ndimen << 3) * *ncoefu * *ncoefv;
4334     AdvApp2Var_SysBase::mcrfill_(&ilong,
4335              &tabini[tabini_offset],
4336              &tabres[tabres_offset]);
4337     goto L9999;
4338
4339 /* ---------------------------- The end ---------------------------------
4340 */
4341
4342 L9999:
4343     return 0;
4344 } /* mmfmca9_ */
4345
4346 //=======================================================================
4347 //function : AdvApp2Var_MathBase::mmfmcar_
4348 //purpose  :
4349 //=======================================================================
4350 int AdvApp2Var_MathBase::mmfmcar_(integer *ndimen,
4351                                   integer *ncofmx,
4352                                   integer *ncoefu,
4353                                   integer *ncoefv,
4354                                   doublereal *patold,
4355                                   doublereal *upara1,
4356                                   doublereal *upara2,
4357                                   doublereal *vpara1,
4358                                   doublereal *vpara2,
4359                                   doublereal *patnew,
4360                                   integer *iercod)
4361
4362 {
4363   integer c__8 = 8;
4364   /* System generated locals */
4365     integer patold_dim1, patold_dim2, patnew_dim1, patnew_dim2,
4366             i__1, patold_offset,patnew_offset;
4367
4368     /* Local variables */
4369     doublereal* tbaux = 0;
4370     integer ksize, numax, kk;
4371     intptr_t iofst;
4372     integer ibb, ier;
4373
4374 /* ***********************************************************************
4375  */
4376
4377 /*     FUNCTION : */
4378 /*     ---------- */
4379 /*       LIMITATION OF A SQUARE DEFINED ON (0,1)*(0,1) BETWEEN ISOS */
4380 /*       UPARA1 AND UPARA2 (BY U) AND VPARA1 AND VPARA2 BY V. */
4381
4382 /*     KEYWORDS : */
4383 /*     ----------- */
4384 /*       LIMITATION , SQUARE , PARAMETER */
4385
4386 /*     INPUT ARGUMENTS : */
4387 /*     ------------------ */
4388 /*     NCOFMX: MAX NUMBER OF COEFF OF THE SQUARE BY U */
4389 /*     NCOEFU: NUMBER OF COEFF OF THE SQUARE BY U */
4390 /*     NCOEFV: NUMBER OF COEFF OF THE SQUARE BY V */
4391 /*     PATOLD : THE SQUARE IS LIMITED BY UPARA1,UPARA2 AND VPARA1,VPARA2
4392 .*/
4393 /*     UPARA1    : LOWER LIMIT OF U */
4394 /*     UPARA2    : UPPER LIMIT OF U */
4395 /*     VPARA1    : LOWER LIMIT OF V */
4396 /*     VPARA2    : UPPER LIMIT OF V */
4397
4398 /*     OUTPUT ARGUMENTS : */
4399 /*     ------------------- */
4400 /*     PATNEW : RELIMITED SQUARE, DEFINED ON (0,1)**2 */
4401 /*     IERCOD : =10 COEFF NB TOO GREAT OR NULL */
4402 /*              =13 PB IN THE DYNAMIC ALLOCATION */
4403 /*              = 0 OK. */
4404
4405 /*     COMMONS USED   : */
4406 /*     ---------------- */
4407
4408 /*     DESCRIPTION/NOTES/LIMITATIONS : */
4409 /*     ----------------------------------- */
4410 /* --->    The following call : */
4411 /*   CALL MMFMCAR(NCOFMX,NCOEFU,NCOEFV,PATOLD,UPARA1,UPARA2,VPARA1,VPARA2
4412 */
4413 /*              ,PATOLD), */
4414 /*        where PATOLD is input/output argument is absolutely legal. */
4415
4416 /* --->    The max number of coeff by u and v of PATOLD is 61 */
4417
4418 /* --->    If NCOEFU < NCOFMX, the data is compressed by MMFMCA9 before
4419 /*        limitation by v to get time during the execution */
4420 /*        of MMARC41 that follows (the square is processed as a curve of
4421 */
4422 /*        dimension NDIMEN*NCOEFU possessing NCOEFV coefficients). */
4423 /* > */
4424 /* ***********************************************************************
4425  */
4426
4427 /*   Name of the routine */
4428
4429
4430     /* Parameter adjustments */
4431     patnew_dim1 = *ndimen;
4432     patnew_dim2 = *ncofmx;
4433     patnew_offset = patnew_dim1 * (patnew_dim2 + 1) + 1;
4434     patnew -= patnew_offset;
4435     patold_dim1 = *ndimen;
4436     patold_dim2 = *ncofmx;
4437     patold_offset = patold_dim1 * (patold_dim2 + 1) + 1;
4438     patold -= patold_offset;
4439
4440     /* Function Body */
4441     ibb = AdvApp2Var_SysBase::mnfndeb_();
4442     if (ibb >= 2) {
4443         AdvApp2Var_SysBase::mgenmsg_("MMFMCAR", 7L);
4444     }
4445     *iercod = 0;
4446     iofst = 0;
4447     AdvApp2Var_SysBase anAdvApp2Var_SysBase;
4448
4449 /* **********************************************************************
4450 */
4451 /*                  TEST OF COEFFICIENT NUMBERS */
4452 /* **********************************************************************
4453 */
4454
4455     if (*ncofmx < *ncoefu) {
4456         *iercod = 10;
4457         goto L9999;
4458     }
4459     if (*ncoefu < 1 || *ncoefu > 61 || *ncoefv < 1 || *ncoefv > 61) {
4460         *iercod = 10;
4461         goto L9999;
4462     }
4463
4464 /* **********************************************************************
4465 */
4466 /*                  CASE WHEN UPARA1=VPARA1=0 AND UPARA2=VPARA2=1 */
4467 /* **********************************************************************
4468 */
4469
4470     if (*upara1 == 0. && *upara2 == 1. && *vpara1 == 0. && *vpara2 == 1.) {
4471         ksize = (*ndimen << 3) * *ncofmx * *ncoefv;
4472         AdvApp2Var_SysBase::mcrfill_(&ksize,
4473                  &patold[patold_offset],
4474                  &patnew[patnew_offset]);
4475         goto L9999;
4476     }
4477
4478 /* **********************************************************************
4479 */
4480 /*                        LIMITATION BY U */
4481 /* **********************************************************************
4482 */
4483
4484     if (*upara1 == 0. && *upara2 == 1.) {
4485         goto L2000;
4486     }
4487     i__1 = *ncoefv;
4488     for (kk = 1; kk <= i__1; ++kk) {
4489         mmarc41_(ndimen, ndimen, ncoefu, &patold[(kk * patold_dim2 + 1) *
4490                 patold_dim1 + 1], upara1, upara2, &patnew[(kk * patnew_dim2 +
4491                 1) * patnew_dim1 + 1], iercod);
4492 /* L100: */
4493     }
4494
4495 /* **********************************************************************
4496 */
4497 /*                         LIMITATION BY V */
4498 /* **********************************************************************
4499 */
4500
4501 L2000:
4502     if (*vpara1 == 0. && *vpara2 == 1.) {
4503         goto L9999;
4504     }
4505
4506 /* ----------- LIMITATION BY V (WITH COMPRESSION I.E. NCOEFU<NCOFMX) ----
4507 */
4508
4509     numax = *ndimen * *ncoefu;
4510     if (*ncofmx != *ncoefu) {
4511 /* ------------------------- Dynamic allocation -------------------
4512 ---- */
4513         ksize = *ndimen * *ncoefu * *ncoefv;
4514         anAdvApp2Var_SysBase.mcrrqst_(&c__8, &ksize, tbaux, &iofst, &ier);
4515         if (ier > 0) {
4516             *iercod = 13;
4517             goto L9900;
4518         }
4519 /* --------------- Compression by (NDIMEN,NCOEFU,NCOEFV) ------------
4520 ---- */
4521         if (*upara1 == 0. && *upara2 == 1.) {
4522           AdvApp2Var_MathBase::mmfmca9_(ndimen,
4523                                         ncofmx,
4524                                         ncoefv,
4525                                         ndimen,
4526                                         ncoefu,
4527                                         ncoefv,
4528                                         &patold[patold_offset],
4529                                         &tbaux[iofst]);
4530         } else {
4531           AdvApp2Var_MathBase::mmfmca9_(ndimen,
4532                                         ncofmx,
4533                                         ncoefv,
4534                                         ndimen,
4535                                         ncoefu,
4536                                         ncoefv,
4537                                         &patnew[patnew_offset],
4538                                         &tbaux[iofst]);
4539         }
4540 /* ------------------------- Limitation by v ------------------------
4541 ---- */
4542         mmarc41_(&numax, &numax, ncoefv, &tbaux[iofst], vpara1, vpara2, &
4543                 tbaux[iofst], iercod);
4544 /* --------------------- Expansion of TBAUX into PATNEW -------------
4545 --- */
4546         AdvApp2Var_MathBase::mmfmca8_(ndimen, ncoefu, ncoefv, ndimen, ncofmx, ncoefv, &tbaux[iofst]
4547                 , &patnew[patnew_offset]);
4548         goto L9900;
4549
4550 /* -------- LIMITATION BY V (WITHOUT COMPRESSION I.E. NCOEFU=NCOFMX) ---
4551 ---- */
4552
4553     } else {
4554         if (*upara1 == 0. && *upara2 == 1.) {
4555             mmarc41_(&numax, &numax, ncoefv, &patold[patold_offset], vpara1,
4556                     vpara2, &patnew[patnew_offset], iercod);
4557         } else {
4558             mmarc41_(&numax, &numax, ncoefv, &patnew[patnew_offset], vpara1,
4559                     vpara2, &patnew[patnew_offset], iercod);
4560         }
4561         goto L9999;
4562     }
4563
4564 /* **********************************************************************
4565 */
4566 /*                             DESALLOCATION */
4567 /* **********************************************************************
4568 */
4569
4570 L9900:
4571     if (iofst != 0) {
4572         anAdvApp2Var_SysBase.mcrdelt_(&c__8, &ksize, tbaux, &iofst, &ier);
4573     }
4574     if (ier > 0) {
4575         *iercod = 13;
4576     }
4577
4578 /* ------------------------------ The end -------------------------------
4579 */
4580
4581 L9999:
4582     if (*iercod > 0) {
4583         AdvApp2Var_SysBase::maermsg_("MMFMCAR", iercod, 7L);
4584     }
4585     if (ibb >= 2) {
4586         AdvApp2Var_SysBase::mgsomsg_("MMFMCAR", 7L);
4587     }
4588     return 0;
4589 } /* mmfmcar_ */
4590
4591
4592 //=======================================================================
4593 //function : AdvApp2Var_MathBase::mmfmcb5_
4594 //purpose  :
4595 //=======================================================================
4596 int AdvApp2Var_MathBase::mmfmcb5_(integer *isenmsc,
4597                                   integer *ndimax,
4598                                   integer *ncf1mx,
4599                                   doublereal *courb1,
4600                                   integer *ncoeff,
4601                                   integer *ncf2mx,
4602                                   integer *ndimen,
4603                                   doublereal *courb2,
4604                                   integer *iercod)
4605
4606 {
4607   /* System generated locals */
4608   integer courb1_dim1, courb1_offset, courb2_dim1, courb2_offset, i__1,
4609   i__2;
4610
4611   /* Local variables */
4612   integer i__, nboct, nd;
4613
4614
4615 /* **********************************************************************
4616 */
4617
4618 /*     FUNCTION : */
4619 /*     ---------- */
4620 /*       Reformating (and  eventual compression/decompression) of curve */
4621 /*       (ndim,.) by (.,ndim) and vice versa. */
4622
4623 /*     KEYWORDS : */
4624 /*     ----------- */
4625 /*      ALL , MATH_ACCES :: */
4626 /*      COURBE&, REORGANISATION,COMPRESSION,INVERSION , &COURBE */
4627
4628 /*     INPUT ARGUMENTS : */
4629 /*     -------------------- */
4630 /*        ISENMSC : required direction of the transfer : */
4631 /*           1   :  passage of (NDIMEN,.) ---> (.,NDIMEN)  direction to AB
4632 */
4633 /*          -1   :  passage of (.,NDIMEN) ---> (NDIMEN,.)  direction to TS,T
4634 V*/
4635 /*        NDIMAX : format / dimension */
4636 /*        NCF1MX : format by t of COURB1 */
4637 /*   if ISENMSC= 1 : COURB1: The curve to be processed (NDIMAX,.) */
4638 /*        NCOEFF : number of coeff of the curve */
4639 /*        NCF2MX : format by t of COURB2 */
4640 /*        NDIMEN : dimension of the curve and format of COURB2 */
4641 /*   if ISENMSC=-1 : COURB2: The curve to be processed (.,NDIMEN) */
4642
4643 /*     OUTPUT ARGUMENTS : */
4644 /*     --------------------- */
4645 /*   if ISENMSC= 1 : COURB2: The resulting curve (.,NDIMEN) */
4646 /*   if ISENMSC=-1 : COURB1: The resulting curve (NDIMAX,.) */
4647
4648 /*     COMMONS USED : */
4649 /*     ------------------ */
4650
4651 /*     REFERENCES CALLED : */
4652 /*     --------------------- */
4653
4654 /*     DESCRIPTION/NOTES/LIMITATIONS : */
4655 /*     ----------------------------------- */
4656 /*     allow to process the usual transfers as follows : */
4657 /*     | ---- ISENMSC = 1 ---- |      | ---- ISENMSC =-1 ----- | */
4658 /*    TS  (3,21) --> (21,3)  AB  ;  AB  (21,3) --> (3,21)  TS */
4659 /*    TS  (3,21) --> (NU,3)  AB  ;  AB  (NU,3) --> (3,21)  TS */
4660 /*        (3,NU) --> (21,3)  AB  ;  AB  (21,3) --> (3,NU) */
4661 /*        (3,NU) --> (NU,3)  AB  ;  AB  (NU,3) --> (3,NU) */
4662 /* > */
4663 /* ***********************************************************************
4664  */
4665
4666
4667     /* Parameter adjustments */
4668     courb1_dim1 = *ndimax;
4669     courb1_offset = courb1_dim1 + 1;
4670     courb1 -= courb1_offset;
4671     courb2_dim1 = *ncf2mx;
4672     courb2_offset = courb2_dim1 + 1;
4673     courb2 -= courb2_offset;
4674
4675     /* Function Body */
4676     if (*ndimen > *ndimax || *ncoeff > *ncf1mx || *ncoeff > *ncf2mx) {
4677         goto L9119;
4678     }
4679
4680     if (*ndimen == 1 && *ncf1mx == *ncf2mx) {
4681         nboct = *ncf2mx << 3;
4682         if (*isenmsc == 1) {
4683             AdvApp2Var_SysBase::mcrfill_(&nboct,
4684                      &courb1[courb1_offset],
4685                      &courb2[courb2_offset]);
4686         }
4687         if (*isenmsc == -1) {
4688             AdvApp2Var_SysBase::mcrfill_(&nboct,
4689                      &courb2[courb2_offset],
4690                      &courb1[courb1_offset]);
4691         }
4692         *iercod = -3136;
4693         goto L9999;
4694     }
4695
4696     *iercod = 0;
4697     if (*isenmsc == 1) {
4698         i__1 = *ndimen;
4699         for (nd = 1; nd <= i__1; ++nd) {
4700             i__2 = *ncoeff;
4701             for (i__ = 1; i__ <= i__2; ++i__) {
4702                 courb2[i__ + nd * courb2_dim1] = courb1[nd + i__ *
4703                         courb1_dim1];
4704 /* L400: */
4705             }
4706 /* L500: */
4707         }
4708     } else if (*isenmsc == -1) {
4709         i__1 = *ndimen;
4710         for (nd = 1; nd <= i__1; ++nd) {
4711             i__2 = *ncoeff;
4712             for (i__ = 1; i__ <= i__2; ++i__) {
4713                 courb1[nd + i__ * courb1_dim1] = courb2[i__ + nd *
4714                         courb2_dim1];
4715 /* L1400: */
4716             }
4717 /* L1500: */
4718         }
4719     } else {
4720         *iercod = 3164;
4721     }
4722
4723     goto L9999;
4724
4725 /* ***********************************************************************
4726  */
4727
4728 L9119:
4729     *iercod = 3119;
4730
4731 L9999:
4732     if (*iercod != 0) {
4733         AdvApp2Var_SysBase::maermsg_("MMFMCB5", iercod, 7L);
4734     }
4735     return 0;
4736 } /* mmfmcb5_ */
4737
4738 //=======================================================================
4739 //function : AdvApp2Var_MathBase::mmfmtb1_
4740 //purpose  :
4741 //=======================================================================
4742 int AdvApp2Var_MathBase::mmfmtb1_(integer *maxsz1,
4743                                   doublereal *table1,
4744                                   integer *isize1,
4745                                   integer *jsize1,
4746                                   integer *maxsz2,
4747                                   doublereal *table2,
4748                                   integer *isize2,
4749                                   integer *jsize2,
4750                                   integer *iercod)
4751 {
4752   integer c__8 = 8;
4753
4754    /* System generated locals */
4755     integer table1_dim1, table1_offset, table2_dim1, table2_offset, i__1,
4756             i__2;
4757
4758     /* Local variables */
4759     doublereal* work = 0;
4760     integer ilong, isize, ii, jj, ier;
4761     intptr_t iofst,iipt, jjpt;
4762
4763
4764 /************************************************************************
4765 *******/
4766
4767 /*     FUNCTION : */
4768 /*     ---------- */
4769 /*     Inversion of elements of a rectangular table (T1(i,j) */
4770 /*     loaded in T2(j,i)) */
4771
4772 /*     KEYWORDS : */
4773 /*     ----------- */
4774 /*      ALL, MATH_ACCES :: TABLEAU&, INVERSION, &TABLEAU */
4775
4776 /*     INPUT ARGUMENTS : */
4777 /*     ------------------ */
4778 /*     MAXSZ1: Max Nb of elements by the 1st dimension of TABLE1. */
4779 /*     TABLE1: Table of reals by two dimensions. */
4780 /*     ISIZE1: Nb of useful elements of TABLE1 on the 1st dimension */
4781 /*     JSIZE1: Nb of useful elements of TABLE1 on the 2nd dimension */
4782 /*     MAXSZ2: Nb max of elements by the 1st dimension of TABLE2. */
4783
4784 /*     OUTPUT ARGUMENTS : */
4785 /*     ------------------- */
4786 /*     TABLE2: Table of reals by two dimensions, containing the transposition
4787 /*             of the rectangular table TABLE1. */
4788 /*     ISIZE2: Nb of useful elements of TABLE2 on the 1st dimension */
4789 /*     JSIZE2: Nb of useful elements of TABLE2 on the 2nd dimension */
4790 /*     IERCOD: Erroe coder. */
4791 /*             = 0, ok. */
4792 /*             = 1, error in the dimension of tables */
4793 /*                  ether MAXSZ1 < ISIZE1 (table TABLE1 too small). */
4794 /*                  or MAXSZ2 < JSIZE1 (table TABLE2 too small). */
4795
4796 /*     COMMONS USED   : */
4797 /*     ---------------- */
4798
4799 /*     REFERENCES CALLED   : */
4800 /*     ---------------------- */
4801
4802 /*     DESCRIPTION/NOTES/LIMITATIONS : */
4803 /*     ----------------------------------- */
4804 /*    It is possible to use TABLE1 as input and output table i.e. */
4805 /*    call: */
4806 /*    CALL MMFMTB1(MAXSZ1,TABLE1,ISIZE1,JSIZE1,MAXSZ2,TABLE1 */
4807 /*               ,ISIZE2,JSIZE2,IERCOD) */
4808 /*    is valuable. */
4809 /* > */
4810 /* **********************************************************************
4811 */
4812
4813
4814     /* Parameter adjustments */
4815     table1_dim1 = *maxsz1;
4816     table1_offset = table1_dim1 + 1;
4817     table1 -= table1_offset;
4818     table2_dim1 = *maxsz2;
4819     table2_offset = table2_dim1 + 1;
4820     table2 -= table2_offset;
4821     AdvApp2Var_SysBase anAdvApp2Var_SysBase;
4822
4823     /* Function Body */
4824     *iercod = 0;
4825     if (*isize1 > *maxsz1 || *jsize1 > *maxsz2) {
4826         goto L9100;
4827     }
4828
4829     iofst = 0;
4830     isize = *maxsz2 * *isize1;
4831     anAdvApp2Var_SysBase.mcrrqst_(&c__8, &isize, work, &iofst, &ier);
4832     if (ier > 0) {
4833         goto L9200;
4834     }
4835
4836 /*             DO NOT BE AFRAID OF CRUSHING. */
4837
4838     i__1 = *isize1;
4839     for (ii = 1; ii <= i__1; ++ii) {
4840         iipt = (ii - 1) * *maxsz2 + iofst;
4841         i__2 = *jsize1;
4842         for (jj = 1; jj <= i__2; ++jj) {
4843             jjpt = iipt + (jj - 1);
4844             work[jjpt] = table1[ii + jj * table1_dim1];
4845 /* L200: */
4846         }
4847 /* L100: */
4848     }
4849     ilong = isize << 3;
4850     AdvApp2Var_SysBase::mcrfill_(&ilong,
4851              &work[iofst],
4852              &table2[table2_offset]);
4853
4854 /* -------------- The number of elements of TABLE2 is returned ------------
4855 */
4856
4857     ii = *isize1;
4858     *isize2 = *jsize1;
4859     *jsize2 = ii;
4860
4861     goto L9999;
4862
4863 /* ------------------------------- THE END ------------------------------
4864 */
4865 /* --> Invalid input. */
4866 L9100:
4867     *iercod = 1;
4868     goto L9999;
4869 /* --> Pb of allocation. */
4870 L9200:
4871     *iercod = 2;
4872     goto L9999;
4873
4874 L9999:
4875     if (iofst != 0) {
4876         anAdvApp2Var_SysBase.mcrdelt_(&c__8, &isize, work, &iofst, &ier);
4877     }
4878     if (ier > 0) {
4879         *iercod = 2;
4880     }
4881     return 0;
4882 } /* mmfmtb1_ */
4883
4884 //=======================================================================
4885 //function : AdvApp2Var_MathBase::mmgaus1_
4886 //purpose  :
4887 //=======================================================================
4888 int AdvApp2Var_MathBase::mmgaus1_(integer *ndimf,
4889                                   int (*bfunx) (
4890                                                 integer *ninteg,
4891                                                 doublereal *parame,
4892                                                 doublereal *vfunj1,
4893                                                 integer *iercod
4894                                                 ),
4895
4896                                   integer *k,
4897                                   doublereal *xd,
4898                                   doublereal *xf,
4899                                   doublereal *saux1,
4900                                   doublereal *saux2,
4901                                   doublereal *somme,
4902                                   integer *niter,
4903                                   integer *iercod)
4904 {
4905   /* System generated locals */
4906   integer i__1, i__2;
4907
4908   /* Local variables */
4909   integer ndeg;
4910   doublereal h__[20];
4911   integer j;
4912   doublereal t, u[20], x;
4913   integer idimf;
4914   doublereal c1x, c2x;
4915 /* **********************************************************************
4916 */
4917
4918 /*      FUNCTION : */
4919 /*      -------- */
4920
4921 /*      Calculate the integral of  function BFUNX passed in parameter */
4922 /*      between limits XD and XF . */
4923 /*      The function should be calculated for any value */
4924 /*      of the variable in the given interval.. */
4925 /*      The method GAUSS-LEGENDRE is used.
4926 /*      For explications refer to the book : */
4927 /*          Complements de mathematiques a l'usage des Ingenieurs de */
4928 /*          l'electrotechnique et des telecommunications. */
4929 /*          Par Andre ANGOT - Collection technique et scientifique du CNET
4930  */
4931 /*          page 772 .... */
4932 /*      The degree of LEGENDRE polynoms used is passed in parameter.
4933  */
4934 /*      KEYWORDS : */
4935 /*      --------- */
4936 /*         INTEGRATION,LEGENDRE,GAUSS */
4937
4938 /*      INPUT ARGUMENTS : */
4939 /*      ------------------ */
4940
4941 /*      NDIMF : Dimension of the function */
4942 /*      BFUNX : Function to integrate passed as argument */
4943 /*              Should be declared as EXTERNAL in the call routine. */
4944 /*                   SUBROUTINE BFUNX(NDIMF,X,VAL,IER) */
4945 /*                   REAL *8 X,VAL */
4946 /*     K      : Parameter determining the degree of the LEGENDRE polynom that
4947 */
4948 /*               can take a value between 0 and 10. */
4949 /*               The degree of the polynom is equal to 4 k, that is 4, 8,
4950 */
4951 /*               12, 16, 20, 24, 28, 32, 36 and 40. */
4952 /*               If K is not correct, the degree is set to 40 directly.
4953 */
4954 /*      XD     : Lower limit of the interval of integration. */
4955 /*      XF     : Upper limit of the interval of integration. */
4956 /*      SAUX1  : Auxiliary table */
4957 /*      SAUX2  : Auxiliary table */
4958
4959 /*      OUTPUT ARGUMENTS : */
4960 /*      ------------------- */
4961
4962 /*      SOMME : Value of the integral */
4963 /*      NITER : Number of iterations to be carried out. */
4964 /*              It is equal to the degree of the polynom. */
4965
4966 /*      IER   : Error code : */
4967 /*              < 0 ==> Attention - Warning */
4968 /*              = 0 ==> Everything is OK */
4969 /*              > 0 ==> Critical error - Apply special processing */
4970 /*                  ==> Error in the calculation of BFUNX (return code */
4971 /*                      of this routine */
4972
4973 /*              If error => SUM = 0 */
4974
4975 /*      COMMONS USED : */
4976 /*      ----------------- */
4977
4978
4979
4980 /*     REFERENCES CALLED   : */
4981 /*     ---------------------- */
4982
4983 /*     Type  Name */
4984 /*    @      BFUNX               MVGAUS0 */
4985
4986 /*      DESCRIPTION/NOTES/LIMITATIONS : */
4987 /*      --------------------------------- */
4988
4989 /*      See the explanations detailed in the listing */
4990 /*      Use of the GAUSS method (orthogonal polynoms) */
4991 /*      The symmetry of roots of these polynomes is used */
4992 /*      Depending on K, the degree of the interpolated polynom grows.
4993 */
4994 /*      If you wish to calculate the integral with a given precision, */
4995 /*      loop on k varying from 1 to 10 and test the difference of 2
4996 */
4997 /*      consecutive iterations. Stop the loop if this difference is less that
4998 /*      an epsilon value set to 10E-6 for example. */
4999 /*      If S1 and S2 are 2 successive iterations, test following this example :
5000  */
5001
5002 /*            AF=DABS(S1-S2) */
5003 /*            AS=DABS(S2) */
5004 /*            If AS < 1 test if FS < eps otherwise test if AF/AS < eps
5005 */
5006 /*            --        -----                    ----- */
5007 /* > */
5008 /************************************************************************
5009 ******/
5010 /*     DECLARATIONS */
5011 /************************************************************************
5012 ******/
5013
5014
5015
5016 /* ****** General Initialization */
5017
5018     /* Parameter adjustments */
5019     --somme;
5020     --saux2;
5021     --saux1;
5022
5023     /* Function Body */
5024     AdvApp2Var_SysBase::mvriraz_(ndimf,
5025              &somme[1]);
5026     *iercod = 0;
5027
5028 /* ****** Loading of coefficients U and H ** */
5029 /* -------------------------------------------- */
5030
5031     mvgaus0_(k, u, h__, &ndeg, iercod);
5032     if (*iercod > 0) {
5033         goto L9999;
5034     }
5035
5036 /* ****** C1X => Medium interval point  [XD,XF] */
5037 /* ****** C2X => 1/2 amplitude interval [XD,XF] */
5038
5039     c1x = (*xf + *xd) * .5;
5040     c2x = (*xf - *xd) * .5;
5041
5042 /* ---------------------------------------- */
5043 /* ****** Integration for degree NDEG ** */
5044 /* ---------------------------------------- */
5045
5046     i__1 = ndeg;
5047     for (j = 1; j <= i__1; ++j) {
5048         t = c2x * u[j - 1];
5049
5050         x = c1x + t;
5051         (*bfunx)(ndimf, &x, &saux1[1], iercod);
5052         if (*iercod != 0) {
5053             goto L9999;
5054         }
5055
5056         x = c1x - t;
5057         (*bfunx)(ndimf, &x, &saux2[1], iercod);
5058         if (*iercod != 0) {
5059             goto L9999;
5060         }
5061
5062         i__2 = *ndimf;
5063         for (idimf = 1; idimf <= i__2; ++idimf) {
5064             somme[idimf] += h__[j - 1] * (saux1[idimf] + saux2[idimf]);
5065         }
5066
5067     }
5068
5069     *niter = ndeg << 1;
5070     i__1 = *ndimf;
5071     for (idimf = 1; idimf <= i__1; ++idimf) {
5072         somme[idimf] *= c2x;
5073     }
5074
5075 /* ****** End of sub-program ** */
5076
5077 L9999:
5078
5079  return 0   ;
5080 } /* mmgaus1_ */
5081 //=======================================================================
5082 //function : mmherm0_
5083 //purpose  :
5084 //=======================================================================
5085 int mmherm0_(doublereal *debfin,
5086              integer *iercod)
5087 {
5088   integer c__576 = 576;
5089   integer c__6 = 6;
5090
5091
5092    /* System generated locals */
5093     integer i__1, i__2;
5094     doublereal d__1;
5095
5096     /* Local variables */
5097     doublereal amat[36] /* was [6][6] */;
5098     integer iord[2];
5099     doublereal prod;
5100     integer iord1, iord2;
5101     doublereal miden[36]        /* was [6][6] */;
5102     integer ncmat;
5103     doublereal epspi, d1, d2;
5104     integer ii, jj, pp, ncf;
5105     doublereal cof[6];
5106     integer iof[2], ier;
5107     doublereal mat[36]  /* was [6][6] */;
5108     integer cot;
5109     doublereal abid[72] /* was [12][6] */;
5110 /* ***********************************************************************
5111  */
5112
5113 /*     FUNCTION : */
5114 /*     ---------- */
5115 /*      INIT OF COEFFS. OF POLYNOMS OF HERMIT INTERPOLATION */
5116
5117 /*     KEYWORDS : */
5118 /*     ----------- */
5119 /*      MATH_ACCES :: HERMITE */
5120
5121 /*     INPUT ARGUMENTS */
5122 /*     -------------------- */
5123 /*       DEBFIN : PARAMETERS DEFINING THE CONSTRAINTS */
5124 /*                 DEBFIN(1) : FIRST PARAMETER */
5125 /*                 DEBFIN(2) : SECOND PARAMETER */
5126
5127 /*      ONE SHOULD HAVE: */
5128 /*                 ABS (DEBFIN(I)) < 100 */
5129 /*                 and */
5130 /*                 (ABS(DEBFIN(1)+ABS(DEBFIN(2))) > 1/100 */
5131 /*           (for overflows) */
5132
5133 /*      ABS(DEBFIN(2)-DEBFIN(1)) / (ABS(DEBFIN(1)+ABS(DEBFIN(2))) > 1/100
5134 */
5135 /*           (for the conditioning) */
5136
5137
5138 /*     OUTPUT ARGUMENTS : */
5139 /*     --------------------- */
5140
5141 /*       IERCOD : Error code : 0 : O.K. */
5142 /*                                1 : value of DEBFIN */
5143 /*                                are unreasonable */
5144 /*                                -1 : init was already done */
5145 /*                                   (OK but no processing) */
5146
5147 /*     COMMONS USED : */
5148 /*     ------------------ */
5149
5150 /*     REFERENCES CALLED : */
5151 /*     ---------------------- */
5152 /*     Type  Name */
5153
5154 /*     DESCRIPTION/NOTES/LIMITATIONS : */
5155 /*     ----------------------------------- */
5156
5157 /*        This program initializes the coefficients of Hermit polynoms */
5158 /*     that are read later by MMHERM1 */
5159 /* ***********************************************************************
5160  */
5161
5162
5163
5164 /* **********************************************************************
5165 */
5166
5167 /*     FUNCTION : */
5168 /*     ---------- */
5169 /*      Used to STORE  coefficients of Hermit interpolation polynoms
5170
5171 /*     KEYWORDS : */
5172 /*     ----------- */
5173 /*      HERMITE */
5174
5175 /*     DEMSCRIPTION/NOTES/LIMITATIONS : */
5176 /*     ----------------------------------- */
5177
5178 /*     The coefficients of hermit polynoms are calculated by */
5179 /*     the routine MMHERM0 and read by the routine MMHERM1 */
5180 /* > */
5181 /* **********************************************************************
5182 */
5183
5184
5185
5186
5187
5188 /*     NBCOEF is the size of CMHERM (see below) */
5189 /* ***********************************************************************
5190  */
5191
5192
5193
5194
5195
5196
5197
5198 /* ***********************************************************************
5199  */
5200 /*     Data checking */
5201 /* ***********************************************************************
5202  */
5203
5204
5205     /* Parameter adjustments */
5206     --debfin;
5207
5208     /* Function Body */
5209     d1 = advapp_abs(debfin[1]);
5210     if (d1 > (float)100.) {
5211         goto L9101;
5212     }
5213
5214     d2 = advapp_abs(debfin[2]);
5215     if (d2 > (float)100.) {
5216         goto L9101;
5217     }
5218
5219     d2 = d1 + d2;
5220     if (d2 < (float).01) {
5221         goto L9101;
5222     }
5223
5224     d1 = (d__1 = debfin[2] - debfin[1], advapp_abs(d__1));
5225     if (d1 / d2 < (float).01) {
5226         goto L9101;
5227     }
5228
5229
5230 /* ***********************************************************************
5231  */
5232 /*     Initialization */
5233 /* ***********************************************************************
5234  */
5235
5236     *iercod = 0;
5237
5238     epspi = 1e-10;
5239
5240
5241 /* ***********************************************************************
5242  */
5243
5244 /*     IS IT ALREADY INITIALIZED ? */
5245
5246     d1 = advapp_abs(debfin[1]) + advapp_abs(debfin[2]);
5247     d1 *= 16111959;
5248
5249     if (debfin[1] != mmcmher_.tdebut) {
5250         goto L100;
5251     }
5252     if (debfin[2] != mmcmher_.tfinal) {
5253         goto L100;
5254     }
5255     if (d1 != mmcmher_.verifi) {
5256         goto L100;
5257     }
5258
5259
5260     goto L9001;
5261
5262
5263 /* ***********************************************************************
5264  */
5265 /*     CALCULATION */
5266 /* ***********************************************************************
5267  */
5268
5269
5270 L100:
5271
5272 /*     Init. matrix identity : */
5273
5274     ncmat = 36;
5275     AdvApp2Var_SysBase::mvriraz_(&ncmat,
5276              miden);
5277
5278     for (ii = 1; ii <= 6; ++ii) {
5279         miden[ii + ii * 6 - 7] = 1.;
5280 /* L110: */
5281     }
5282
5283
5284
5285 /*     Init to 0 of table CMHERM */
5286
5287     AdvApp2Var_SysBase::mvriraz_(&c__576, mmcmher_.cmherm);
5288
5289 /*     Calculation by solution of linear systems */
5290
5291     for (iord1 = -1; iord1 <= 2; ++iord1) {
5292         for (iord2 = -1; iord2 <= 2; ++iord2) {
5293
5294             iord[0] = iord1;
5295             iord[1] = iord2;
5296
5297
5298             iof[0] = 0;
5299             iof[1] = iord[0] + 1;
5300
5301
5302             ncf = iord[0] + iord[1] + 2;
5303
5304 /*        Calculate matrix MAT to invert: */
5305
5306             for (cot = 1; cot <= 2; ++cot) {
5307
5308
5309                 if (iord[cot - 1] > -1) {
5310                     prod = 1.;
5311                     i__1 = ncf;
5312                     for (jj = 1; jj <= i__1; ++jj) {
5313                         cof[jj - 1] = 1.;
5314 /* L200: */
5315                     }
5316                 }
5317
5318                 i__1 = iord[cot - 1] + 1;
5319                 for (pp = 1; pp <= i__1; ++pp) {
5320
5321                     ii = pp + iof[cot - 1];
5322
5323                     prod = 1.;
5324
5325                     i__2 = pp - 1;
5326                     for (jj = 1; jj <= i__2; ++jj) {
5327                         mat[ii + jj * 6 - 7] = (float)0.;
5328 /* L300: */
5329                     }
5330
5331                     i__2 = ncf;
5332                     for (jj = pp; jj <= i__2; ++jj) {
5333
5334 /*        everything is done in these 3 lines
5335  */
5336
5337                         mat[ii + jj * 6 - 7] = cof[jj - 1] * prod;
5338                         cof[jj - 1] *= jj - pp;
5339                         prod *= debfin[cot];
5340
5341 /* L400: */
5342                     }
5343 /* L500: */
5344                 }
5345
5346 /* L1000: */
5347             }
5348
5349 /*     Inversion */
5350
5351             if (ncf >= 1) {
5352                 AdvApp2Var_MathBase::mmmrslwd_(&c__6, &ncf, &ncf, mat, miden, &epspi, abid, amat, &
5353                         ier);
5354                 if (ier > 0) {
5355                     goto L9101;
5356                 }
5357             }
5358
5359             for (cot = 1; cot <= 2; ++cot) {
5360                 i__1 = iord[cot - 1] + 1;
5361                 for (pp = 1; pp <= i__1; ++pp) {
5362                     i__2 = ncf;
5363                     for (ii = 1; ii <= i__2; ++ii) {
5364                         mmcmher_.cmherm[ii + (pp + (cot + ((iord1 + (iord2 <<
5365                                 2)) << 1)) * 3) * 6 + 155] = amat[ii + (pp +
5366                                 iof[cot - 1]) * 6 - 7];
5367 /* L1300: */
5368                     }
5369 /* L1400: */
5370                 }
5371 /* L1500: */
5372             }
5373
5374 /* L2000: */
5375         }
5376 /* L2010: */
5377     }
5378
5379 /* ***********************************************************************
5380  */
5381
5382 /*     The initialized flag is located: */
5383
5384     mmcmher_.tdebut = debfin[1];
5385     mmcmher_.tfinal = debfin[2];
5386
5387     d1 = advapp_abs(debfin[1]) + advapp_abs(debfin[2]);
5388     mmcmher_.verifi = d1 * 16111959;
5389
5390
5391 /* ***********************************************************************
5392  */
5393
5394     goto L9999;
5395
5396 /* ***********************************************************************
5397  */
5398
5399 L9101:
5400     *iercod = 1;
5401     goto L9999;
5402
5403 L9001:
5404     *iercod = -1;
5405     goto L9999;
5406
5407 /* ***********************************************************************
5408  */
5409
5410 L9999:
5411
5412     AdvApp2Var_SysBase::maermsg_("MMHERM0", iercod, 7L);
5413
5414 /* ***********************************************************************
5415  */
5416  return 0 ;
5417 } /* mmherm0_ */
5418
5419 //=======================================================================
5420 //function : mmherm1_
5421 //purpose  :
5422 //=======================================================================
5423 int mmherm1_(doublereal *debfin,
5424              integer *ordrmx,
5425              integer *iordre,
5426              doublereal *hermit,
5427              integer *iercod)
5428 {
5429   /* System generated locals */
5430   integer hermit_dim1, hermit_dim2, hermit_offset;
5431
5432   /* Local variables */
5433   integer nbval;
5434   doublereal d1;
5435   integer cot;
5436
5437 /* ***********************************************************************
5438  */
5439
5440 /*     FUNCTION : */
5441 /*     ---------- */
5442 /*      reading of coeffs. of HERMIT interpolation polynoms */
5443
5444 /*     KEYWORDS : */
5445 /*     ----------- */
5446 /*      MATH_ACCES :: HERMIT */
5447
5448 /*     INPUT ARGUMENTS : */
5449 /*     -------------------- */
5450 /*       DEBFIN : PARAMETES DEFINING THE CONSTRAINTS */
5451 /*                 DEBFIN(1) : FIRST PARAMETER */
5452 /*                 DEBFIN(2) : SECOND PARAMETER */
5453
5454 /*           Should be equal to the corresponding arguments during the */
5455 /*           last call to MMHERM0 for the initialization of coeffs. */
5456
5457 /*       ORDRMX : indicates the dimensioning of HERMIT: */
5458 /*              there is no choice : ORDRMX should be equal to the value */
5459 /*              of PARAMETER IORDMX of INCLUDE MMCMHER, or 2 for the moment */
5460
5461 /*       IORDRE (2) : Orders of constraints in each corresponding parameter DEBFIN(I)
5462 /*              should be between -1 (no constraints) and ORDRMX. */
5463
5464
5465 /*     OUTPUT ARGUMENTS : */
5466 /*     --------------------- */
5467
5468 /*       HERMIT : HERMIT(1:IORDRE(1)+IORDRE(2)+2, j, cote) are the  */
5469 /*       coefficients in the canonic base of Hermit polynom */
5470 /*       corresponding to orders IORDRE with parameters DEBFIN for */
5471 /*       the constraint of order j on DEBFIN(cote). j is between 0 and IORDRE(cote). */
5472
5473
5474 /*       IERCOD : Error code : */
5475 /*          -1: O.K but necessary to reinitialize the coefficients */
5476 /*                 (info for optimization) */
5477 /*          0 : O.K. */
5478 /*          1 : Error in MMHERM0 */
5479 /*          2 : arguments invalid */
5480
5481 /*     COMMONS USED : */
5482 /*     ------------------ */
5483
5484 /*     REFERENCES CALLED   : */
5485 /*     ---------------------- */
5486 /*     Type  Name */
5487
5488 /*     DESCRIPTION/NOTES/LIMITATIONS : */
5489 /*     ----------------------------------- */
5490
5491 /*     This program reads coefficients of Hermit polynoms */
5492 /*     that were earlier initialized by MMHERM0 */
5493
5494 /* PMN : initialisation is no more done by the caller. */
5495
5496
5497 /* ***********************************************************************
5498  */
5499
5500
5501
5502 /* **********************************************************************
5503 */
5504
5505 /*     FUNCTION : */
5506 /*     ---------- */
5507 /*      Serves to STORE the coefficients of Hermit interpolation polynoms
5508
5509 /*     KEYWORDS : */
5510 /*     ----------- */
5511 /*      HERMITE */
5512
5513 /*     DEMSCRIPTION/NOTES/LIMITATIONS : */
5514 /*     ----------------------------------- */
5515
5516 /*     the coefficients of Hetmit polynoms are calculated by */
5517 /*     routine MMHERM0 and read by routine MMHERM1 */
5518
5519 /* > */
5520 /* **********************************************************************
5521 */
5522
5523
5524
5525
5526
5527 /*     NBCOEF is the size of CMHERM (see lower) */
5528
5529
5530
5531 /* ***********************************************************************
5532  */
5533
5534
5535
5536
5537
5538 /* ***********************************************************************
5539  */
5540 /*     Initializations */
5541 /* ***********************************************************************
5542  */
5543
5544     /* Parameter adjustments */
5545     --debfin;
5546     hermit_dim1 = (*ordrmx << 1) + 2;
5547     hermit_dim2 = *ordrmx + 1;
5548     hermit_offset = hermit_dim1 * hermit_dim2 + 1;
5549     hermit -= hermit_offset;
5550     --iordre;
5551
5552     /* Function Body */
5553     *iercod = 0;
5554
5555
5556 /* ***********************************************************************
5557  */
5558 /*     Data Checking */
5559 /* ***********************************************************************
5560  */
5561
5562
5563     if (*ordrmx != 2) {
5564         goto L9102;
5565     }
5566
5567     for (cot = 1; cot <= 2; ++cot) {
5568         if (iordre[cot] < -1) {
5569             goto L9102;
5570         }
5571         if (iordre[cot] > *ordrmx) {
5572             goto L9102;
5573         }
5574 /* L100: */
5575     }
5576
5577
5578 /*     IS-IT CORRECTLY INITIALIZED ? */
5579
5580     d1 = advapp_abs(debfin[1]) + advapp_abs(debfin[2]);
5581     d1 *= 16111959;
5582
5583 /*     OTHERWISE IT IS INITIALIZED */
5584
5585     if (debfin[1] != mmcmher_.tdebut || debfin[2] != mmcmher_.tfinal || d1
5586             != mmcmher_.verifi) {
5587         *iercod = -1;
5588         mmherm0_(&debfin[1], iercod);
5589         if (*iercod > 0) {
5590             goto L9101;
5591         }
5592     }
5593
5594
5595 /* ***********************************************************************
5596  */
5597 /*        READING */
5598 /* ***********************************************************************
5599  */
5600
5601     nbval = 36;
5602
5603     AdvApp2Var_SysBase::msrfill_(&nbval, &mmcmher_.cmherm[((((iordre[1] + (iordre[2] << 2)) << 1)
5604             + 1) * 3 + 1) * 6 + 156], &hermit[hermit_offset]);
5605
5606 /* ***********************************************************************
5607  */
5608
5609     goto L9999;
5610
5611 /* ***********************************************************************
5612  */
5613
5614 L9101:
5615     *iercod = 1;
5616     goto L9999;
5617
5618 L9102:
5619     *iercod = 2;
5620     goto L9999;
5621
5622 /* ***********************************************************************
5623  */
5624
5625 L9999:
5626
5627     AdvApp2Var_SysBase::maermsg_("MMHERM1", iercod, 7L);
5628
5629 /* ***********************************************************************
5630  */
5631  return 0 ;
5632 } /* mmherm1_ */
5633
5634 //=======================================================================
5635 //function : AdvApp2Var_MathBase::mmhjcan_
5636 //purpose  :
5637 //=======================================================================
5638 int AdvApp2Var_MathBase::mmhjcan_(integer *ndimen,
5639                             integer *ncourb,
5640                             integer *ncftab,
5641                             integer *orcont,
5642                             integer *ncflim,
5643                             doublereal *tcbold,
5644                             doublereal *tdecop,
5645                             doublereal *tcbnew,
5646                             integer *iercod)
5647
5648 {
5649   integer c__2 = 2;
5650   integer c__21 = 21;
5651   /* System generated locals */
5652     integer tcbold_dim1, tcbold_dim2, tcbold_offset, tcbnew_dim1, tcbnew_dim2,
5653              tcbnew_offset, i__1, i__2, i__3, i__4, i__5;
5654
5655
5656     /* Local variables */
5657     logical ldbg;
5658     integer ndeg;
5659     doublereal taux1[21];
5660     integer d__, e, i__, k;
5661     doublereal mfact;
5662     integer ncoeff;
5663     doublereal tjacap[21];
5664     integer iordre[2];
5665     doublereal hermit[36]/* was [6][3][2] */, ctenor, bornes[2];
5666     integer ier;
5667     integer aux1, aux2;
5668
5669 /* ***********************************************************************
5670  */
5671
5672 /*     FUNCTION : */
5673 /*     ---------- */
5674 /*       CONVERSION OF TABLE TCBOLD OF POLYNOMIAL CURVE COEFFICIENTS */
5675 /*       EXPRESSED IN HERMIT JACOBI BASE, INTO A */
5676 /*       TABLE OF COEFFICIENTS TCBNEW OF COURVES EXPRESSED IN THE CANONIC BASE */
5677
5678 /*     KEYWORDS : */
5679 /*     ----------- */
5680 /*      CANNONIC, HERMIT, JACCOBI */
5681
5682 /*     INPUT ARGUMENTS : */
5683 /*     -------------------- */
5684 /*       ORDHER : ORDER OF HERMIT POLYNOMS OR ORDER OF CONTINUITY */
5685 /*       NCOEFS : NUMBER OF COEFFICIENTS OF A POLYNOMIAL CURVE */
5686 /*                FOR ONE OF ITS NDIM COMPONENTS;(DEGREE+1 OF THE CURVE)
5687 */
5688 /*       NDIM   : DIMENSION OF THE CURVE */
5689 /*       CBHEJA : TABLE OF COEFFICIENTS OF THE CURVE IN THE BASE */
5690 /*                HERMIT JACOBI */
5691 /*                (H(0,-1),..,H(ORDHER,-1),H(0,1),..,H(ORDHER,1), */
5692 /*                 JA(ORDHER+1,2*ORDHER+2),....,JA(ORDHER+1,NCOEFS-1) */
5693
5694 /*     OUTPUT ARGUMENTS  : */
5695 /*     --------------------- */
5696 /*       CBRCAN : TABLE OF COEFFICIENTS OF THE CURVE IN THE CANONIC BASE */
5697 /*                (1, t, ...) */
5698
5699 /*     COMMONS USED : */
5700 /*     ------------------ */
5701
5702
5703 /*     REFERENCES CALLED : */
5704 /*     --------------------- */
5705
5706
5707 /* ***********************************************************************
5708  */
5709
5710
5711 /* ***********************************************************************
5712  */
5713
5714 /*     FUNCTION : */
5715 /*     ---------- */
5716 /*        Providesinteger constants from 0 to 1000 */
5717
5718 /*     KEYWORDS : */
5719 /*     ----------- */
5720 /*        ALL, INTEGER */
5721
5722 /*     DEMSCRIPTION/NOTES/LIMITATIONS : */
5723 /*     ----------------------------------- */
5724 /* > */
5725 /* ***********************************************************************
5726  */
5727
5728
5729 /* ***********************************************************************
5730  */
5731
5732
5733
5734
5735 /* ***********************************************************************
5736  */
5737 /*                      INITIALIZATION */
5738 /* ***********************************************************************
5739  */
5740
5741     /* Parameter adjustments */
5742     --ncftab;
5743     tcbnew_dim1 = *ndimen;
5744     tcbnew_dim2 = *ncflim;
5745     tcbnew_offset = tcbnew_dim1 * (tcbnew_dim2 + 1) + 1;
5746     tcbnew -= tcbnew_offset;
5747     tcbold_dim1 = *ndimen;
5748     tcbold_dim2 = *ncflim;
5749     tcbold_offset = tcbold_dim1 * (tcbold_dim2 + 1) + 1;
5750     tcbold -= tcbold_offset;
5751
5752     /* Function Body */
5753     ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 2;
5754     if (ldbg) {
5755         AdvApp2Var_SysBase::mgenmsg_("MMHJCAN", 7L);
5756     }
5757     *iercod = 0;
5758
5759     bornes[0] = -1.;
5760     bornes[1] = 1.;
5761
5762 /* ***********************************************************************
5763  */
5764 /*                     PROCESSING */
5765 /* ***********************************************************************
5766  */
5767
5768     if (*orcont > 2) {
5769         goto L9101;
5770     }
5771     if (*ncflim > 21) {
5772         goto L9101;
5773     }
5774
5775 /*     CALCULATION OF HERMIT POLYNOMS IN THE CANONIC BASE ON (-1,1) */
5776
5777
5778     iordre[0] = *orcont;
5779     iordre[1] = *orcont;
5780     mmherm1_(bornes, &c__2, iordre, hermit, &ier);
5781     if (ier > 0) {
5782         goto L9102;
5783     }
5784
5785
5786     aux1 = *orcont + 1;
5787     aux2 = aux1 << 1;
5788
5789     i__1 = *ncourb;
5790     for (e = 1; e <= i__1; ++e) {
5791
5792         ctenor = (tdecop[e] - tdecop[e - 1]) / 2;
5793         ncoeff = ncftab[e];
5794         ndeg = ncoeff - 1;
5795         if (ncoeff > 21) {
5796             goto L9101;
5797         }
5798
5799         i__2 = *ndimen;
5800         for (d__ = 1; d__ <= i__2; ++d__) {
5801
5802 /*     CONVERSION OF THE COEFFICIENTS OF THE PART OF THE CURVE EXPRESSED */
5803 /*     IN HERMIT BASE, INTO THE CANONIC BASE */
5804
5805             AdvApp2Var_SysBase::mvriraz_(&ncoeff, taux1);
5806
5807             i__3 = aux2;
5808             for (k = 1; k <= i__3; ++k) {
5809                 i__4 = aux1;
5810                 for (i__ = 1; i__ <= i__4; ++i__) {
5811                     i__5 = i__ - 1;
5812                     mfact = AdvApp2Var_MathBase::pow__di(&ctenor, &i__5);
5813                     taux1[k - 1] += (tcbold[d__ + (i__ + e * tcbold_dim2) *
5814                             tcbold_dim1] * hermit[k + (i__ + 2) * 6 - 19] +
5815                             tcbold[d__ + (i__ + aux1 + e * tcbold_dim2) *
5816                             tcbold_dim1] * hermit[k + (i__ + 5) * 6 - 19]) *
5817                             mfact;
5818                 }
5819             }
5820
5821
5822             i__3 = ncoeff;
5823             for (i__ = aux2 + 1; i__ <= i__3; ++i__) {
5824                 taux1[i__ - 1] = tcbold[d__ + (i__ + e * tcbold_dim2) *
5825                         tcbold_dim1];
5826             }
5827
5828 /*     CONVERSION OF THE COEFFICIENTS OF THE PART OF THE CURVE EXPRESSED */
5829 /*     IN CANONIC-JACOBI BASE, INTO THE CANONIC BASE */
5830
5831
5832
5833             AdvApp2Var_MathBase::mmapcmp_(&minombr_.nbr[1], &c__21, &ncoeff, taux1, tjacap);
5834             AdvApp2Var_MathBase::mmjacan_(orcont, &ndeg, tjacap, taux1);
5835
5836 /*        RECOPY THE COEFS RESULTING FROM THE CONVERSION IN THE TABLE */
5837 /*        OF RESULTS */
5838
5839             i__3 = ncoeff;
5840             for (i__ = 1; i__ <= i__3; ++i__) {
5841                 tcbnew[d__ + (i__ + e * tcbnew_dim2) * tcbnew_dim1] = taux1[
5842                         i__ - 1];
5843             }
5844
5845         }
5846     }
5847
5848     goto L9999;
5849
5850 /* ***********************************************************************
5851  */
5852 /*                   PROCESSING OF ERRORS */
5853 /* ***********************************************************************
5854  */
5855
5856 L9101:
5857     *iercod = 1;
5858     goto L9999;
5859 L9102:
5860     *iercod = 2;
5861     goto L9999;
5862
5863 /* ***********************************************************************
5864  */
5865 /*                   RETURN CALLING PROGRAM */
5866 /* ***********************************************************************
5867  */
5868
5869 L9999:
5870
5871     AdvApp2Var_SysBase::maermsg_("MMHJCAN", iercod, 7L);
5872     if (ldbg) {
5873         AdvApp2Var_SysBase::mgsomsg_("MMHJCAN", 7L);
5874     }
5875  return 0 ;
5876 } /* mmhjcan_ */
5877
5878 //=======================================================================
5879 //function : AdvApp2Var_MathBase::mminltt_
5880 //purpose  :
5881 //=======================================================================
5882  int AdvApp2Var_MathBase::mminltt_(integer *ncolmx,
5883                             integer *nlgnmx,
5884                             doublereal *tabtri,
5885                             integer *nbrcol,
5886                             integer *nbrlgn,
5887                             doublereal *ajoute,
5888                             doublereal *,//epseg,
5889                             integer *iercod)
5890 {
5891   /* System generated locals */
5892   integer tabtri_dim1, tabtri_offset, i__1, i__2;
5893
5894   /* Local variables */
5895   logical idbg;
5896   integer icol, ilgn, nlgn, noct, inser;
5897   doublereal epsega = 0.;
5898   integer ibb;
5899
5900 /* ***********************************************************************
5901  */
5902
5903 /*     FUNCTION : */
5904 /*     ---------- */
5905 /*        . Insert a line in a table parsed without redundance */
5906
5907 /*     KEYWORDS : */
5908 /*     ----------- */
5909 /*      TOUS,MATH_ACCES :: TABLEAU&,INSERTION,&TABLEAU */
5910
5911 /*     INPUT ARGUMENTS : */
5912 /*     -------------------- */
5913 /*        . NCOLMX : Number of columns in the table */
5914 /*        . NLGNMX : Number of lines in the table */
5915 /*        . TABTRI : Table parsed by lines without redundances */
5916 /*        . NBRCOL : Number of columns used */
5917 /*        . NBRLGN : Number of lines used */
5918 /*        . AJOUTE : Line to be added */
5919 /*        . EPSEGA : Epsilon to test the redundance */
5920
5921 /*     OUTPUT ARGUMENTS : */
5922 /*     --------------------- */
5923 /*        . TABTRI : Table parsed by lines without redundances */
5924 /*        . NBRLGN : Number of lines used */
5925 /*        . IERCOD : 0 -> No problem */
5926 /*                   1 -> The table is full */
5927
5928 /*     COMMONS USED : */
5929 /*     ------------------ */
5930
5931 /*     REFERENCES CALLED : */
5932 /*     --------------------- */
5933
5934 /*     DESCRIPTION/NOTES/LIMITATIONS : */
5935 /*     ----------------------------------- */
5936 /*        . The line is inserted only if there is no line with all
5937 */
5938 /*     elements equl to those which are planned to be insered, to epsilon. */
5939
5940 /*        . Level of de debug = 3 */
5941
5942
5943 /*
5944 /*     DECLARATIONS , CONTROL OF INPUT ARGUMENTS , INITIALIZATION */
5945 /* ***********************************************************************
5946  */
5947
5948 /* --- Parameters */
5949
5950
5951 /* --- Functions */
5952
5953
5954 /* --- Local variables */
5955
5956
5957 /* --- Messages */
5958
5959     /* Parameter adjustments */
5960     tabtri_dim1 = *ncolmx;
5961     tabtri_offset = tabtri_dim1 + 1;
5962     tabtri -= tabtri_offset;
5963     --ajoute;
5964
5965     /* Function Body */
5966     ibb = AdvApp2Var_SysBase::mnfndeb_();
5967     idbg = ibb >= 3;
5968     if (idbg) {
5969         AdvApp2Var_SysBase::mgenmsg_("MMINLTT", 7L);
5970     }
5971
5972 /* --- Control arguments */
5973
5974     if (*nbrlgn >= *nlgnmx) {
5975         goto L9001;
5976     }
5977
5978 /* -------------------- */
5979 /* *** INITIALIZATION */
5980 /* -------------------- */
5981
5982     *iercod = 0;
5983
5984 /* ---------------------------- */
5985 /* *** SEARCH OF REDUNDANCE */
5986 /* ---------------------------- */
5987
5988     i__1 = *nbrlgn;
5989     for (ilgn = 1; ilgn <= i__1; ++ilgn) {
5990         if (tabtri[ilgn * tabtri_dim1 + 1] >= ajoute[1] - epsega) {
5991             if (tabtri[ilgn * tabtri_dim1 + 1] <= ajoute[1] + epsega) {
5992                 i__2 = *nbrcol;
5993                 for (icol = 1; icol <= i__2; ++icol) {
5994                     if (tabtri[icol + ilgn * tabtri_dim1] < ajoute[icol] -
5995                             epsega || tabtri[icol + ilgn * tabtri_dim1] >
5996                             ajoute[icol] + epsega) {
5997                         goto L20;
5998                     }
5999 /* L10: */
6000                 }
6001                 goto L9999;
6002             } else {
6003                 goto L30;
6004             }
6005         }
6006 L20:
6007         ;
6008     }
6009
6010 /* ----------------------------------- */
6011 /* *** SEARCH OF THE INSERTION POINT */
6012 /* ----------------------------------- */
6013
6014 L30:
6015
6016     i__1 = *nbrlgn;
6017     for (ilgn = 1; ilgn <= i__1; ++ilgn) {
6018         i__2 = *nbrcol;
6019         for (icol = 1; icol <= i__2; ++icol) {
6020             if (tabtri[icol + ilgn * tabtri_dim1] < ajoute[icol]) {
6021                 goto L50;
6022             }
6023             if (tabtri[icol + ilgn * tabtri_dim1] > ajoute[icol]) {
6024                 goto L70;
6025             }
6026 /* L60: */
6027         }
6028 L50:
6029         ;
6030     }
6031
6032     ilgn = *nbrlgn + 1;
6033
6034 /* -------------- */
6035 /* *** INSERTION */
6036 /* -------------- */
6037
6038 L70:
6039
6040     inser = ilgn;
6041     ++(*nbrlgn);
6042
6043 /* --- Shift lower */
6044
6045     nlgn = *nbrlgn - inser;
6046     if (nlgn > 0) {
6047         noct = (*ncolmx << 3) * nlgn;
6048         AdvApp2Var_SysBase::mcrfill_(&noct,
6049                  &tabtri[inser * tabtri_dim1 + 1],
6050                  &tabtri[(inser + 1)* tabtri_dim1 + 1]);
6051     }
6052
6053 /* --- Copy line */
6054
6055     noct = *nbrcol << 3;
6056     AdvApp2Var_SysBase::mcrfill_(&noct,
6057              &ajoute[1],
6058              &tabtri[inser * tabtri_dim1 + 1]);
6059
6060     goto L9999;
6061
6062 /* ******************************************************************** */
6063 /*       OUTPUT ERROR , RETURN CALLING PROGRAM , MESSAGES */
6064 /* ******************************************************************** */
6065
6066 /* --- The table is already full */
6067
6068 L9001:
6069     *iercod = 1;
6070
6071 /* --- End */
6072
6073 L9999:
6074     if (*iercod != 0) {
6075         AdvApp2Var_SysBase::maermsg_("MMINLTT", iercod, 7L);
6076     }
6077     if (idbg) {
6078         AdvApp2Var_SysBase::mgsomsg_("MMINLTT", 7L);
6079     }
6080  return 0 ;
6081 } /* mminltt_ */
6082
6083 //=======================================================================
6084 //function : AdvApp2Var_MathBase::mmjacan_
6085 //purpose  :
6086 //=======================================================================
6087  int AdvApp2Var_MathBase::mmjacan_(const integer *ideriv,
6088                             integer *ndeg,
6089                             doublereal *poljac,
6090                             doublereal *polcan)
6091 {
6092     /* System generated locals */
6093   integer poljac_dim1, i__1, i__2;
6094
6095   /* Local variables */
6096   integer iptt, i__, j, ibb;
6097   doublereal bid;
6098
6099 /* ***********************************************************************
6100  */
6101
6102 /*     FUNCTION : */
6103 /*     ---------- */
6104 /*     Routine of transfer of Jacobi normalized to canonic [-1,1], */
6105 /*     the tables are ranked by even, then by uneven degree. */
6106
6107 /*     KEYWORDS : */
6108 /*     ----------- */
6109 /*        LEGENDRE,JACOBI,PASSAGE. */
6110
6111 /*     INPUT ARGUMENTS  : */
6112 /*     ------------------ */
6113 /*        IDERIV : Order of Jacobi between -1 and 2. */
6114 /*        NDEG :   The true degree of the polynom. */
6115 /*        POLJAC : The polynom in the Jacobi base. */
6116
6117 /*     OUTPUT ARGUMENTS : */
6118 /*     ------------------- */
6119 /*        POLCAN : The curve expressed in the canonic base [-1,1]. */
6120
6121 /*     COMMONS USED   : */
6122 /*     ---------------- */
6123
6124 /*     REFERENCES CALLED   : */
6125 /*     ----------------------- */
6126
6127 /*     DESCRIPTION/NOTES/LIMITATIONS : */
6128 /*     ----------------------------------- */
6129
6130 /* > */
6131 /* ***********************************************************************
6132  */
6133
6134 /*   Name of the routine */
6135
6136 /*   Matrices of conversion */
6137
6138
6139 /* ***********************************************************************
6140  */
6141
6142 /*     FUNCTION : */
6143 /*     ---------- */
6144 /*        MATRIX OF TRANSFORMATION OF LEGENDRE BASE */
6145
6146 /*     KEYWORDS : */
6147 /*     ----------- */
6148 /*        MATH */
6149
6150 /*     DEMSCRIPTION/NOTES/LIMITATIONS : */
6151 /*     ----------------------------------- */
6152
6153 /* > */
6154 /* ***********************************************************************
6155  */
6156
6157
6158
6159 /*  Legendre common / Restricted Casteljau. */
6160
6161 /*   0:1      0 Concerns the even terms, 1 the uneven terms. */
6162 /*   CANPLG : Matrix of passage to canonic from Jacobi with calculated parities */
6163 /*   PLGCAN : Matrix of passage from Jacobi to canonic with calculated parities */
6164
6165
6166 /* ***********************************************************************
6167  */
6168
6169     /* Parameter adjustments */
6170     poljac_dim1 = *ndeg / 2 + 1;
6171
6172     /* Function Body */
6173     ibb = AdvApp2Var_SysBase::mnfndeb_();
6174     if (ibb >= 5) {
6175         AdvApp2Var_SysBase::mgenmsg_("MMJACAN", 7L);
6176     }
6177
6178 /* ----------------- Expression of terms of even degree ----------------
6179 */
6180
6181     i__1 = *ndeg / 2;
6182     for (i__ = 0; i__ <= i__1; ++i__) {
6183         bid = 0.;
6184         iptt = i__ * 31 - (i__ + 1) * i__ / 2 + 1;
6185         i__2 = *ndeg / 2;
6186         for (j = i__; j <= i__2; ++j) {
6187             bid += mmjcobi_.plgcan[iptt + j + *ideriv * 992 + 991] * poljac[
6188                     j];
6189 /* L310: */
6190         }
6191         polcan[i__ * 2] = bid;
6192 /* L300: */
6193     }
6194
6195 /* --------------- Expression of terms of uneven degree ----------------
6196 */
6197
6198     if (*ndeg == 0) {
6199         goto L9999;
6200     }
6201
6202     i__1 = (*ndeg - 1) / 2;
6203     for (i__ = 0; i__ <= i__1; ++i__) {
6204         bid = 0.;
6205         iptt = i__ * 31 - (i__ + 1) * i__ / 2 + 1;
6206         i__2 = (*ndeg - 1) / 2;
6207         for (j = i__; j <= i__2; ++j) {
6208             bid += mmjcobi_.plgcan[iptt + j + ((*ideriv << 1) + 1) * 496 +
6209                     991] * poljac[j + poljac_dim1];
6210 /* L410: */
6211         }
6212         polcan[(i__ << 1) + 1] = bid;
6213 /* L400: */
6214     }
6215
6216 /* -------------------------------- The end -----------------------------
6217 */
6218
6219 L9999:
6220     if (ibb >= 5) {
6221         AdvApp2Var_SysBase::mgsomsg_("MMJACAN", 7L);
6222     }
6223     return 0;
6224 } /* mmjacan_ */
6225
6226 //=======================================================================
6227 //function : AdvApp2Var_MathBase::mmjaccv_
6228 //purpose  :
6229 //=======================================================================
6230  int AdvApp2Var_MathBase::mmjaccv_(const integer *ncoef,
6231                             const integer *ndim,
6232                             const integer *ider,
6233                             const doublereal *crvlgd,
6234                             doublereal *polaux,
6235                             doublereal *crvcan)
6236
6237 {
6238   /* Initialized data */
6239
6240   static char nomprg[8+1] = "MMJACCV ";
6241
6242   /* System generated locals */
6243   integer crvlgd_dim1, crvlgd_offset, crvcan_dim1, crvcan_offset,
6244   polaux_dim1, i__1, i__2;
6245
6246   /* Local variables */
6247   integer ndeg, i__, nd, ii, ibb;
6248
6249 /* ***********************************************************************
6250  */
6251
6252 /*     FUNCTION : */
6253 /*     ---------- */
6254 /*        Passage from the normalized Jacobi base to the canonic base. */
6255
6256 /*     KEYWORDS : */
6257 /*     ----------- */
6258 /*        SMOOTHING, BASE, LEGENDRE */
6259
6260
6261 /*     INPUT ARGUMENTS : */
6262 /*     ------------------ */
6263 /*        NDIM: Space Dimension. */
6264 /*        NCOEF: Degree +1 of the polynom. */
6265 /*        IDER: Order of Jacobi polynoms. */
6266 /*        CRVLGD : Curve in the base of Jacobi. */
6267
6268 /*     OUTPUT ARGUMENTS : */
6269 /*     ------------------- */
6270 /*        POLAUX : Auxilliary space. */
6271 /*        CRVCAN : The curve in the canonic base [-1,1] */
6272
6273 /*     COMMONS USED   : */
6274 /*     ---------------- */
6275
6276 /*     REFERENCES CALLED   : */
6277 /*     ----------------------- */
6278
6279 /*     DESCRIPTION/NOTES/LIMITATIONS : */
6280 /*     ----------------------------------- */
6281
6282 /* > */
6283 /* *********************************************************************
6284 */
6285
6286 /*   Name of the routine */
6287     /* Parameter adjustments */
6288     polaux_dim1 = (*ncoef - 1) / 2 + 1;
6289     crvcan_dim1 = *ncoef - 1 + 1;
6290     crvcan_offset = crvcan_dim1;
6291     crvcan -= crvcan_offset;
6292     crvlgd_dim1 = *ncoef - 1 + 1;
6293     crvlgd_offset = crvlgd_dim1;
6294     crvlgd -= crvlgd_offset;
6295
6296     /* Function Body */
6297
6298     ibb = AdvApp2Var_SysBase::mnfndeb_();
6299     if (ibb >= 3) {
6300         AdvApp2Var_SysBase::mgenmsg_(nomprg, 6L);
6301     }
6302
6303     ndeg = *ncoef - 1;
6304
6305     i__1 = *ndim;
6306     for (nd = 1; nd <= i__1; ++nd) {
6307 /*  Loading of the auxilliary table. */
6308         ii = 0;
6309         i__2 = ndeg / 2;
6310         for (i__ = 0; i__ <= i__2; ++i__) {
6311             polaux[i__] = crvlgd[ii + nd * crvlgd_dim1];
6312             ii += 2;
6313 /* L310: */
6314         }
6315
6316         ii = 1;
6317         if (ndeg >= 1) {
6318             i__2 = (ndeg - 1) / 2;
6319             for (i__ = 0; i__ <= i__2; ++i__) {
6320                 polaux[i__ + polaux_dim1] = crvlgd[ii + nd * crvlgd_dim1];
6321                 ii += 2;
6322 /* L320: */
6323             }
6324         }
6325 /*   Call the routine of base change. */
6326         AdvApp2Var_MathBase::mmjacan_(ider, &ndeg, polaux, &crvcan[nd * crvcan_dim1]);
6327 /* L300: */
6328     }
6329
6330
6331 /* L9999: */
6332     return 0;
6333 } /* mmjaccv_ */
6334
6335 //=======================================================================
6336 //function : mmloncv_
6337 //purpose  :
6338 //=======================================================================
6339 int mmloncv_(integer *ndimax,
6340              integer *ndimen,
6341              integer *ncoeff,
6342              doublereal *courbe,
6343              doublereal *tdebut,
6344              doublereal *tfinal,
6345              doublereal *xlongc,
6346              integer *iercod)
6347
6348 {
6349   /* Initialized data */
6350
6351   integer kgar = 0;
6352
6353   /* System generated locals */
6354   integer courbe_dim1, courbe_offset, i__1, i__2;
6355
6356   /* Local variables */
6357   doublereal tran;
6358   integer ngaus;
6359   doublereal c1, c2, d1, d2, wgaus[20], uroot[20], x1, x2, dd;
6360   integer ii, jj, kk;
6361   doublereal som;
6362   doublereal der1, der2;
6363
6364
6365
6366
6367 /* **********************************************************************
6368 */
6369
6370 /*     FUNCTION : Length of an arc of curve on a given interval */
6371 /*     ---------- for a function the mathematic representation  */
6372 /*                which of is a multidimensional polynom. */
6373 /*      The polynom is a set of polynoms the coefficients which of are ranked
6374         /*  in a table with 2 indices, each line relative to 1 polynom. */
6375 /*      The polynom is defined by its coefficients ordered by increasing
6376 *       power of the variable. */
6377 /*      All polynoms have the same number of coefficients (and the same degree). */
6378
6379 /*     KEYWORDS : LENGTH, CURVE */
6380 /*     ----------- */
6381
6382 /*     INPUT ARGUMENTS : */
6383 /*     -------------------- */
6384
6385 /*      NDIMAX : Max number of lines of tables (max number of polynoms). */
6386 /*      NDIMEN : Dimension of the polynom (Nomber of polynoms). */
6387 /*      NCOEFF : Number of coefficients of the polynom (no limitation) */
6388 /*               This is degree + 1 */
6389 /*      COURBE : Coefficients of the polynom ordered by increasing power */
6390 /*               Dimension to (NDIMAX,NCOEFF). */
6391 /*      TDEBUT : Lower limit of integration for length calculation. */
6392 /*      TFINAL : Upper limit of integration for length calculation.  */
6393
6394 /*     OUTPUT ARGUMENTS : */
6395 /*     --------------------- */
6396 /*      XLONGC : Length of arc of curve */
6397
6398 /*      IERCOD : Error code : */
6399 /*             = 0 ==> All is OK */
6400 /*             = 1 ==> NDIMEN or NCOEFF negative or null */
6401 /*             = 2 ==> Pb loading Legendre roots and Gauss weight */
6402 /*                     by MVGAUS0. */
6403
6404 /*     If error => XLONGC = 0 */
6405
6406 /*     COMMONS USED : */
6407 /*     ------------------ */
6408
6409 /*      .Neant. */
6410
6411 /*     REFERENCES CALLED   : */
6412 /*     ---------------------- */
6413 /*     Type  Name */
6414 /*           MAERMSG         R*8  DSQRT          I*4  MIN */
6415 /*           MVGAUS0 */
6416
6417 /*     DESCRIPTION/NOTES/LIMITATIONS : */
6418 /*     ----------------------------------- */
6419
6420 /*      See VGAUSS to understand well the technique. */
6421 /*      Actually SQRT (dpi^2) is integrated for i=1,nbdime */
6422 /*      Calculation of the derivative is included in the code to avoid an additional */
6423 /*      call of the routine. */
6424
6425 /*      The integrated function is strictly increasing, it */
6426 /*      is not necessary to use a high degree for the GAUSS method GAUSS. */
6427
6428 /*      The degree of LEGENDRE polynom results from the degree of the */
6429 /*      polynom to be integrated. It can vary from 4 to 40 (with step of 4). */
6430
6431 /*      The precision (relative) of integration is of order 1.D-8. */
6432
6433 /*      ATTENTION : if TDEBUT > TFINAL, the length is NEGATIVE. */
6434
6435 /*      Attention : the precision of the result is not controlled. */
6436 /*      If you wish to control it, use  MMCGLC1, taking into account that  */
6437 /*      the performance (in time) will be worse. */
6438
6439 /* >=====================================================================
6440 */
6441
6442 /*      ATTENTION : SAVE KGAR WGAUS and UROOT EVENTUALLY */
6443 /*     ,IERXV */
6444 /*      INTEGER I1,I20 */
6445 /*      PARAMETER (I1=1,I20=20) */
6446
6447     /* Parameter adjustments */
6448     courbe_dim1 = *ndimax;
6449     courbe_offset = courbe_dim1 + 1;
6450     courbe -= courbe_offset;
6451
6452     /* Function Body */
6453
6454 /* ****** General initialization ** */
6455
6456     *iercod = 999999;
6457     *xlongc = 0.;
6458
6459 /* ****** Initialization of UROOT, WGAUS, NGAUS and KGAR ** */
6460
6461 /*      CALL MXVINIT(IERXV,'INTEGER',I1,KGAR,'INTEGER',I1,NGAUS */
6462 /*     1    ,'DOUBLE PRECISION',I20,UROOT,'DOUBLE PRECISION',I20,WGAUS) */
6463 /*      IF (IERXV.GT.0) KGAR=0 */
6464
6465 /* ****** Test the equity of limits ** */
6466
6467     if (*tdebut == *tfinal) {
6468         *iercod = 0;
6469         goto L9900;
6470     }
6471
6472 /* ****** Test the dimension and the number of coefficients ** */
6473
6474     if (*ndimen <= 0 || *ncoeff <= 0) {
6475         *iercod = 1;
6476         goto L9900;
6477     }
6478
6479 /* ****** Calculate the optimal degree ** */
6480
6481     kk = *ncoeff / 4 + 1;
6482     kk = advapp_min(kk,10);
6483
6484 /* ****** Return the coefficients for the integral (DEGRE=4*KK) */
6485 /*       if KK <> KGAR. */
6486
6487     if (kk != kgar) {
6488         mvgaus0_(&kk, uroot, wgaus, &ngaus, iercod);
6489         if (*iercod > 0) {
6490             kgar = 0;
6491             *iercod = 2;
6492             goto L9900;
6493         }
6494         kgar = kk;
6495     }
6496
6497 /*      C1 => Point medium interval */
6498 /*      C2 => 1/2 amplitude interval */
6499
6500     c1 = (*tfinal + *tdebut) * .5;
6501     c2 = (*tfinal - *tdebut) * .5;
6502
6503 /* ----------------------------------------------------------- */
6504 /* ****** Integration - Loop on GAUSS intervals ** */
6505 /* ----------------------------------------------------------- */
6506
6507     som = 0.;
6508
6509     i__1 = ngaus;
6510     for (jj = 1; jj <= i__1; ++jj) {
6511
6512 /* ****** Integration taking the symmetry into account ** */
6513
6514         tran = c2 * uroot[jj - 1];
6515         x1 = c1 + tran;
6516         x2 = c1 - tran;
6517
6518 /* ****** Derivation on the dimension of the space ** */
6519
6520         der1 = 0.;
6521         der2 = 0.;
6522         i__2 = *ndimen;
6523         for (kk = 1; kk <= i__2; ++kk) {
6524             d1 = (*ncoeff - 1) * courbe[kk + *ncoeff * courbe_dim1];
6525             d2 = d1;
6526             for (ii = *ncoeff - 1; ii >= 2; --ii) {
6527                 dd = (ii - 1) * courbe[kk + ii * courbe_dim1];
6528                 d1 = d1 * x1 + dd;
6529                 d2 = d2 * x2 + dd;
6530 /* L100: */
6531             }
6532             der1 += d1 * d1;
6533             der2 += d2 * d2;
6534 /* L200: */
6535         }
6536
6537 /* ****** Integration ** */
6538
6539         som += wgaus[jj - 1] * c2 * (sqrt(der1) + sqrt(der2));
6540
6541 /* ****** End of loop on GAUSS intervals ** */
6542
6543 /* L300: */
6544     }
6545
6546 /* ****** Work ended ** */
6547
6548     *xlongc = som;
6549
6550 /* ****** It is forced IERCOD  =  0 ** */
6551
6552     *iercod = 0;
6553
6554 /* ****** Final processing ** */
6555
6556 L9900:
6557
6558 /* ****** Save UROOT, WGAUS, NGAUS and KGAR ** */
6559
6560 /*      CALL MXVSAVE(IERXV,'INTEGER',I1,KGAR,'INTEGER',I1,NGAUS */
6561 /*     1    ,'DOUBLE PRECISION',I20,UROOT,'DOUBLE PRECISION',I20,WGAUS) */
6562 /*      IF (IERXV.GT.0) KGAR=0 */
6563
6564 /* ****** End of sub-program ** */
6565
6566     if (*iercod != 0) {
6567         AdvApp2Var_SysBase::maermsg_("MMLONCV", iercod, 7L);
6568     }
6569  return 0 ;
6570 } /* mmloncv_ */
6571
6572 //=======================================================================
6573 //function : AdvApp2Var_MathBase::mmpobas_
6574 //purpose  :
6575 //=======================================================================
6576  int AdvApp2Var_MathBase::mmpobas_(doublereal *tparam,
6577                             integer *iordre,
6578                             integer *ncoeff,
6579                             integer *nderiv,
6580                             doublereal *valbas,
6581                             integer *iercod)
6582
6583 {
6584   integer c__2 = 2;
6585   integer c__1 = 1;
6586
6587
6588    /* Initialized data */
6589
6590     doublereal moin11[2] = { -1.,1. };
6591
6592     /* System generated locals */
6593     integer valbas_dim1, i__1;
6594
6595     /* Local variables */
6596     doublereal vjac[80], herm[24];
6597     integer iord[2];
6598     doublereal wval[4];
6599     integer nwcof, iunit;
6600     doublereal wpoly[7];
6601     integer ii, jj, iorjac;
6602     doublereal hermit[36]       /* was [6][3][2] */;
6603     integer kk1, kk2, kk3;
6604     integer khe, ier;
6605
6606
6607 /* ***********************************************************************
6608  */
6609
6610 /*     FUNCTION : */
6611 /*     ---------- */
6612 /*       Position on the polynoms of base hermit-Jacobi */
6613 /*       and their succesive derivatives */
6614
6615 /*     KEYWORDS : */
6616 /*     ----------- */
6617 /*      PUBLIC, POSITION, HERMIT, JACOBI */
6618
6619 /*     INPUT ARGUMENTS : */
6620 /*     -------------------- */
6621 /*       TPARAM : Parameter for which the position is found. */
6622 /*       IORDRE : Orderof hermit-Jacobi (-1,0,1, ou 2) */
6623 /*       NCOEFF : Number of coefficients of polynoms (Nb of value to calculate) */
6624 /*       NDERIV : Number of derivative to calculate (0<= N <=3) */
6625 /*              0 -> Position simple on base functions */
6626 /*              N -> Position on base functions and derivative */
6627 /*              of order 1 to N */
6628
6629 /*     OUTPUT ARGUMENTS : */
6630 /*     --------------------- */
6631 /*     VALBAS (NCOEFF, 0:NDERIV) : calculated value */
6632 /*           i */
6633 /*          d    vj(t)  = VALBAS(J, I) */
6634 /*          -- i */
6635 /*          dt */
6636
6637 /*    IERCOD : Error code */
6638 /*      0 : Ok */
6639 /*      1 : Incoherence of input arguments */
6640
6641 /*     COMMONS USED : */
6642 /*     -------------- */
6643
6644
6645 /*     REFERENCES CALLED : */
6646 /*     ------------------- */
6647
6648
6649 /*     DESCRIPTION/NOTES/LIMITATIONS : */
6650 /*     ----------------------------------- */
6651
6652 /* > */
6653 /* ***********************************************************************
6654  */
6655 /*                            DECLARATIONS */
6656 /* ***********************************************************************
6657  */
6658
6659
6660
6661     /* Parameter adjustments */
6662     valbas_dim1 = *ncoeff;
6663     --valbas;
6664
6665     /* Function Body */
6666
6667 /* ***********************************************************************
6668  */
6669 /*                      INITIALIZATIONS */
6670 /* ***********************************************************************
6671  */
6672
6673     *iercod = 0;
6674
6675 /* ***********************************************************************
6676  */
6677 /*                     PROCESSING */
6678 /* ***********************************************************************
6679  */
6680
6681     if (*nderiv > 3) {
6682         goto L9101;
6683     }
6684     if (*ncoeff > 20) {
6685         goto L9101;
6686     }
6687     if (*iordre > 2) {
6688         goto L9101;
6689     }
6690
6691     iord[0] = *iordre;
6692     iord[1] = *iordre;
6693     iorjac = (*iordre + 1) << 1;
6694
6695 /*  (1) Generic Calculations .... */
6696
6697 /*  (1.a) Calculation of hermit polynoms */
6698
6699     if (*iordre >= 0) {
6700         mmherm1_(moin11, &c__2, iord, hermit, &ier);
6701         if (ier > 0) {
6702             goto L9102;
6703         }
6704     }
6705
6706 /*  (1.b) Evaluation of hermit polynoms */
6707
6708     jj = 1;
6709     iunit = *nderiv + 1;
6710     khe = (*iordre + 1) * iunit;
6711
6712     if (*nderiv > 0) {
6713
6714         i__1 = *iordre;
6715         for (ii = 0; ii <= i__1; ++ii) {
6716             mmdrvcb_(nderiv, &c__1, &iorjac, &hermit[(ii + 3) * 6 - 18],
6717                     tparam, &herm[jj - 1], &ier);
6718             if (ier > 0) {
6719                 goto L9102;
6720             }
6721
6722             mmdrvcb_(nderiv, &c__1, &iorjac, &hermit[(ii + 6) * 6 - 18],
6723                     tparam, &herm[jj + khe - 1], &ier);
6724             if (ier > 0) {
6725                 goto L9102;
6726             }
6727             jj += iunit;
6728         }
6729
6730     } else {
6731
6732         i__1 = *iordre;
6733         for (ii = 0; ii <= i__1; ++ii) {
6734             AdvApp2Var_MathBase::mmpocrb_(&c__1, &iorjac, &hermit[(ii + 3) * 6 - 18], &c__1,
6735                     tparam, &herm[jj - 1]);
6736
6737             AdvApp2Var_MathBase::mmpocrb_(&c__1, &iorjac, &hermit[(ii + 6) * 6 - 18], &c__1,
6738                     tparam, &herm[jj + khe - 1]);
6739             jj += iunit;
6740         }
6741     }
6742
6743 /*  (1.c) Evaluation of Jacobi polynoms */
6744
6745     ii = *ncoeff - iorjac;
6746
6747     mmpojac_(tparam, &iorjac, &ii, nderiv, vjac, &ier);
6748     if (ier > 0) {
6749         goto L9102;
6750     }
6751
6752 /*  (1.d) Evaluation of W(t) */
6753
6754 /* Computing MAX */
6755     i__1 = iorjac + 1;
6756     nwcof = advapp_max(i__1,1);
6757     AdvApp2Var_SysBase::mvriraz_(&nwcof,
6758              wpoly);
6759     wpoly[0] = 1.;
6760     if (*iordre == 2) {
6761         wpoly[2] = -3.;
6762         wpoly[4] = 3.;
6763         wpoly[6] = -1.;
6764     } else if (*iordre == 1) {
6765         wpoly[2] = -2.;
6766         wpoly[4] = 1.;
6767     } else if (*iordre == 0) {
6768         wpoly[2] = -1.;
6769     }
6770
6771     mmdrvcb_(nderiv, &c__1, &nwcof, wpoly, tparam, wval, &ier);
6772     if (ier > 0) {
6773         goto L9102;
6774     }
6775
6776     kk1 = *ncoeff - iorjac;
6777     kk2 = kk1 << 1;
6778     kk3 = kk1 * 3;
6779
6780 /*  (2) Evaluation of order 0 */
6781
6782     jj = 1;
6783     i__1 = iorjac;
6784     for (ii = 1; ii <= i__1; ++ii) {
6785         valbas[ii] = herm[jj - 1];
6786         jj += iunit;
6787     }
6788
6789     i__1 = kk1;
6790     for (ii = 1; ii <= i__1; ++ii) {
6791         valbas[ii + iorjac] = wval[0] * vjac[ii - 1];
6792     }
6793
6794 /*  (3) Evaluation of order 1 */
6795
6796     if (*nderiv >= 1) {
6797         jj = 2;
6798         i__1 = iorjac;
6799         for (ii = 1; ii <= i__1; ++ii) {
6800             valbas[ii + valbas_dim1] = herm[jj - 1];
6801             jj += iunit;
6802         }
6803
6804
6805         i__1 = kk1;
6806         for (ii = 1; ii <= i__1; ++ii) {
6807             valbas[ii + iorjac + valbas_dim1] = wval[0] * vjac[ii + kk1 - 1]
6808                     + wval[1] * vjac[ii - 1];
6809         }
6810     }
6811
6812 /*  (4)  Evaluation of order 2 */
6813
6814     if (*nderiv >= 2) {
6815         jj = 3;
6816         i__1 = iorjac;
6817         for (ii = 1; ii <= i__1; ++ii) {
6818             valbas[ii + (valbas_dim1 << 1)] = herm[jj - 1];
6819             jj += iunit;
6820         }
6821
6822         i__1 = kk1;
6823         for (ii = 1; ii <= i__1; ++ii) {
6824             valbas[ii + iorjac + (valbas_dim1 << 1)] = wval[0] * vjac[ii +
6825                     kk2 - 1] + wval[1] * 2 * vjac[ii + kk1 - 1] + wval[2] *
6826                     vjac[ii - 1];
6827         }
6828     }
6829
6830 /*  (5) Evaluation of order 3 */
6831
6832     if (*nderiv >= 3) {
6833         jj = 4;
6834         i__1 = iorjac;
6835         for (ii = 1; ii <= i__1; ++ii) {
6836             valbas[ii + valbas_dim1 * 3] = herm[jj - 1];
6837             jj += iunit;
6838         }
6839
6840         i__1 = kk1;
6841         for (ii = 1; ii <= i__1; ++ii) {
6842             valbas[ii + iorjac + valbas_dim1 * 3] = wval[0] * vjac[ii + kk3 -
6843                     1] + wval[1] * 3 * vjac[ii + kk2 - 1] + wval[2] * 3 *
6844                     vjac[ii + kk1 - 1] + wval[3] * vjac[ii - 1];
6845         }
6846     }
6847
6848     goto L9999;
6849
6850 /* ***********************************************************************
6851  */
6852 /*                   ERROR PROCESSING */
6853 /* ***********************************************************************
6854  */
6855
6856 L9101:
6857     *iercod = 1;
6858     goto L9999;
6859
6860 L9102:
6861     *iercod = 2;
6862
6863 /* ***********************************************************************
6864  */
6865 /*                   RETURN CALLING PROGRAM */
6866 /* ***********************************************************************
6867  */
6868
6869 L9999:
6870
6871     if (*iercod > 0) {
6872         AdvApp2Var_SysBase::maermsg_("MMPOBAS", iercod, 7L);
6873     }
6874  return 0 ;
6875 } /* mmpobas_ */
6876
6877 //=======================================================================
6878 //function : AdvApp2Var_MathBase::mmpocrb_
6879 //purpose  :
6880 //=======================================================================
6881  int AdvApp2Var_MathBase::mmpocrb_(integer *ndimax,
6882                             integer *ncoeff,
6883                             doublereal *courbe,
6884                             integer *ndim,
6885                             doublereal *tparam,
6886                             doublereal *pntcrb)
6887
6888 {
6889   /* System generated locals */
6890   integer courbe_dim1, courbe_offset, i__1, i__2;
6891
6892   /* Local variables */
6893   integer ncof2;
6894   integer isize, nd, kcf, ncf;
6895
6896
6897 /* ***********************************************************************
6898  */
6899
6900 /*     FUNCTION : */
6901 /*     ---------- */
6902 /*        CALCULATE THE COORDINATES OF A POINT OF A CURVE OF GIVEN PARAMETER */
6903 /*        TPARAM ( IN 2D, 3D OR MORE) */
6904
6905 /*     KEYWORDS : */
6906 /*     ----------- */
6907 /*       TOUS , MATH_ACCES :: COURBE&,PARAMETRE& , POSITIONNEMENT , &POINT
6908  */
6909
6910 /*     INPUT ARGUMENTS  : */
6911 /*     ------------------ */
6912 /*        NDIMAX : format / dimension of the curve */
6913 /*        NCOEFF : Nb of coefficients of the curve */
6914 /*        COURBE : Matrix of coefficients of the curve */
6915 /*        NDIM   : Dimension useful of the workspace  */
6916 /*        TPARAM : Value of the parameter where the point is calculated */
6917
6918 /*     OUTPUT ARGUMENTS : */
6919 /*     ------------------- */
6920 /*        PNTCRB : Coordinates of the calculated point */
6921
6922 /*     COMMONS USED   : */
6923 /*     ---------------- */
6924
6925 /*      .Neant. */
6926
6927 /*     REFERENCES CALLED   : */
6928 /*     ---------------------- */
6929 /*     Type  Name */
6930 /*           MIRAZ                MVPSCR2              MVPSCR3 */
6931
6932 /*     DESCRIPTION/NOTES/LIMITATIONS : */
6933 /*     ----------------------------------- */
6934
6935 /* > */
6936 /* ***********************************************************************
6937  */
6938
6939
6940 /* ***********************************************************************
6941  */
6942
6943     /* Parameter adjustments */
6944     courbe_dim1 = *ndimax;
6945     courbe_offset = courbe_dim1 + 1;
6946     courbe -= courbe_offset;
6947     --pntcrb;
6948
6949     /* Function Body */
6950     isize = *ndim << 3;
6951     AdvApp2Var_SysBase::miraz_(&isize,
6952            &pntcrb[1]);
6953
6954     if (*ncoeff <= 0) {
6955         goto L9999;
6956     }
6957
6958 /*   optimal processing 3d */
6959
6960     if (*ndim == 3 && *ndimax == 3) {
6961         mvpscr3_(ncoeff, &courbe[courbe_offset], tparam, &pntcrb[1]);
6962
6963 /*   optimal processing 2d */
6964
6965     } else if (*ndim == 2 && *ndimax == 2) {
6966         mvpscr2_(ncoeff, &courbe[courbe_offset], tparam, &pntcrb[1]);
6967
6968 /*   Any dimension - scheme of HORNER */
6969
6970     } else if (*tparam == 0.) {
6971         i__1 = *ndim;
6972         for (nd = 1; nd <= i__1; ++nd) {
6973             pntcrb[nd] = courbe[nd + courbe_dim1];
6974 /* L100: */
6975         }
6976     } else if (*tparam == 1.) {
6977         i__1 = *ncoeff;
6978         for (ncf = 1; ncf <= i__1; ++ncf) {
6979             i__2 = *ndim;
6980             for (nd = 1; nd <= i__2; ++nd) {
6981                 pntcrb[nd] += courbe[nd + ncf * courbe_dim1];
6982 /* L300: */
6983             }
6984 /* L200: */
6985         }
6986     } else {
6987         ncof2 = *ncoeff + 2;
6988         i__1 = *ndim;
6989         for (nd = 1; nd <= i__1; ++nd) {
6990             i__2 = *ncoeff;
6991             for (ncf = 2; ncf <= i__2; ++ncf) {
6992                 kcf = ncof2 - ncf;
6993                 pntcrb[nd] = (pntcrb[nd] + courbe[nd + kcf * courbe_dim1]) * *
6994                         tparam;
6995 /* L500: */
6996             }
6997             pntcrb[nd] += courbe[nd + courbe_dim1];
6998 /* L400: */
6999         }
7000     }
7001
7002 L9999:
7003  return 0   ;
7004 } /* mmpocrb_ */
7005
7006 //=======================================================================
7007 //function : AdvApp2Var_MathBase::mmmpocur_
7008 //purpose  :
7009 //=======================================================================
7010  int AdvApp2Var_MathBase::mmmpocur_(integer *ncofmx,
7011                              integer *ndim,
7012                              integer *ndeg,
7013                              doublereal *courbe,
7014                              doublereal *tparam,
7015                              doublereal *tabval)
7016
7017 {
7018   /* System generated locals */
7019   integer courbe_dim1, courbe_offset, i__1;
7020
7021   /* Local variables */
7022   integer i__, nd;
7023   doublereal fu;
7024
7025
7026 /* ***********************************************************************
7027  */
7028
7029 /*     FUNCTION : */
7030 /*     ---------- */
7031 /*        Position of a point on curve (ncofmx,ndim). */
7032
7033 /*     KEYWORDS : */
7034 /*     ----------- */
7035 /*        TOUS , AB_SPECIFI :: COURBE&,POLYNOME&,POSITIONNEMENT,&POINT */
7036
7037 /*     INPUT ARGUMENTS  : */
7038 /*     ------------------ */
7039 /*        NCOFMX: Format / degree of the CURVE. */
7040 /*        NDIM  : Dimension of the space. */
7041 /*        NDEG  : Degree of the polynom. */
7042 /*        COURBE: Coefficients of the curve. */
7043 /*        TPARAM: Parameter on the curve */
7044
7045 /*     OUTPUT ARGUMENTS  : */
7046 /*     ------------------- */
7047 /*        TABVAL(NDIM): The resulting point (or table of values) */
7048
7049 /*     COMMONS USED   : */
7050 /*     ---------------- */
7051
7052 /*     REFERENCES CALLED : */
7053 /*     ----------------------- */
7054
7055 /*     DESCRIPTION/NOTES/LIMITATIONS : */
7056 /*     ----------------------------------- */
7057
7058 /* > */
7059 /* ***********************************************************************
7060  */
7061
7062     /* Parameter adjustments */
7063     --tabval;
7064     courbe_dim1 = *ncofmx;
7065     courbe_offset = courbe_dim1 + 1;
7066     courbe -= courbe_offset;
7067
7068     /* Function Body */
7069     if (*ndeg < 1) {
7070         i__1 = *ndim;
7071         for (nd = 1; nd <= i__1; ++nd) {
7072             tabval[nd] = 0.;
7073 /* L290: */
7074         }
7075     } else {
7076         i__1 = *ndim;
7077         for (nd = 1; nd <= i__1; ++nd) {
7078             fu = courbe[*ndeg + nd * courbe_dim1];
7079             for (i__ = *ndeg - 1; i__ >= 1; --i__) {
7080                 fu = fu * *tparam + courbe[i__ + nd * courbe_dim1];
7081 /* L120: */
7082             }
7083             tabval[nd] = fu;
7084 /* L300: */
7085         }
7086     }
7087  return 0 ;
7088 } /* mmmpocur_ */
7089
7090 //=======================================================================
7091 //function : mmpojac_
7092 //purpose  :
7093 //=======================================================================
7094 int mmpojac_(doublereal *tparam,
7095              integer *iordre,
7096              integer *ncoeff,
7097              integer *nderiv,
7098              doublereal *valjac,
7099              integer *iercod)
7100
7101 {
7102   integer c__2 = 2;
7103
7104     /* Initialized data */
7105
7106     integer nbcof = -1;
7107
7108     /* System generated locals */
7109     integer valjac_dim1, i__1, i__2;
7110
7111     /* Local variables */
7112     doublereal cofa, cofb, denom, tnorm[100];
7113     integer ii, jj, kk1, kk2;
7114     doublereal aux1, aux2;
7115
7116
7117 /* ***********************************************************************
7118  */
7119
7120 /*     FUNCTION : */
7121 /*     ---------- */
7122 /*       Positioning on Jacobi polynoms and their derivatives */
7123 /*       successive by a recurrent algorithm */
7124
7125 /*     KEYWORDS : */
7126 /*     ----------- */
7127 /*      RESERVE, POSITIONING, JACOBI */
7128
7129 /*     INPUT ARGUMENTS : */
7130 /*     -------------------- */
7131 /*       TPARAM : Parameter for which positioning is done. */
7132 /*       IORDRE : Order of hermit-?? (-1,0,1, or 2) */
7133 /*       NCOEFF : Number of coeeficients of polynoms (Nb of value to */
7134 /*                calculate) */
7135 /*       NDERIV : Number of derivative to calculate (0<= N <=3) */
7136 /*              0 -> Position simple on jacobi functions */
7137 /*              N -> Position on jacobi functions and their */
7138 /*              derivatives of order 1 to N. */
7139
7140 /*     OUTPUT ARGUMENTS : */
7141 /*     --------------------- */
7142 /*     VALJAC (NCOEFF, 0:NDERIV) : the calculated values */
7143 /*           i */
7144 /*          d    vj(t)  = VALJAC(J, I) */
7145 /*          -- i */
7146 /*          dt */
7147
7148 /*    IERCOD : Error Code */
7149 /*      0 : Ok */
7150 /*      1 : Incoherence of input arguments */
7151
7152 /*     COMMONS USED : */
7153 /*     ------------------ */
7154
7155
7156 /*     REFERENCES CALLED : */
7157 /*     --------------------- */
7158
7159
7160 /*     DESCRIPTION/NOTES/LIMITATIONS : */
7161 /*     ----------------------------------- */
7162
7163 /* > */
7164 /* ***********************************************************************
7165  */
7166 /*                            DECLARATIONS */
7167 /* ***********************************************************************
7168  */
7169
7170
7171 /*     static varaibles */
7172
7173
7174
7175     /* Parameter adjustments */
7176     valjac_dim1 = *ncoeff;
7177     --valjac;
7178
7179     /* Function Body */
7180
7181 /* ***********************************************************************
7182  */
7183 /*                      INITIALISATIONS */
7184 /* ***********************************************************************
7185  */
7186
7187     *iercod = 0;
7188
7189 /* ***********************************************************************
7190  */
7191 /*                     Processing */
7192 /* ***********************************************************************
7193  */
7194
7195     if (*nderiv > 3) {
7196         goto L9101;
7197     }
7198     if (*ncoeff > 100) {
7199         goto L9101;
7200     }
7201
7202 /*  --- Calculation of norms */
7203
7204 /*      IF (NCOEFF.GT.NBCOF) THEN */
7205     i__1 = *ncoeff;
7206     for (ii = 1; ii <= i__1; ++ii) {
7207         kk1 = ii - 1;
7208         aux2 = 1.;
7209         i__2 = *iordre;
7210         for (jj = 1; jj <= i__2; ++jj) {
7211             aux2 = aux2 * (doublereal) (kk1 + *iordre + jj) / (doublereal) (
7212                     kk1 + jj);
7213         }
7214         i__2 = (*iordre << 1) + 1;
7215         tnorm[ii - 1] = sqrt(aux2 * (kk1 * 2. + (*iordre << 1) + 1) / pow__ii(&
7216                 c__2, &i__2));
7217     }
7218
7219     nbcof = *ncoeff;
7220
7221 /*      END IF */
7222
7223 /*  --- Trivial Positions ----- */
7224
7225     valjac[1] = 1.;
7226     aux1 = (doublereal) (*iordre + 1);
7227     valjac[2] = aux1 * *tparam;
7228
7229     if (*nderiv >= 1) {
7230         valjac[valjac_dim1 + 1] = 0.;
7231         valjac[valjac_dim1 + 2] = aux1;
7232
7233         if (*nderiv >= 2) {
7234             valjac[(valjac_dim1 << 1) + 1] = 0.;
7235             valjac[(valjac_dim1 << 1) + 2] = 0.;
7236
7237             if (*nderiv >= 3) {
7238                 valjac[valjac_dim1 * 3 + 1] = 0.;
7239                 valjac[valjac_dim1 * 3 + 2] = 0.;
7240             }
7241         }
7242     }
7243
7244 /*  --- Positioning by recurrence */
7245
7246     i__1 = *ncoeff;
7247     for (ii = 3; ii <= i__1; ++ii) {
7248
7249         kk1 = ii - 1;
7250         kk2 = ii - 2;
7251         aux1 = (doublereal) (*iordre + kk2);
7252         aux2 = aux1 * 2;
7253         cofa = aux2 * (aux2 + 1) * (aux2 + 2);
7254         cofb = (aux2 + 2) * -2. * aux1 * aux1;
7255         denom = kk1 * 2. * (kk2 + (*iordre << 1) + 1) * aux2;
7256         denom = 1. / denom;
7257
7258 /*        --> Pi(t) */
7259         valjac[ii] = (cofa * *tparam * valjac[kk1] + cofb * valjac[kk2]) *
7260                 denom;
7261 /*        --> P'i(t) */
7262         if (*nderiv >= 1) {
7263             valjac[ii + valjac_dim1] = (cofa * *tparam * valjac[kk1 +
7264                     valjac_dim1] + cofa * valjac[kk1] + cofb * valjac[kk2 +
7265                     valjac_dim1]) * denom;
7266 /*        --> P''i(t) */
7267             if (*nderiv >= 2) {
7268                 valjac[ii + (valjac_dim1 << 1)] = (cofa * *tparam * valjac[
7269                         kk1 + (valjac_dim1 << 1)] + cofa * 2 * valjac[kk1 +
7270                         valjac_dim1] + cofb * valjac[kk2 + (valjac_dim1 << 1)]
7271                         ) * denom;
7272             }
7273 /*        --> P'i(t) */
7274             if (*nderiv >= 3) {
7275                 valjac[ii + valjac_dim1 * 3] = (cofa * *tparam * valjac[kk1 +
7276                         valjac_dim1 * 3] + cofa * 3 * valjac[kk1 + (
7277                         valjac_dim1 << 1)] + cofb * valjac[kk2 + valjac_dim1 *
7278                          3]) * denom;
7279             }
7280         }
7281     }
7282
7283 /*    ---> Normalization */
7284
7285     i__1 = *ncoeff;
7286     for (ii = 1; ii <= i__1; ++ii) {
7287         i__2 = *nderiv;
7288         for (jj = 0; jj <= i__2; ++jj) {
7289             valjac[ii + jj * valjac_dim1] = tnorm[ii - 1] * valjac[ii + jj *
7290                     valjac_dim1];
7291         }
7292     }
7293
7294     goto L9999;
7295
7296 /* ***********************************************************************
7297  */
7298 /*                   PROCESSING OF ERRORS */
7299 /* ***********************************************************************
7300  */
7301
7302 L9101:
7303     *iercod = 1;
7304     goto L9999;
7305
7306
7307 /* ***********************************************************************
7308  */
7309 /*                   RETURN CALLING PROGRAM */
7310 /* ***********************************************************************
7311  */
7312
7313 L9999:
7314
7315     if (*iercod > 0) {
7316         AdvApp2Var_SysBase::maermsg_("MMPOJAC", iercod, 7L);
7317     }
7318  return 0 ;
7319 } /* mmpojac_ */
7320
7321 //=======================================================================
7322 //function : AdvApp2Var_MathBase::mmposui_
7323 //purpose  :
7324 //=======================================================================
7325  int AdvApp2Var_MathBase::mmposui_(integer *dimmat,
7326                             integer *,//nistoc,
7327                             integer *aposit,
7328                             integer *posuiv,
7329                             integer *iercod)
7330
7331 {
7332   /* System generated locals */
7333   integer i__1, i__2;
7334
7335   /* Local variables */
7336   logical ldbg;
7337   integer imin, jmin, i__, j, k;
7338   logical trouve;
7339
7340 /* ***********************************************************************
7341  */
7342
7343 /*     FUNCTION : */
7344 /*     ---------- */
7345 /*       FILL THE TABLE OF POSITIONING POSUIV WHICH ALLOWS TO */
7346 /*       PARSE BY COLUMN THE INFERIOR TRIANGULAR PART OF THE */
7347 /*       MATRIX  IN FORM OF PROFILE */
7348
7349
7350 /*     KEYWORDS : */
7351 /*     ----------- */
7352 /*      RESERVE, MATRIX, PROFILE */
7353
7354 /*     INPUT ARGUMENTS : */
7355 /*     -------------------- */
7356
7357 /*       NISTOC: NUMBER OF COEFFICIENTS IN THE PROFILE */
7358 /*       DIMMAT: NUMBER OF LINE OF THE SYMMETRIC SQUARE MATRIX */
7359 /*       APOSIT: TABLE OF POSITIONING OF STORAGE TERMS */
7360 /*               APOSIT(1,I) CONTAINS THE NUMBER OF TERMES-1 ON LINE
7361 /*               I IN THE PROFILE OF THE MATRIX */
7362 /*               APOSIT(2,I) CONTAINS THE INDEX OF STORAGE OF DIAGONAL TERM
7363 /*               OF LINE I */
7364
7365
7366 /*     OUTPUT ARGUMENTS : */
7367 /*     --------------------- */
7368 /*       POSUIV: POSUIV(K) (WHERE K IS THE INDEX OF STORAGE OF MAT(I,J)) */
7369 /*               CONTAINS THE SMALLEST NUMBER IMIN>I OF THE  LINE THAT */
7370 /*               POSSESSES A TERM MAT(IMIN,J) THAT IS IN THE PROFILE. */
7371 /*               IF THERE IS NO TERM MAT(IMIN,J) IN THE PROFILE THEN POSUIV(K)=-1 */
7372
7373
7374 /*     COMMONS USED : */
7375 /*     ------------------ */
7376
7377
7378 /*     REFERENCES CALLED : */
7379 /*     --------------------- */
7380
7381
7382 /*     DESCRIPTION/NOTES/LIMITATIONS : */
7383 /*     ----------------------------------- */
7384
7385
7386 /* ***********************************************************************
7387  */
7388 /*                            DECLARATIONS */
7389 /* ***********************************************************************
7390  */
7391
7392
7393
7394 /* ***********************************************************************
7395  */
7396 /*                      INITIALIZATIONS */
7397 /* ***********************************************************************
7398  */
7399
7400     /* Parameter adjustments */
7401     aposit -= 3;
7402     --posuiv;
7403
7404     /* Function Body */
7405     ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 2;
7406     if (ldbg) {
7407         AdvApp2Var_SysBase::mgenmsg_("MMPOSUI", 7L);
7408     }
7409     *iercod = 0;
7410
7411
7412 /* ***********************************************************************
7413  */
7414 /*                     PROCESSING */
7415 /* ***********************************************************************
7416  */
7417
7418
7419
7420     i__1 = *dimmat;
7421     for (i__ = 1; i__ <= i__1; ++i__) {
7422         jmin = i__ - aposit[(i__ << 1) + 1];
7423         i__2 = i__;
7424         for (j = jmin; j <= i__2; ++j) {
7425             imin = i__ + 1;
7426             trouve = FALSE_;
7427             while(! trouve && imin <= *dimmat) {
7428                 if (imin - aposit[(imin << 1) + 1] <= j) {
7429                     trouve = TRUE_;
7430                 } else {
7431                     ++imin;
7432                 }
7433             }
7434             k = aposit[(i__ << 1) + 2] - i__ + j;
7435             if (trouve) {
7436                 posuiv[k] = imin;
7437             } else {
7438                 posuiv[k] = -1;
7439             }
7440         }
7441     }
7442
7443
7444
7445
7446
7447     goto L9999;
7448
7449 /* ***********************************************************************
7450  */
7451 /*                   ERROR PROCESSING */
7452 /* ***********************************************************************
7453  */
7454
7455
7456
7457
7458 /* ***********************************************************************
7459  */
7460 /*                   RETURN CALLING PROGRAM */
7461 /* ***********************************************************************
7462  */
7463
7464 L9999:
7465
7466 /* ___ DESALLOCATION, ... */
7467
7468     AdvApp2Var_SysBase::maermsg_("MMPOSUI", iercod, 7L);
7469     if (ldbg) {
7470         AdvApp2Var_SysBase::mgsomsg_("MMPOSUI", 7L);
7471     }
7472  return 0 ;
7473 } /* mmposui_ */
7474
7475 //=======================================================================
7476 //function : AdvApp2Var_MathBase::mmresol_
7477 //purpose  :
7478 //=======================================================================
7479  int AdvApp2Var_MathBase::mmresol_(integer *hdimen,
7480                             integer *gdimen,
7481                             integer *hnstoc,
7482                             integer *gnstoc,
7483                             integer *mnstoc,
7484                             doublereal *matsyh,
7485                             doublereal *matsyg,
7486                             doublereal *vecsyh,
7487                             doublereal *vecsyg,
7488                             integer *hposit,
7489                             integer *hposui,
7490                             integer *gposit,
7491                             integer *mmposui,
7492                             integer *mposit,
7493                             doublereal *vecsol,
7494                             integer *iercod)
7495
7496 {
7497   integer c__100 = 100;
7498
7499    /* System generated locals */
7500     integer i__1, i__2;
7501
7502     /* Local variables */
7503     logical ldbg;
7504     doublereal* mcho = 0;
7505     integer jmin, jmax, i__, j, k, l;
7506     intptr_t iofv1, iofv2, iofv3, iofv4;
7507     doublereal *v1 = 0, *v2 = 0, *v3 = 0, *v4 = 0;
7508     integer deblig, dimhch;
7509     doublereal* hchole = 0;
7510     intptr_t iofmch, iofmam, iofhch;
7511     doublereal* matsym = 0;
7512     integer ier;
7513     integer aux;
7514
7515
7516
7517 /* ***********************************************************************
7518  */
7519
7520 /*     FUNCTION : */
7521 /*     ---------- */
7522 /*       SOLUTION OF THE SYSTEM */
7523 /*       H  t(G)   V     B */
7524 /*                    = */
7525 /*       G    0    L     C */
7526
7527 /*     KEYWORDS : */
7528 /*     ----------- */
7529 /*      RESERVE, SOLUTION, SYSTEM, LAGRANGIAN */
7530
7531 /*     INPUT ARGUMENTS : */
7532 /*     -------------------- */
7533 /*      HDIMEN: NOMBER OF LINE (OR COLUMN) OF THE HESSIAN MATRIX */
7534 /*      GDIMEN: NOMBER OF LINE OF THE MATRIX OF CONSTRAINTS */
7535 /*      HNSTOC: NOMBErS OF TERMS IN THE PROFILE OF HESSIAN MATRIX
7536 */
7537 /*      GNSTOC: NOMBERS OF TERMS IN THE PROFILE OF THE MATRIX OF CONSTRAINTS */
7538 /*      MNSTOC: NOMBERS OF TERMS IN THE PROFILE OF THE MATRIX M= G H t(G) */
7539 /*              where H IS THE HESSIAN MATRIX AND G IS THE MATRIX OF CONSTRAINTS */
7540 /*      MATSYH: TRIANGULAR INFERIOR PART OF THE HESSIAN MATRIX
7541 /*              IN FORM OF PROFILE */
7542 /*      MATSYG: MATRIX OF CONSTRAINTS IN FORM OF PROFILE */
7543 /*      VECSYH: VECTOR OF THE SECOND MEMBER ASSOCIATED TO MATSYH */
7544 /*      VECSYG: VECTOR OF THE SECOND MEMBER ASSOCIATED TO MATSYG */
7545 /*      HPOSIT: TABLE OF POSITIONING OF THE HESSIAN MATRIX */
7546 /*              HPOSIT(1,I) CONTAINS THE NUMBER OF TERMS -1 */
7547 /*              WHICH ARE IN THE PROFILE AT LINE I */
7548 /*              HPOSIT(2,I) CONTAINS THE INDEX OF STORAGE OF TERM */
7549 /*              DIAGONAL OF THE MATRIX AT LINE I */
7550 /*      HPOSUI: TABLE ALLOWING TO PARSE THE HESSIAN MATRIX BY COLUMN */
7551 /*              IN FORM OF PROFILE */
7552 /*             HPOSUI(K) CONTAINS THE NUMBER OF LINE IMIN FOLLOWING THE CURRENT LINE*/
7553 /*              I WHERE H(I,J)=MATSYH(K) AS IT EXISTS IN THE */
7554 /*              SAME COLUMN J A TERM IN THE PROFILE OF LINE IMIN */
7555 /*              IF SUCH TERM DOES NOT EXIST IMIN=-1 */
7556 /*      GPOSIT: TABLE OF POSITIONING OF THE MATRIX OF CONSTRAINTS */
7557 /*              GPOSIT(1,I) CONTAINS THE NUMBER OF TERMS OF LINE I */
7558 /*                          WHICH ARE IN THE PROFILE */
7559 /*              GPOSIT(2,I) CONTAINS THE INDEX OF STORAGE OF THE LAST TERM
7560 /*                          OF LINE I WHICH IS IN THE PROFILE */
7561 /*              GPOSIT(3,I) CONTAINS THE NUMBER OF COLUMN CORRESPONDING */
7562 /*                          TO THE FIRST TERM OF LINE I WHICH IS IN THE PROFILE */
7563 /*      MMPOSUI, MPOSIT: SAME STRUCTURE AS HPOSUI, BUT FOR MATRIX
7564 /*              M=G H t(G) */
7565
7566
7567 /*     OUTPUT ARGUMENTS : */
7568 /*     --------------------- */
7569 /*       VECSOL: VECTOR SOLUTION V OF THE SYSTEM */
7570 /*       IERCOD: ERROR CODE */
7571
7572 /*     COMMONS USED : */
7573 /*     ------------------ */
7574
7575
7576 /*     REFERENCES CALLED : */
7577 /*     --------------------- */
7578
7579
7580 /*     DESCRIPTION/NOTES/LIMITATIONS : */
7581 /*     ----------------------------------- */
7582 /* > */
7583 /* ***********************************************************************
7584  */
7585 /*                            DECLARATIONS */
7586 /* ***********************************************************************
7587  */
7588
7589 /* ***********************************************************************
7590  */
7591 /*                      INITIALISATIONS */
7592 /* ***********************************************************************
7593  */
7594
7595     /* Parameter adjustments */
7596     --vecsol;
7597     hposit -= 3;
7598     --vecsyh;
7599     --hposui;
7600     --matsyh;
7601     --matsyg;
7602     --vecsyg;
7603     gposit -= 4;
7604     --mmposui;
7605     mposit -= 3;
7606
7607     /* Function Body */
7608     ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 2;
7609     if (ldbg) {
7610         AdvApp2Var_SysBase::mgenmsg_("MMRESOL", 7L);
7611     }
7612     *iercod = 0;
7613     iofhch = 0;
7614     iofv1 = 0;
7615     iofv2 = 0;
7616     iofv3 = 0;
7617     iofv4 = 0;
7618     iofmam = 0;
7619     iofmch = 0;
7620
7621 /* ***********************************************************************
7622  */
7623 /*                     PROCESSING */
7624 /* ***********************************************************************
7625  */
7626
7627 /*    Dynamic allocation */
7628     AdvApp2Var_SysBase anAdvApp2Var_SysBase;
7629     anAdvApp2Var_SysBase.macrar8_(hdimen, &c__100, v1, &iofv1, &ier);
7630     if (ier > 0) {
7631         goto L9102;
7632     }
7633     dimhch = hposit[(*hdimen << 1) + 2];
7634     anAdvApp2Var_SysBase.macrar8_(&dimhch, &c__100, hchole, &iofhch, &ier);
7635     if (ier > 0) {
7636         goto L9102;
7637     }
7638
7639 /*   solution of system 1     H V1 = b */
7640 /*   where H=MATSYH  and b=VECSYH */
7641
7642     mmchole_(hnstoc, hdimen, &matsyh[1], &hposit[3], &hposui[1], &hchole[
7643             iofhch], &ier);
7644     if (ier > 0) {
7645         goto L9101;
7646     }
7647     mmrslss_(hnstoc, hdimen, &hchole[iofhch], &hposit[3], &hposui[1], &vecsyh[
7648             1], &v1[iofv1], &ier);
7649     if (ier > 0) {
7650         goto L9102;
7651     }
7652
7653 /*    Case when there are constraints */
7654
7655     if (*gdimen > 0) {
7656
7657 /*    Calculate the vector of the second member V2=G H(-1) b -c = G v1-c */
7658 /*    of system of unknown Lagrangian vector MULTIP */
7659 /*    where G=MATSYG */
7660 /*          c=VECSYG */
7661
7662         anAdvApp2Var_SysBase.macrar8_(gdimen, &c__100, v2, &iofv2, &ier);
7663         if (ier > 0) {
7664             goto L9102;
7665         }
7666         anAdvApp2Var_SysBase.macrar8_(hdimen, &c__100, v3, &iofv3, &ier);
7667         if (ier > 0) {
7668             goto L9102;
7669         }
7670         anAdvApp2Var_SysBase.macrar8_(gdimen, &c__100, v4, &iofv4, &ier);
7671         if (ier > 0) {
7672             goto L9102;
7673         }
7674         anAdvApp2Var_SysBase.macrar8_(mnstoc, &c__100, matsym, &iofmam, &ier);
7675         if (ier > 0) {
7676             goto L9102;
7677         }
7678
7679         deblig = 1;
7680         mmatvec_(gdimen, hdimen, &gposit[4], gnstoc, &matsyg[1], &v1[iofv1], &
7681                 deblig, &v2[iofv2], &ier);
7682         if (ier > 0) {
7683             goto L9101;
7684         }
7685         i__1 = *gdimen;
7686         for (i__ = 1; i__ <= i__1; ++i__) {
7687             v2[i__ + iofv2 - 1] -= vecsyg[i__];
7688         }
7689
7690 /*     Calculate the matrix M= G H(-1) t(G) */
7691 /*     RESOL DU SYST 2 : H qi = gi */
7692 /*            where is a vector column of t(G) */
7693 /*                qi=v3 */
7694 /*            then calculate G qi */
7695 /*            then construct M in form of profile */
7696
7697
7698
7699         i__1 = *gdimen;
7700         for (i__ = 1; i__ <= i__1; ++i__) {
7701             AdvApp2Var_SysBase::mvriraz_(hdimen, &v1[iofv1]);
7702             AdvApp2Var_SysBase::mvriraz_(hdimen, &v3[iofv3]);
7703             AdvApp2Var_SysBase::mvriraz_(gdimen, &v4[iofv4]);
7704             jmin = gposit[i__ * 3 + 3];
7705             jmax = gposit[i__ * 3 + 1] + gposit[i__ * 3 + 3] - 1;
7706             aux = gposit[i__ * 3 + 2] - gposit[i__ * 3 + 1] - jmin + 1;
7707             i__2 = jmax;
7708             for (j = jmin; j <= i__2; ++j) {
7709                 k = j + aux;
7710                 v1[j + iofv1 - 1] = matsyg[k];
7711             }
7712             mmrslss_(hnstoc, hdimen, &hchole[iofhch], &hposit[3], &hposui[1],
7713                     &v1[iofv1], &v3[iofv3], &ier);
7714             if (ier > 0) {
7715                 goto L9101;
7716             }
7717
7718             deblig = i__;
7719             mmatvec_(gdimen, hdimen, &gposit[4], gnstoc, &matsyg[1], &v3[
7720                     iofv3], &deblig, &v4[iofv4], &ier);
7721             if (ier > 0) {
7722                 goto L9101;
7723             }
7724
7725             k = mposit[(i__ << 1) + 2];
7726             matsym[k + iofmam - 1] = v4[i__ + iofv4 - 1];
7727             while(mmposui[k] > 0) {
7728                 l = mmposui[k];
7729                 k = mposit[(l << 1) + 2] - l + i__;
7730                 matsym[k + iofmam - 1] = v4[l + iofv4 - 1];
7731             }
7732         }
7733
7734
7735 /*    SOLVE SYST 3  M L = V2 */
7736 /*     WITH L=V4 */
7737
7738
7739         AdvApp2Var_SysBase::mvriraz_(gdimen, &v4[iofv4]);
7740         anAdvApp2Var_SysBase.macrar8_(mnstoc, &c__100, mcho, &iofmch, &ier);
7741         if (ier > 0) {
7742             goto L9102;
7743         }
7744         mmchole_(mnstoc, gdimen, &matsym[iofmam], &mposit[3], &mmposui[1], &
7745                 mcho[iofmch], &ier);
7746         if (ier > 0) {
7747             goto L9101;
7748         }
7749         mmrslss_(mnstoc, gdimen, &mcho[iofmch], &mposit[3], &mmposui[1], &v2[
7750                 iofv2], &v4[iofv4], &ier);
7751         if (ier > 0) {
7752             goto L9102;
7753         }
7754
7755
7756 /*    CALCULATE THE VECTOR OF THE SECOND MEMBER OF THE SYSTEM  Hx = b - t(G) L
7757 */
7758 /*                                                      = V1 */
7759
7760         AdvApp2Var_SysBase::mvriraz_(hdimen, &v1[iofv1]);
7761         mmtmave_(gdimen, hdimen, &gposit[4], gnstoc, &matsyg[1], &v4[iofv4], &
7762                 v1[iofv1], &ier);
7763         if (ier > 0) {
7764             goto L9101;
7765         }
7766         i__1 = *hdimen;
7767         for (i__ = 1; i__ <= i__1; ++i__) {
7768             v1[i__ + iofv1 - 1] = vecsyh[i__] - v1[i__ + iofv1 - 1];
7769         }
7770
7771 /*    RESOL SYST 4   Hx = b - t(G) L */
7772
7773
7774         mmrslss_(hnstoc, hdimen, &hchole[iofhch], &hposit[3], &hposui[1], &v1[
7775                 iofv1], &vecsol[1], &ier);
7776         if (ier > 0) {
7777             goto L9102;
7778         }
7779     } else {
7780         i__1 = *hdimen;
7781         for (i__ = 1; i__ <= i__1; ++i__) {
7782             vecsol[i__] = v1[i__ + iofv1 - 1];
7783         }
7784     }
7785
7786     goto L9999;
7787
7788 /* ***********************************************************************
7789  */
7790 /*                   PROCESSING OF ERRORS */
7791 /* ***********************************************************************
7792  */
7793
7794
7795 L9101:
7796     *iercod = 1;
7797     goto L9999;
7798
7799 L9102:
7800     AdvApp2Var_SysBase::mswrdbg_("MMRESOL : PROBLEM WITH DIMMAT", 30L);
7801     *iercod = 2;
7802
7803 /* ***********************************************************************
7804  */
7805 /*                   RETURN CALLING PROGRAM */
7806 /* ***********************************************************************
7807  */
7808
7809 L9999:
7810
7811 /* ___ DESALLOCATION, ... */
7812     anAdvApp2Var_SysBase.macrdr8_(hdimen, &c__100, v1, &iofv1, &ier);
7813     if (*iercod == 0 && ier > 0) {
7814         *iercod = 3;
7815     }
7816     anAdvApp2Var_SysBase.macrdr8_(&dimhch, &c__100, hchole, &iofhch, &ier);
7817     if (*iercod == 0 && ier > 0) {
7818         *iercod = 3;
7819     }
7820     anAdvApp2Var_SysBase.macrdr8_(gdimen, &c__100, v2, &iofv2, &ier);
7821     if (*iercod == 0 && ier > 0) {
7822         *iercod = 3;
7823     }
7824     anAdvApp2Var_SysBase.macrdr8_(hdimen, &c__100, v3, &iofv3, &ier);
7825     if (*iercod == 0 && ier > 0) {
7826         *iercod = 3;
7827     }
7828     anAdvApp2Var_SysBase.macrdr8_(gdimen, &c__100, v4, &iofv4, &ier);
7829     if (*iercod == 0 && ier > 0) {
7830         *iercod = 3;
7831     }
7832     anAdvApp2Var_SysBase.macrdr8_(mnstoc, &c__100, matsym, &iofmam, &ier);
7833     if (*iercod == 0 && ier > 0) {
7834         *iercod = 3;
7835     }
7836     anAdvApp2Var_SysBase.macrdr8_(mnstoc, &c__100, mcho, &iofmch, &ier);
7837     if (*iercod == 0 && ier > 0) {
7838         *iercod = 3;
7839     }
7840
7841     AdvApp2Var_SysBase::maermsg_("MMRESOL", iercod, 7L);
7842     if (ldbg) {
7843         AdvApp2Var_SysBase::mgsomsg_("MMRESOL", 7L);
7844     }
7845  return 0 ;
7846 } /* mmresol_ */
7847
7848 //=======================================================================
7849 //function : mmrslss_
7850 //purpose  :
7851 //=======================================================================
7852 int mmrslss_(integer *,//mxcoef,
7853              integer *dimens,
7854              doublereal *smatri,
7855              integer *sposit,
7856              integer *posuiv,
7857              doublereal *mscnmbr,
7858              doublereal *soluti,
7859              integer *iercod)
7860 {
7861   /* System generated locals */
7862   integer i__1, i__2;
7863
7864   /* Local variables */
7865   logical ldbg;
7866   integer i__, j;
7867   doublereal somme;
7868   integer pointe, ptcour;
7869
7870 /* ***********************************************************************
7871  */
7872
7873 /*     FuNCTION : */
7874 /*     ----------                     T */
7875 /*       Solves linear system SS x = b where S is a  */
7876 /*       triangular lower matrix given in form of profile */
7877
7878 /*     KEYWORDS : */
7879 /*     ----------- */
7880 /*     RESERVE, MATRICE_PROFILE, RESOLUTION, CHOLESKI */
7881
7882 /*     INPUT ARGUMENTS : */
7883 /*     -------------------- */
7884 /*     MXCOEF  : Maximum number of non-null coefficient in the matrix */
7885 /*     DIMENS  : Dimension of the matrix */
7886 /*     SMATRI(MXCOEF) : Values of coefficients of the matrix */
7887 /*     SPOSIT(2,DIMENS): */
7888 /*       SPOSIT(1,*) : Distance diagonal-extremity of the line */
7889 /*       SPOSIT(2,*) : Position of diagonal terms in AMATRI */
7890 /*     POSUIV(MXCOEF): first line inferior not out of profile */
7891 /*     MSCNMBR(DIMENS): Vector second member of the equation */
7892
7893 /*     OUTPUT ARGUMENTS : */
7894 /*     --------------------- */
7895 /*     SOLUTI(NDIMEN) : Result vector */
7896 /*     IERCOD   : Error code 0  : ok */
7897
7898 /*     COMMONS USED : */
7899 /*     ------------------ */
7900
7901
7902 /*     REFERENCES CALLED : */
7903 /*     --------------------- */
7904
7905
7906 /*     DESCRIPTION/NOTES/LIMITATIONS : */
7907 /*     ----------------------------------- */
7908 /*       T */
7909 /*     SS  is the decomposition of choleski of a symmetric matrix */
7910 /*     defined postive, that can result from routine MMCHOLE. */
7911
7912 /*     For a full matrix it is possible to use MRSLMSC */
7913
7914 /*     LEVEL OF DEBUG = 4 */
7915 /* > */
7916 /* ***********************************************************************
7917  */
7918 /*                            DECLARATIONS */
7919 /* ***********************************************************************
7920  */
7921
7922
7923
7924 /* ***********************************************************************
7925  */
7926 /*                      INITIALISATIONS */
7927 /* ***********************************************************************
7928  */
7929
7930     /* Parameter adjustments */
7931     --posuiv;
7932     --smatri;
7933     --soluti;
7934     --mscnmbr;
7935     sposit -= 3;
7936
7937     /* Function Body */
7938     ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 4;
7939     if (ldbg) {
7940         AdvApp2Var_SysBase::mgenmsg_("MMRSLSS", 7L);
7941     }
7942     *iercod = 0;
7943
7944 /* ***********************************************************************
7945  */
7946 /*                     PROCESSING */
7947 /* ***********************************************************************
7948  */
7949
7950 /* ----- Solution of Sw = b */
7951
7952     i__1 = *dimens;
7953     for (i__ = 1; i__ <= i__1; ++i__) {
7954
7955         pointe = sposit[(i__ << 1) + 2];
7956         somme = 0.;
7957         i__2 = i__ - 1;
7958         for (j = i__ - sposit[(i__ << 1) + 1]; j <= i__2; ++j) {
7959             somme += smatri[pointe - (i__ - j)] * soluti[j];
7960         }
7961
7962         soluti[i__] = (mscnmbr[i__] - somme) / smatri[pointe];
7963     }
7964 /*                     T */
7965 /* ----- Solution of S u = w */
7966
7967     for (i__ = *dimens; i__ >= 1; --i__) {
7968
7969         pointe = sposit[(i__ << 1) + 2];
7970         j = posuiv[pointe];
7971         somme = 0.;
7972         while(j > 0) {
7973             ptcour = sposit[(j << 1) + 2] - (j - i__);
7974             somme += smatri[ptcour] * soluti[j];
7975             j = posuiv[ptcour];
7976         }
7977
7978         soluti[i__] = (soluti[i__] - somme) / smatri[pointe];
7979     }
7980
7981     goto L9999;
7982
7983 /* ***********************************************************************
7984  */
7985 /*                   ERROR PROCESSING */
7986 /* ***********************************************************************
7987  */
7988
7989
7990 /* ***********************************************************************
7991  */
7992 /*                   RETURN PROGRAM CALLING */
7993 /* ***********************************************************************
7994  */
7995
7996 L9999:
7997
7998     AdvApp2Var_SysBase::maermsg_("MMRSLSS", iercod, 7L);
7999     if (ldbg) {
8000         AdvApp2Var_SysBase::mgsomsg_("MMRSLSS", 7L);
8001     }
8002  return 0 ;
8003 } /* mmrslss_ */
8004
8005 //=======================================================================
8006 //function : mmrslw_
8007 //purpose  :
8008 //=======================================================================
8009 int mmrslw_(integer *normax,
8010             integer *nordre,
8011             integer *ndimen,
8012             doublereal *epspiv,
8013             doublereal *abmatr,
8014             doublereal *xmatri,
8015             integer *iercod)
8016 {
8017   /* System generated locals */
8018     integer abmatr_dim1, abmatr_offset, xmatri_dim1, xmatri_offset, i__1,
8019             i__2, i__3;
8020     doublereal d__1;
8021
8022     /* Local variables */
8023     integer kpiv;
8024     doublereal pivot;
8025     integer ii, jj, kk;
8026     doublereal akj;
8027
8028
8029 /* **********************************************************************
8030 */
8031
8032 /*     FUNCTION : */
8033 /*     ---------- */
8034 /*  Solution of a linear system A.x = B of N equations to N */
8035 /*  unknown by Gauss method (partial pivot) or : */
8036 /*          A is matrix NORDRE * NORDRE, */
8037 /*          B is matrix NORDRE (lines) * NDIMEN (columns), */
8038 /*          x is matrix NORDRE (lines) * NDIMEN (columns). */
8039 /*  In this program, A and B are stored in matrix ABMATR  */
8040 /*  the lines and columns which of were inverted. ABMATR(k,j) is */
8041 /*  term A(j,k) if k <= NORDRE, B(j,k-NORDRE) otherwise (see example). */
8042
8043 /*     KEYWORDS : */
8044 /*     ----------- */
8045 /* TOUS, MATH_ACCES::EQUATION&, MATRICE&, RESOLUTION, GAUSS, &SOLUTION */
8046
8047 /*     INPUT ARGUMENTS : */
8048 /*     ------------------ */
8049 /*   NORMAX : Max size of the first index of XMATRI. This argument */
8050 /*            serves only for the declaration of dimension of XMATRI and should be */
8051 /*            above or equal to NORDRE. */
8052 /*   NORDRE : Order of the matrix i.e. number of equations and  */
8053 /*            unknown quantities of the linear system to be solved. */
8054 /*   NDIMEN : Number of the second member. */
8055 /*   EPSPIV : Minimal value of a pivot. If during the calculation  */
8056 /*            the absolute value of the pivot is below EPSPIV, the */
8057 /*            system of equations is declared singular. EPSPIV should */
8058 /*            be a "small" real. */
8059
8060 /*   ABMATR(NORDRE+NDIMEN,NORDRE) : Auxiliary matrix containing  */
8061 /*                                  matrix A and matrix B. */
8062
8063 /*     OUTPUT ARGUMENTS : */
8064 /*     ------------------- */
8065 /*   XMATRI : Matrix containing  NORDRE*NDIMEN solutions. */
8066 /*   IERCOD=0 shows that all solutions are calculated. */
8067 /*   IERCOD=1 shows that the matrix is of lower rank than NORDRE */
8068 /*            (the system is singular). */
8069
8070 /*     COMMONS USED   : */
8071 /*     ---------------- */
8072
8073 /*     REFERENCES CALLED   : */
8074 /*     ----------------------- */
8075
8076 /*     DESCRIPTION/NOTES/LIMITATIONS : */
8077 /*     ----------------------------------- */
8078 /*     ATTENTION : the indices of line and column are inverted */
8079 /*                 compared to usual indices. */
8080 /*                 System : */
8081 /*                        a1*x + b1*y = c1 */
8082 /*                        a2*x + b2*y = c2 */
8083 /*                 should be represented by matrix ABMATR : */
8084
8085 /*                 ABMATR(1,1) = a1  ABMATR(1,2) = a2 */
8086 /*                 ABMATR(2,1) = b1  ABMATR(2,2) = b2 */
8087 /*                 ABMATR(3,1) = c1  ABMATR(3,2) = c2 */
8088
8089 /*     To solve this system, it is necessary to set : */
8090
8091 /*                 NORDRE = 2 (there are 2 equations with 2 unknown values), */
8092 /*                 NDIMEN = 1 (there is only one second member), */
8093 /*                 any NORMAX can be taken >= NORDRE. */
8094
8095 /*     To use this routine, it is recommended to use one of */
8096 /*     interfaces : MMRSLWI or MMMRSLWD. */
8097 /* > */
8098 /* **********************************************************************
8099 */
8100
8101 /*   Name of the routine */
8102
8103 /*      INTEGER IBB,MNFNDEB */
8104
8105 /*      IBB=MNFNDEB() */
8106 /*      IF (IBB.GE.2) CALL MGENMSG(NOMPR) */
8107     /* Parameter adjustments */
8108     xmatri_dim1 = *normax;
8109     xmatri_offset = xmatri_dim1 + 1;
8110     xmatri -= xmatri_offset;
8111     abmatr_dim1 = *nordre + *ndimen;
8112     abmatr_offset = abmatr_dim1 + 1;
8113     abmatr -= abmatr_offset;
8114
8115     /* Function Body */
8116     *iercod = 0;
8117
8118 /* *********************************************************************
8119 */
8120 /*                  Triangulation of matrix ABMATR. */
8121 /* *********************************************************************
8122 */
8123
8124     i__1 = *nordre;
8125     for (kk = 1; kk <= i__1; ++kk) {
8126
8127 /* ---------- Find max pivot in column KK. ------------
8128 --- */
8129
8130         pivot = *epspiv;
8131         kpiv = 0;
8132         i__2 = *nordre;
8133         for (jj = kk; jj <= i__2; ++jj) {
8134             akj = (d__1 = abmatr[kk + jj * abmatr_dim1], advapp_abs(d__1));
8135             if (akj > pivot) {
8136                 pivot = akj;
8137                 kpiv = jj;
8138             }
8139 /* L100: */
8140         }
8141         if (kpiv == 0) {
8142             goto L9900;
8143         }
8144
8145 /* --------- Swapping of line KPIV with line KK. ------
8146 --- */
8147
8148         if (kpiv != kk) {
8149             i__2 = *nordre + *ndimen;
8150             for (jj = kk; jj <= i__2; ++jj) {
8151                 akj = abmatr[jj + kk * abmatr_dim1];
8152                 abmatr[jj + kk * abmatr_dim1] = abmatr[jj + kpiv *
8153                         abmatr_dim1];
8154                 abmatr[jj + kpiv * abmatr_dim1] = akj;
8155 /* L200: */
8156             }
8157         }
8158
8159 /* ---------- Removal and triangularization. -----------
8160 --- */
8161
8162         pivot = -abmatr[kk + kk * abmatr_dim1];
8163         i__2 = *nordre;
8164         for (ii = kk + 1; ii <= i__2; ++ii) {
8165             akj = abmatr[kk + ii * abmatr_dim1] / pivot;
8166             i__3 = *nordre + *ndimen;
8167             for (jj = kk + 1; jj <= i__3; ++jj) {
8168                 abmatr[jj + ii * abmatr_dim1] += akj * abmatr[jj + kk *
8169                         abmatr_dim1];
8170 /* L400: */
8171             }
8172 /* L300: */
8173         }
8174
8175
8176 /* L1000: */
8177     }
8178
8179 /* *********************************************************************
8180 */
8181 /*          Solution of the system of triangular equations. */
8182 /*   Matrix ABMATR(NORDRE+JJ,II), contains second members  */
8183 /*             of the system for 1<=j<=NDIMEN and 1<=i<=NORDRE. */
8184 /* *********************************************************************
8185 */
8186
8187
8188 /* ---------------- Calculation of solutions by ascending. -----------------
8189 */
8190
8191     for (kk = *nordre; kk >= 1; --kk) {
8192         pivot = abmatr[kk + kk * abmatr_dim1];
8193         i__1 = *ndimen;
8194         for (ii = 1; ii <= i__1; ++ii) {
8195             akj = abmatr[ii + *nordre + kk * abmatr_dim1];
8196             i__2 = *nordre;
8197             for (jj = kk + 1; jj <= i__2; ++jj) {
8198                 akj -= abmatr[jj + kk * abmatr_dim1] * xmatri[jj + ii *
8199                         xmatri_dim1];
8200 /* L800: */
8201             }
8202             xmatri[kk + ii * xmatri_dim1] = akj / pivot;
8203 /* L700: */
8204         }
8205 /* L600: */
8206     }
8207     goto L9999;
8208
8209 /* ------If the absolute value of a pivot is smaller than --------
8210 /* ---------- EPSPIV: return the code of error. ------------
8211 */
8212
8213 L9900:
8214     *iercod = 1;
8215
8216
8217
8218 L9999:
8219     if (*iercod > 0) {
8220         AdvApp2Var_SysBase::maermsg_("MMRSLW ", iercod, 7L);
8221     }
8222 /*      IF (IBB.GE.2) CALL MGSOMSG(NOMPR) */
8223  return 0 ;
8224 } /* mmrslw_ */
8225
8226 //=======================================================================
8227 //function : AdvApp2Var_MathBase::mmmrslwd_
8228 //purpose  :
8229 //=======================================================================
8230  int AdvApp2Var_MathBase::mmmrslwd_(integer *normax,
8231                              integer *nordre,
8232                              integer *ndim,
8233                              doublereal *amat,
8234                              doublereal *bmat,
8235                              doublereal *epspiv,
8236                              doublereal *aaux,
8237                              doublereal *xmat,
8238                              integer *iercod)
8239
8240 {
8241   /* System generated locals */
8242   integer amat_dim1, amat_offset, bmat_dim1, bmat_offset, xmat_dim1,
8243   xmat_offset, aaux_dim1, aaux_offset, i__1, i__2;
8244
8245   /* Local variables */
8246   integer i__, j;
8247   integer ibb;
8248
8249 /*      IMPLICIT DOUBLE PRECISION (A-H,O-Z) */
8250 /*      IMPLICIT INTEGER (I-N) */
8251
8252
8253 /* **********************************************************************
8254 */
8255
8256 /*     FUNCTION : */
8257 /*     ---------- */
8258 /*        Solution of a linear system by Gauss method where */
8259 /*        the second member is a table of vectors. Method of partial pivot. */
8260
8261 /*     KEYWORDS : */
8262 /*     ----------- */
8263 /*        ALL, MATH_ACCES :: */
8264 /*        SYSTEME&,EQUATION&, RESOLUTION,GAUSS ,&VECTEUR */
8265
8266 /*     INPUT ARGUMENTS : */
8267 /*     ------------------ */
8268 /*        NORMAX : Max. Dimension of AMAT. */
8269 /*        NORDRE :  Order of the matrix. */
8270 /*        NDIM : Number of columns of BMAT and XMAT. */
8271 /*        AMAT(NORMAX,NORDRE) : The processed matrix. */
8272 /*        BMAT(NORMAX,NDIM)   : The matrix of second member. */
8273 /*        XMAT(NORMAX,NDIM)   : The matrix of solutions. */
8274 /*        EPSPIV : Min value of a pivot. */
8275
8276 /*     OUTPUT ARGUMENTS : */
8277 /*     ------------------- */
8278 /*        AAUX(NORDRE+NDIM,NORDRE) : Auxiliary matrix. */
8279 /*        XMAT(NORMAX,NDIM) : Matrix of solutions. */
8280 /*        IERCOD=0 shows that solutions in XMAT are valid. */
8281 /*        IERCOD=1 shows that matrix AMAT is of lower rank than NORDRE. */
8282
8283 /*     COMMONS USED   : */
8284 /*     ---------------- */
8285
8286 /*      .Neant. */
8287
8288 /*     REFERENCES CALLED : */
8289 /*     ---------------------- */
8290 /*     Type  Name */
8291 /*           MAERMSG              MGENMSG              MGSOMSG */
8292 /*           MMRSLW          I*4  MNFNDEB */
8293
8294 /*     DESCRIPTION/NOTES/LIMITATIONS : */
8295 /*     ----------------------------------- */
8296 /*    ATTENTION : lines and columns are located in usual order : */
8297 /*               1st index  = index line */
8298 /*               2nd index = index column */
8299 /*    Example, the system : */
8300 /*                 a1*x + b1*y = c1 */
8301 /*                 a2*x + b2*y = c2 */
8302 /*    is represented by matrix AMAT : */
8303
8304 /*                 AMAT(1,1) = a1  AMAT(2,1) = a2 */
8305 /*                 AMAT(1,2) = b1  AMAT(2,2) = b2 */
8306
8307 /*     The first index is the index of line, the second index */
8308 /*     is the index of columns (Compare with MMRSLWI which is faster). */
8309
8310 /* > */
8311 /* **********************************************************************
8312 */
8313
8314 /*   Name of the routine */
8315
8316     /* Parameter adjustments */
8317     amat_dim1 = *normax;
8318     amat_offset = amat_dim1 + 1;
8319     amat -= amat_offset;
8320     xmat_dim1 = *normax;
8321     xmat_offset = xmat_dim1 + 1;
8322     xmat -= xmat_offset;
8323     aaux_dim1 = *nordre + *ndim;
8324     aaux_offset = aaux_dim1 + 1;
8325     aaux -= aaux_offset;
8326     bmat_dim1 = *normax;
8327     bmat_offset = bmat_dim1 + 1;
8328     bmat -= bmat_offset;
8329
8330     /* Function Body */
8331     ibb = AdvApp2Var_SysBase::mnfndeb_();
8332     if (ibb >= 3) {
8333         AdvApp2Var_SysBase::mgenmsg_("MMMRSLW", 7L);
8334     }
8335
8336 /*   Initialization of the auxiliary matrix. */
8337
8338     i__1 = *nordre;
8339     for (i__ = 1; i__ <= i__1; ++i__) {
8340         i__2 = *nordre;
8341         for (j = 1; j <= i__2; ++j) {
8342             aaux[j + i__ * aaux_dim1] = amat[i__ + j * amat_dim1];
8343 /* L200: */
8344         }
8345 /* L100: */
8346     }
8347
8348 /*    Second member. */
8349
8350     i__1 = *nordre;
8351     for (i__ = 1; i__ <= i__1; ++i__) {
8352         i__2 = *ndim;
8353         for (j = 1; j <= i__2; ++j) {
8354             aaux[j + *nordre + i__ * aaux_dim1] = bmat[i__ + j * bmat_dim1];
8355 /* L400: */
8356         }
8357 /* L300: */
8358     }
8359
8360 /*    Solution of the system of equations. */
8361
8362     mmrslw_(normax, nordre, ndim, epspiv, &aaux[aaux_offset], &xmat[
8363             xmat_offset], iercod);
8364
8365
8366     if (*iercod != 0) {
8367         AdvApp2Var_SysBase::maermsg_("MMMRSLW", iercod, 7L);
8368     }
8369     if (ibb >= 3) {
8370         AdvApp2Var_SysBase::mgsomsg_("MMMRSLW", 7L);
8371     }
8372  return 0 ;
8373 } /* mmmrslwd_ */
8374
8375 //=======================================================================
8376 //function : AdvApp2Var_MathBase::mmrtptt_
8377 //purpose  :
8378 //=======================================================================
8379  int AdvApp2Var_MathBase::mmrtptt_(integer *ndglgd,
8380                             doublereal *rtlegd)
8381
8382 {
8383   integer ideb, nmod2, nsur2, ilong, ibb;
8384
8385
8386 /* **********************************************************************
8387 */
8388
8389 /*     FUNCTION : */
8390 /*     ---------- */
8391 /*     Extracts from Common LDGRTL the STRICTLY positive roots of the */
8392 /*     Legendre polynom of degree NDGLGD, for 2 <= NDGLGD <= 61. */
8393
8394 /*     KEYWORDS : */
8395 /*     ----------- */
8396 /*     TOUS, AB_SPECIFI::COMMON&, EXTRACTION, &RACINE, &LEGENDRE. */
8397
8398 /*     INPUT ARGUMENTS : */
8399 /*     ------------------ */
8400 /*        NDGLGD : Mathematic degree of Legendre polynom. */
8401 /*                 This degree should be above or equal to 2 and */
8402 /*                 below or equal to 61. */
8403
8404 /*     OUTPUT ARGUMENTS : */
8405 /*     ------------------- */
8406 /*        RTLEGD : The table of strictly positive roots of */
8407 /*                 Legendre polynom of degree NDGLGD. */
8408
8409 /*     COMMONS USED   : */
8410 /*     ---------------- */
8411
8412 /*     REFERENCES CALLED   : */
8413 /*     ----------------------- */
8414
8415 /*     DESCRIPTION/NOTES/LIMITATIONS : */
8416 /*     ----------------------------------- */
8417 /*     ATTENTION: the condition on NDEGRE ( 2 <= NDEGRE <= 61) is not */
8418 /*     tested. The caller should make the test. */
8419
8420 /* > */
8421 /* **********************************************************************
8422 */
8423 /*   Nome of the routine */
8424
8425
8426 /*   Common MLGDRTL: */
8427 /*   This common includes POSITIVE roots of Legendre polynoms */
8428 /*   AND the weight of Gauss quadrature formulas on all */
8429 /*   POSITIVE roots of Legendre polynoms. */
8430
8431
8432 /* ***********************************************************************
8433  */
8434
8435 /*     FUNCTION : */
8436 /*     ---------- */
8437 /*   The common of Legendre roots. */
8438
8439 /*     KEYWORDS : */
8440 /*     ----------- */
8441 /*        BASE LEGENDRE */
8442
8443 /*     DEMSCRIPTION/NOTES/LIMITATIONS : */
8444 /*     ----------------------------------- */
8445
8446 /* > */
8447 /* ***********************************************************************
8448  */
8449
8450
8451
8452
8453 /*   ROOTAB : Table of all rotts of Legendre polynoms */
8454 /*   between [0,1]. They are ranked for degrees increasing from 2 to 61. */
8455 /*   HILTAB : Table of Legendre interpolators concerning ROOTAB. */
8456 /*   The address is the same. */
8457 /*   HI0TAB : Table of Legendre interpolators for root x=0 */
8458 /*   the polynoms of UNEVEN degree. */
8459 /*   RTLTB0 : Table of Li(uk) where uk are roots of a */
8460 /*   Legendre polynom of EVEN degree. */
8461 /*   RTLTB1 : Table of Li(uk) where uk are roots of a */
8462 /*   Legendre polynom of UNEVEN degree. */
8463
8464
8465 /************************************************************************
8466 *****/
8467     /* Parameter adjustments */
8468     --rtlegd;
8469
8470     /* Function Body */
8471     ibb = AdvApp2Var_SysBase::mnfndeb_();
8472     if (ibb >= 3) {
8473         AdvApp2Var_SysBase::mgenmsg_("MMRTPTT", 7L);
8474     }
8475     if (*ndglgd < 2) {
8476         goto L9999;
8477     }
8478
8479     nsur2 = *ndglgd / 2;
8480     nmod2 = *ndglgd % 2;
8481
8482     ilong = nsur2 << 3;
8483     ideb = nsur2 * (nsur2 - 1) / 2 + 1;
8484     AdvApp2Var_SysBase::mcrfill_(&ilong,
8485              &mlgdrtl_.rootab[ideb + nmod2 * 465 - 1],
8486              &rtlegd[1]);
8487
8488 /* ----------------------------- The end --------------------------------
8489 */
8490
8491 L9999:
8492     if (ibb >= 3) {
8493         AdvApp2Var_SysBase::mgsomsg_("MMRTPTT", 7L);
8494     }
8495     return 0;
8496 } /* mmrtptt_ */
8497
8498 //=======================================================================
8499 //function : AdvApp2Var_MathBase::mmsrre2_
8500 //purpose  :
8501 //=======================================================================
8502  int AdvApp2Var_MathBase::mmsrre2_(doublereal *tparam,
8503                             integer *nbrval,
8504                             doublereal *tablev,
8505                             doublereal *epsil,
8506                             integer *numint,
8507                             integer *itypen,
8508                             integer *iercod)
8509 {
8510   /* System generated locals */
8511   doublereal d__1;
8512
8513   /* Local variables */
8514   integer ideb, ifin, imil, ibb;
8515
8516 /* ***********************************************************************
8517  */
8518
8519 /*     FUNCTION : */
8520 /*     -------- */
8521
8522 /*     Find the interval corresponding to a valueb given in  */
8523 /*     increasing order of real numbers with double precision. */
8524
8525 /*     KEYWORDS : */
8526 /*     --------- */
8527 /*     TOUS,MATH_ACCES::TABLEAU&,POINT&,CORRESPONDANCE,&RANG */
8528
8529 /*     INPUT ARGUMENTS : */
8530 /*     ------------------ */
8531
8532 /*     TPARAM  : Value to be tested. */
8533 /*     NBRVAL  : Size of TABLEV */
8534 /*     TABLEV  : Table of reals. */
8535 /*     EPSIL   : Epsilon of precision */
8536
8537 /*     OUTPUT ARGUMENTS : */
8538 /*     ------------------- */
8539
8540 /*     NUMINT  : Number of the interval (between 1 and NBRVAL-1). */
8541 /*     ITYPEN  : = 0 TPARAM is inside the interval NUMINT */
8542 /*               = 1 : TPARAM corresponds to the lower limit of */
8543 /*               the provided interval. */
8544 /*               = 2 : TPARAM corresponds to the upper limit of */
8545 /*               the provided interval. */
8546
8547 /*     IERCOD : Error code. */
8548 /*                     = 0 : OK */
8549 /*                     = 1 : TABLEV does not contain enough elements. */
8550 /*                     = 2 : TPARAM out of limits of TABLEV. */
8551
8552 /*     COMMONS USED : */
8553 /*     ---------------- */
8554
8555 /*     REFERENCES CALLED : */
8556 /*     ------------------- */
8557
8558 /*     DESCRIPTION/NOTES/LIMITATIONS : */
8559 /*     --------------------------------- */
8560 /*     There are NBRVAL values in TABLEV which stands for NBRVAL-1 intervals. */
8561 /*     One searches the interval containing TPARAM by */
8562 /*     dichotomy. Complexity of the algorithm : Log(n)/Log(2).(RBD). */
8563 /* > */
8564 /* ***********************************************************************
8565  */
8566
8567
8568 /* Initialisations */
8569
8570     /* Parameter adjustments */
8571     --tablev;
8572
8573     /* Function Body */
8574     ibb = AdvApp2Var_SysBase::mnfndeb_();
8575     if (ibb >= 6) {
8576         AdvApp2Var_SysBase::mgenmsg_("MMSRRE2", 7L);
8577     }
8578
8579     *iercod = 0;
8580     *numint = 0;
8581     *itypen = 0;
8582     ideb = 1;
8583     ifin = *nbrval;
8584
8585 /* TABLEV should contain at least two values */
8586
8587     if (*nbrval < 2) {
8588         *iercod = 1;
8589         goto L9999;
8590     }
8591
8592 /* TPARAM should be between extreme limits of TABLEV. */
8593
8594     if (*tparam < tablev[1] || *tparam > tablev[*nbrval]) {
8595         *iercod = 2;
8596         goto L9999;
8597     }
8598
8599 /* ----------------------- SEARCH OF THE INTERVAL --------------------
8600 */
8601
8602 L1000:
8603
8604 /* Test end of loop (found). */
8605
8606     if (ideb + 1 == ifin) {
8607         *numint = ideb;
8608         goto L2000;
8609     }
8610
8611 /* Find by dichotomy on increasing values of TABLEV. */
8612
8613     imil = (ideb + ifin) / 2;
8614     if (*tparam >= tablev[ideb] && *tparam <= tablev[imil]) {
8615         ifin = imil;
8616     } else {
8617         ideb = imil;
8618     }
8619
8620     goto L1000;
8621
8622 /* -------------- TEST IF TPARAM IS NOT A VALUE ---------
8623 /* ------------------------OF TABLEV UP TO EPSIL ----------------------
8624 */
8625
8626 L2000:
8627     if ((d__1 = *tparam - tablev[ideb], advapp_abs(d__1)) < *epsil) {
8628         *itypen = 1;
8629         goto L9999;
8630     }
8631     if ((d__1 = *tparam - tablev[ifin], advapp_abs(d__1)) < *epsil) {
8632         *itypen = 2;
8633         goto L9999;
8634     }
8635
8636 /* --------------------------- THE END ----------------------------------
8637 */
8638
8639 L9999:
8640     if (*iercod > 0) {
8641         AdvApp2Var_SysBase::maermsg_("MMSRRE2", iercod, 7L);
8642     }
8643     if (ibb >= 6) {
8644         AdvApp2Var_SysBase::mgsomsg_("MMSRRE2", 7L);
8645     }
8646  return 0 ;
8647 } /* mmsrre2_ */
8648
8649 //=======================================================================
8650 //function : mmtmave_
8651 //purpose  :
8652 //=======================================================================
8653 int mmtmave_(integer *nligne,
8654              integer *ncolon,
8655              integer *gposit,
8656              integer *,//gnstoc,
8657              doublereal *gmatri,
8658              doublereal *vecin,
8659              doublereal *vecout,
8660              integer *iercod)
8661
8662 {
8663   /* System generated locals */
8664   integer i__1, i__2;
8665
8666   /* Local variables */
8667   logical ldbg;
8668   integer imin, imax, i__, j, k;
8669   doublereal somme;
8670   integer aux;
8671
8672
8673 /* ***********************************************************************
8674  */
8675
8676 /*     FUNCTION : */
8677 /*     ---------- */
8678 /*                          t */
8679 /*      CREATES PRODUCT   G V */
8680 /*      WHERE THE MATRIX IS IN FORM OF PROFILE */
8681
8682 /*     KEYWORDS : */
8683 /*     ----------- */
8684 /*      RESERVE, PRODUCT, MATRIX, PROFILE, VECTOR */
8685
8686 /*     INPUT ARGUMENTS : */
8687 /*     -------------------- */
8688 /*       NLIGNE : NUMBER OF LINE OF THE MATRIX */
8689 /*       NCOLON : NOMBER OF COLUMN OF THE MATRIX */
8690 /*       GPOSIT: TABLE OF POSITIONING OF TERMS OF STORAGE */
8691 /*               GPOSIT(1,I) CONTAINS THE NUMBER of TERMS-1 ON LINE
8692                I IN THE PROFILE OF THE MATRIX */
8693 /*              GPOSIT(2,I) CONTAINS THE INDEX OF STORAGE OF THE DIAGONAL TERM
8694 /*               OF LINE I */
8695 /*               GPOSIT(3,I) CONTAINS THE INDEX COLUMN OF THE FIRST TERM OF
8696 /*                           PROFILE OF LINE I */
8697 /*       GNSTOC : NOMBER OF TERM IN THE PROFILE OF GMATRI */
8698 /*       GMATRI : MATRIX OF CONSTRAINTS IN FORM OF PROFILE */
8699 /*       VECIN :  INPUT VECTOR */
8700
8701 /*     OUTPUT ARGUMENTS : */
8702 /*     --------------------- */
8703 /*       VECOUT : VECTOR PRODUCT */
8704 /*       IERCOD : ERROR CODE */
8705
8706
8707 /*     COMMONS USED : */
8708 /*     ------------------ */
8709
8710
8711 /*     REFERENCES CALLED : */
8712 /*     --------------------- */
8713
8714
8715 /*     DESCRIPTION/NOTES/LIMITATIONS : */
8716 /*     ----------------------------------- */
8717 /* > */
8718 /* ***********************************************************************
8719  */
8720 /*                            DECLARATIONS */
8721 /* ***********************************************************************
8722  */
8723
8724
8725
8726 /* ***********************************************************************
8727  */
8728 /*                      INITIALISATIONS */
8729 /* ***********************************************************************
8730  */
8731
8732     /* Parameter adjustments */
8733     --vecin;
8734     gposit -= 4;
8735     --vecout;
8736     --gmatri;
8737
8738     /* Function Body */
8739     ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 2;
8740     if (ldbg) {
8741         AdvApp2Var_SysBase::mgenmsg_("MMTMAVE", 7L);
8742     }
8743     *iercod = 0;
8744
8745 /* ***********************************************************************
8746  */
8747 /*                     PROCESSING */
8748 /* ***********************************************************************
8749  */
8750
8751
8752
8753     i__1 = *ncolon;
8754     for (i__ = 1; i__ <= i__1; ++i__) {
8755         somme = 0.;
8756         i__2 = *nligne;
8757         for (j = 1; j <= i__2; ++j) {
8758             imin = gposit[j * 3 + 3];
8759             imax = gposit[j * 3 + 1] + gposit[j * 3 + 3] - 1;
8760             aux = gposit[j * 3 + 2] - gposit[j * 3 + 1] - imin + 1;
8761             if (imin <= i__ && i__ <= imax) {
8762                 k = i__ + aux;
8763                 somme += gmatri[k] * vecin[j];
8764             }
8765         }
8766         vecout[i__] = somme;
8767     }
8768
8769
8770
8771
8772
8773     goto L9999;
8774
8775 /* ***********************************************************************
8776  */
8777 /*                   ERROR PROCESSING */
8778 /* ***********************************************************************
8779  */
8780
8781
8782 /* ***********************************************************************
8783  */
8784 /*                   RETURN CALLING PROGRAM */
8785 /* ***********************************************************************
8786  */
8787
8788 L9999:
8789
8790 /* ___ DESALLOCATION, ... */
8791
8792     AdvApp2Var_SysBase::maermsg_("MMTMAVE", iercod, 7L);
8793     if (ldbg) {
8794         AdvApp2Var_SysBase::mgsomsg_("MMTMAVE", 7L);
8795     }
8796  return 0 ;
8797 } /* mmtmave_ */
8798
8799 //=======================================================================
8800 //function : mmtrpj0_
8801 //purpose  :
8802 //=======================================================================
8803 int mmtrpj0_(integer *ncofmx,
8804              integer *ndimen,
8805              integer *ncoeff,
8806              doublereal *epsi3d,
8807              doublereal *crvlgd,
8808              doublereal *ycvmax,
8809              doublereal *epstrc,
8810              integer *ncfnew)
8811
8812 {
8813   /* System generated locals */
8814   integer crvlgd_dim1, crvlgd_offset, i__1, i__2;
8815   doublereal d__1;
8816
8817   /* Local variables */
8818   integer ncut, i__;
8819   doublereal bidon, error;
8820   integer nd;
8821
8822
8823 /* ***********************************************************************
8824  */
8825
8826 /*     FUNCTION : */
8827 /*     ---------- */
8828 /*        Lowers the degree of a curve defined on (-1,1) in the direction of */
8829 /*        Legendre with a given precision. */
8830
8831 /*     KEYWORDS : */
8832 /*     ----------- */
8833 /*        LEGENDRE, POLYGON, TRUNCATION, CURVE, SMOOTHING. */
8834
8835 /*     INPUT ARGUMENTS : */
8836 /*     ------------------ */
8837 /*        NCOFMX : Max Nb of coeff. of the curve (dimensioning). */
8838 /*        NDIMEN : Dimension of the space. */
8839 /*        NCOEFF : Degree +1 of the polynom. */
8840 /*        EPSI3D : Precision required for the approximation. */
8841 /*        CRVLGD : The curve the degree which of it is required to lower. */
8842
8843 /*     OUTPUT ARGUMENTS : */
8844 /*     ------------------- */
8845 /*        EPSTRC : Precision of the approximation. */
8846 /*        NCFNEW : Degree +1 of the resulting polynom. */
8847
8848 /*     COMMONS USED   : */
8849 /*     ---------------- */
8850
8851 /*     REFERENCES CALLED   : */
8852 /*     ----------------------- */
8853
8854 /*     DESCRIPTION/NOTES/LIMITATIONS : */
8855 /*     ----------------------------------- */
8856 /* > */
8857 /* ***********************************************************************
8858  */
8859
8860
8861 /* ------- Minimum degree that can be attained : Stop at 1 (RBD) ---------
8862 */
8863
8864     /* Parameter adjustments */
8865     --ycvmax;
8866     crvlgd_dim1 = *ncofmx;
8867     crvlgd_offset = crvlgd_dim1 + 1;
8868     crvlgd -= crvlgd_offset;
8869
8870     /* Function Body */
8871     *ncfnew = 1;
8872 /* ------------------- Init for error calculation -----------------------
8873 */
8874     i__1 = *ndimen;
8875     for (i__ = 1; i__ <= i__1; ++i__) {
8876         ycvmax[i__] = 0.;
8877 /* L100: */
8878     }
8879     *epstrc = 0.;
8880     error = 0.;
8881
8882 /*   Cutting of coefficients. */
8883
8884     ncut = 2;
8885 /* ------ Loop on the series of Legendre :NCOEFF --> 2 (RBD) -----------
8886 */
8887     i__1 = ncut;
8888     for (i__ = *ncoeff; i__ >= i__1; --i__) {
8889 /*   Factor of renormalization. */
8890         bidon = ((i__ - 1) * 2. + 1.) / 2.;
8891         bidon = sqrt(bidon);
8892         i__2 = *ndimen;
8893         for (nd = 1; nd <= i__2; ++nd) {
8894             ycvmax[nd] += (d__1 = crvlgd[i__ + nd * crvlgd_dim1], advapp_abs(d__1)) *
8895                      bidon;
8896 /* L310: */
8897         }
8898 /*   Cutting is stopped if the norm becomes too great. */
8899         error = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
8900         if (error > *epsi3d) {
8901             *ncfnew = i__;
8902             goto L9999;
8903         }
8904
8905 /* ---  Max error cumulee when the I-th coeff is removed. */
8906
8907         *epstrc = error;
8908
8909 /* L300: */
8910     }
8911
8912 /* --------------------------------- End --------------------------------
8913 */
8914
8915 L9999:
8916     return 0;
8917 } /* mmtrpj0_ */
8918
8919 //=======================================================================
8920 //function : mmtrpj2_
8921 //purpose  :
8922 //=======================================================================
8923 int mmtrpj2_(integer *ncofmx,
8924              integer *ndimen,
8925              integer *ncoeff,
8926              doublereal *epsi3d,
8927              doublereal *crvlgd,
8928              doublereal *ycvmax,
8929              doublereal *epstrc,
8930              integer *ncfnew)
8931
8932 {
8933     /* Initialized data */
8934
8935     static doublereal xmaxj[57] = { .9682458365518542212948163499456,
8936             .986013297183269340427888048593603,
8937             1.07810420343739860362585159028115,
8938             1.17325804490920057010925920756025,
8939             1.26476561266905634732910520370741,
8940             1.35169950227289626684434056681946,
8941             1.43424378958284137759129885012494,
8942             1.51281316274895465689402798226634,
8943             1.5878364329591908800533936587012,
8944             1.65970112228228167018443636171226,
8945             1.72874345388622461848433443013543,
8946             1.7952515611463877544077632304216,
8947             1.85947199025328260370244491818047,
8948             1.92161634324190018916351663207101,
8949             1.98186713586472025397859895825157,
8950             2.04038269834980146276967984252188,
8951             2.09730119173852573441223706382076,
8952             2.15274387655763462685970799663412,
8953             2.20681777186342079455059961912859,
8954             2.25961782459354604684402726624239,
8955             2.31122868752403808176824020121524,
8956             2.36172618435386566570998793688131,
8957             2.41117852396114589446497298177554,
8958             2.45964731268663657873849811095449,
8959             2.50718840313973523778244737914028,
8960             2.55385260994795361951813645784034,
8961             2.59968631659221867834697883938297,
8962             2.64473199258285846332860663371298,
8963             2.68902863641518586789566216064557,
8964             2.73261215675199397407027673053895,
8965             2.77551570192374483822124304745691,
8966             2.8177699459714315371037628127545,
8967             2.85940333797200948896046563785957,
8968             2.90044232019793636101516293333324,
8969             2.94091151970640874812265419871976,
8970             2.98083391718088702956696303389061,
8971             3.02023099621926980436221568258656,
8972             3.05912287574998661724731962377847,
8973             3.09752842783622025614245706196447,
8974             3.13546538278134559341444834866301,
8975             3.17295042316122606504398054547289,
8976             3.2099992681699613513775259670214,
8977             3.24662674946606137764916854570219,
8978             3.28284687953866689817670991319787,
8979             3.31867291347259485044591136879087,
8980             3.35411740487202127264475726990106,
8981             3.38919225660177218727305224515862,
8982             3.42390876691942143189170489271753,
8983             3.45827767149820230182596660024454,
8984             3.49230918177808483937957161007792,
8985             3.5260130200285724149540352829756,
8986             3.55939845146044235497103883695448,
8987             3.59247431368364585025958062194665,
8988             3.62524904377393592090180712976368,
8989             3.65773070318071087226169680450936,
8990             3.68992700068237648299565823810245,
8991             3.72184531357268220291630708234186 };
8992
8993     /* System generated locals */
8994     integer crvlgd_dim1, crvlgd_offset, i__1, i__2;
8995     doublereal d__1;
8996
8997     /* Local variables */
8998     integer ncut, i__;
8999     doublereal bidon, error;
9000     integer ia, nd;
9001     doublereal bid, eps1;
9002
9003
9004 /* ***********************************************************************
9005  */
9006
9007 /*     FUNCTION : */
9008 /*     ---------- */
9009 /*        Lower the degree of a curve defined on (-1,1) in the direction of */
9010 /*        Legendre with a given precision. */
9011
9012 /*     KEYWORDS : */
9013 /*     ----------- */
9014 /*        LEGENDRE, POLYGON, TRUNCATION, CURVE, SMOOTHING. */
9015
9016 /*     INPUT ARGUMENTS : */
9017 /*     ------------------ */
9018 /*        NCOFMX : Max nb of coeff. of the curve (dimensioning). */
9019 /*        NDIMEN : Dimension of the space. */
9020 /*        NCOEFF : Degree +1 of the polynom. */
9021 /*        EPSI3D : Precision required for the approximation. */
9022 /*        CRVLGD : The curve the degree which of will be lowered. */
9023
9024 /*     OUTPUT ARGUMENTS : */
9025 /*     ------------------- */
9026 /*        YCVMAX : Auxiliary table (error max on each dimension).
9027 */
9028 /*        EPSTRC : Precision of the approximation. */
9029 /*        NCFNEW : Degree +1 of the resulting polynom. */
9030
9031 /*     COMMONS USED   : */
9032 /*     ---------------- */
9033
9034 /*     REFERENCES CALLED   : */
9035 /*     ----------------------- */
9036
9037 /*     DESCRIPTION/NOTES/LIMITATIONS : */
9038 /*     ----------------------------------- */
9039 /* > */
9040 /* ***********************************************************************
9041  */
9042
9043
9044     /* Parameter adjustments */
9045     --ycvmax;
9046     crvlgd_dim1 = *ncofmx;
9047     crvlgd_offset = crvlgd_dim1 + 1;
9048     crvlgd -= crvlgd_offset;
9049
9050     /* Function Body */
9051
9052
9053
9054 /*   Minimum degree that can be reached : Stop at IA (RBD). -------------
9055 */
9056     ia = 2;
9057     *ncfnew = ia;
9058 /* Init for calculation of error. */
9059     i__1 = *ndimen;
9060     for (i__ = 1; i__ <= i__1; ++i__) {
9061         ycvmax[i__] = 0.;
9062 /* L100: */
9063     }
9064     *epstrc = 0.;
9065     error = 0.;
9066
9067 /*   Cutting of coefficients. */
9068
9069     ncut = ia + 1;
9070 /* ------ Loop on the series of Jacobi :NCOEFF --> IA+1 (RBD) ----------
9071 */
9072     i__1 = ncut;
9073     for (i__ = *ncoeff; i__ >= i__1; --i__) {
9074 /*   Factor of renormalization. */
9075         bidon = xmaxj[i__ - ncut];
9076         i__2 = *ndimen;
9077         for (nd = 1; nd <= i__2; ++nd) {
9078             ycvmax[nd] += (d__1 = crvlgd[i__ + nd * crvlgd_dim1], advapp_abs(d__1)) *
9079                      bidon;
9080 /* L310: */
9081         }
9082 /*   One stops to cut if the norm becomes too great. */
9083         error = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
9084         if (error > *epsi3d) {
9085             *ncfnew = i__;
9086             goto L400;
9087         }
9088
9089 /* --- Max error cumulated when the I-th coeff is removed. */
9090
9091         *epstrc = error;
9092
9093 /* L300: */
9094     }
9095
9096 /* ------- Cutting of zero coeffs of interpolation (RBD) -------
9097 */
9098
9099 L400:
9100     if (*ncfnew == ia) {
9101         AdvApp2Var_MathBase::mmeps1_(&eps1);
9102         for (i__ = ia; i__ >= 2; --i__) {
9103             bid = 0.;
9104             i__1 = *ndimen;
9105             for (nd = 1; nd <= i__1; ++nd) {
9106                 bid += (d__1 = crvlgd[i__ + nd * crvlgd_dim1], advapp_abs(d__1));
9107 /* L600: */
9108             }
9109             if (bid > eps1) {
9110                 *ncfnew = i__;
9111                 goto L9999;
9112             }
9113 /* L500: */
9114         }
9115 /* --- If all coeffs can be removed, this is a point. */
9116         *ncfnew = 1;
9117     }
9118
9119 /* --------------------------------- End --------------------------------
9120 */
9121
9122 L9999:
9123     return 0;
9124 } /* mmtrpj2_ */
9125
9126 //=======================================================================
9127 //function : mmtrpj4_
9128 //purpose  :
9129 //=======================================================================
9130 int mmtrpj4_(integer *ncofmx,
9131              integer *ndimen,
9132              integer *ncoeff,
9133              doublereal *epsi3d,
9134              doublereal *crvlgd,
9135              doublereal *ycvmax,
9136              doublereal *epstrc,
9137              integer *ncfnew)
9138 {
9139     /* Initialized data */
9140
9141     static doublereal xmaxj[55] = { 1.1092649593311780079813740546678,
9142             1.05299572648705464724876659688996,
9143             1.0949715351434178709281698645813,
9144             1.15078388379719068145021100764647,
9145             1.2094863084718701596278219811869,
9146             1.26806623151369531323304177532868,
9147             1.32549784426476978866302826176202,
9148             1.38142537365039019558329304432581,
9149             1.43575531950773585146867625840552,
9150             1.48850442653629641402403231015299,
9151             1.53973611681876234549146350844736,
9152             1.58953193485272191557448229046492,
9153             1.63797820416306624705258190017418,
9154             1.68515974143594899185621942934906,
9155             1.73115699602477936547107755854868,
9156             1.77604489805513552087086912113251,
9157             1.81989256661534438347398400420601,
9158             1.86276344480103110090865609776681,
9159             1.90471563564740808542244678597105,
9160             1.94580231994751044968731427898046,
9161             1.98607219357764450634552790950067,
9162             2.02556989246317857340333585562678,
9163             2.06433638992049685189059517340452,
9164             2.10240936014742726236706004607473,
9165             2.13982350649113222745523925190532,
9166             2.17661085564771614285379929798896,
9167             2.21280102016879766322589373557048,
9168             2.2484214321456956597803794333791,
9169             2.28349755104077956674135810027654,
9170             2.31805304852593774867640120860446,
9171             2.35210997297725685169643559615022,
9172             2.38568889602346315560143377261814,
9173             2.41880904328694215730192284109322,
9174             2.45148841120796359750021227795539,
9175             2.48374387161372199992570528025315,
9176             2.5155912654873773953959098501893,
9177             2.54704548720896557684101746505398,
9178             2.57812056037881628390134077704127,
9179             2.60882970619319538196517982945269,
9180             2.63918540521920497868347679257107,
9181             2.66919945330942891495458446613851,
9182             2.69888301230439621709803756505788,
9183             2.72824665609081486737132853370048,
9184             2.75730041251405791603760003778285,
9185             2.78605380158311346185098508516203,
9186             2.81451587035387403267676338931454,
9187             2.84269522483114290814009184272637,
9188             2.87060005919012917988363332454033,
9189             2.89823818258367657739520912946934,
9190             2.92561704377132528239806135133273,
9191             2.95274375377994262301217318010209,
9192             2.97962510678256471794289060402033,
9193             3.00626759936182712291041810228171,
9194             3.03267744830655121818899164295959,
9195             3.05886060707437081434964933864149 };
9196
9197     /* System generated locals */
9198     integer crvlgd_dim1, crvlgd_offset, i__1, i__2;
9199     doublereal d__1;
9200
9201     /* Local variables */
9202     integer ncut, i__;
9203     doublereal bidon, error;
9204     integer ia, nd;
9205     doublereal bid, eps1;
9206
9207
9208
9209 /* ***********************************************************************
9210  */
9211
9212 /*     FUNCTION : */
9213 /*     ---------- */
9214 /*        Lowers the degree of a curve defined on (-1,1) in the direction of */
9215 /*        Legendre with a given precision. */
9216
9217 /*     KEYWORDS : */
9218 /*     ----------- */
9219 /*        LEGENDRE, POLYGON, TRONCATION, CURVE, SMOOTHING. */
9220
9221 /*     INPUT ARGUMENTS : */
9222 /*     ------------------ */
9223 /*        NCOFMX : Max nb of coeff. of the curve (dimensioning). */
9224 /*        NDIMEN : Dimension of the space. */
9225 /*        NCOEFF : Degree +1 of the polynom. */
9226 /*        EPSI3D : Precision required for the approximation. */
9227 /*        CRVLGD : The curve which wishes to lower the degree. */
9228
9229 /*     OUTPUT ARGUMENTS : */
9230 /*     ------------------- */
9231 /*        YCVMAX : Auxiliary table (max error on each dimension).
9232 */
9233 /*        EPSTRC : Precision of the approximation. */
9234 /*        NCFNEW : Degree +1 of the resulting polynom. */
9235
9236 /*     COMMONS USED   : */
9237 /*     ---------------- */
9238
9239 /*     REFERENCES CALLED   : */
9240 /*     ----------------------- */
9241
9242 /*     DESCRIPTION/NOTES/LIMITATIONS : */
9243 /*     ----------------------------------- */
9244 /* > */
9245 /* ***********************************************************************
9246  */
9247
9248
9249     /* Parameter adjustments */
9250     --ycvmax;
9251     crvlgd_dim1 = *ncofmx;
9252     crvlgd_offset = crvlgd_dim1 + 1;
9253     crvlgd -= crvlgd_offset;
9254
9255     /* Function Body */
9256
9257
9258
9259 /*   Minimum degree that can be reached : Stop at IA (RBD). -------------
9260 */
9261     ia = 4;
9262     *ncfnew = ia;
9263 /* Init for error calculation. */
9264     i__1 = *ndimen;
9265     for (i__ = 1; i__ <= i__1; ++i__) {
9266         ycvmax[i__] = 0.;
9267 /* L100: */
9268     }
9269     *epstrc = 0.;
9270     error = 0.;
9271
9272 /*   Cutting of coefficients. */
9273
9274     ncut = ia + 1;
9275 /* ------ Loop on the series of Jacobi :NCOEFF --> IA+1 (RBD) ----------
9276 */
9277     i__1 = ncut;
9278     for (i__ = *ncoeff; i__ >= i__1; --i__) {
9279 /*   Factor of renormalization. */
9280         bidon = xmaxj[i__ - ncut];
9281         i__2 = *ndimen;
9282         for (nd = 1; nd <= i__2; ++nd) {
9283             ycvmax[nd] += (d__1 = crvlgd[i__ + nd * crvlgd_dim1], advapp_abs(d__1)) *
9284                      bidon;
9285 /* L310: */
9286         }
9287 /*   Stop cutting if the norm becomes too great. */
9288         error = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
9289         if (error > *epsi3d) {
9290             *ncfnew = i__;
9291             goto L400;
9292         }
9293
9294 /* -- Error max cumulated when the I-eme coeff is removed. */
9295
9296         *epstrc = error;
9297
9298 /* L300: */
9299     }
9300
9301 /* ------- Cutting of zero coeffs of the pole of interpolation (RBD) -------
9302 */
9303
9304 L400:
9305     if (*ncfnew == ia) {
9306         AdvApp2Var_MathBase::mmeps1_(&eps1);
9307         for (i__ = ia; i__ >= 2; --i__) {
9308             bid = 0.;
9309             i__1 = *ndimen;
9310             for (nd = 1; nd <= i__1; ++nd) {
9311                 bid += (d__1 = crvlgd[i__ + nd * crvlgd_dim1], advapp_abs(d__1));
9312 /* L600: */
9313             }
9314             if (bid > eps1) {
9315                 *ncfnew = i__;
9316                 goto L9999;
9317             }
9318 /* L500: */
9319         }
9320 /* --- If all coeffs can be removed, this is a point. */
9321         *ncfnew = 1;
9322     }
9323
9324 /* --------------------------------- End --------------------------------
9325 */
9326
9327 L9999:
9328     return 0;
9329 } /* mmtrpj4_ */
9330
9331 //=======================================================================
9332 //function : mmtrpj6_
9333 //purpose  :
9334 //=======================================================================
9335 int mmtrpj6_(integer *ncofmx,
9336              integer *ndimen,
9337              integer *ncoeff,
9338              doublereal *epsi3d,
9339              doublereal *crvlgd,
9340              doublereal *ycvmax,
9341              doublereal *epstrc,
9342              integer *ncfnew)
9343
9344 {
9345     /* Initialized data */
9346
9347     static doublereal xmaxj[53] = { 1.21091229812484768570102219548814,
9348             1.11626917091567929907256116528817,
9349             1.1327140810290884106278510474203,
9350             1.1679452722668028753522098022171,
9351             1.20910611986279066645602153641334,
9352             1.25228283758701572089625983127043,
9353             1.29591971597287895911380446311508,
9354             1.3393138157481884258308028584917,
9355             1.3821288728999671920677617491385,
9356             1.42420414683357356104823573391816,
9357             1.46546895108549501306970087318319,
9358             1.50590085198398789708599726315869,
9359             1.54550385142820987194251585145013,
9360             1.58429644271680300005206185490937,
9361             1.62230484071440103826322971668038,
9362             1.65955905239130512405565733793667,
9363             1.69609056468292429853775667485212,
9364             1.73193098017228915881592458573809,
9365             1.7671112206990325429863426635397,
9366             1.80166107681586964987277458875667,
9367             1.83560897003644959204940535551721,
9368             1.86898184653271388435058371983316,
9369             1.90180515174518670797686768515502,
9370             1.93410285411785808749237200054739,
9371             1.96589749778987993293150856865539,
9372             1.99721027139062501070081653790635,
9373             2.02806108474738744005306947877164,
9374             2.05846864831762572089033752595401,
9375             2.08845055210580131460156962214748,
9376             2.11802334209486194329576724042253,
9377             2.14720259305166593214642386780469,
9378             2.17600297710595096918495785742803,
9379             2.20443832785205516555772788192013,
9380             2.2325216999457379530416998244706,
9381             2.2602654243075083168599953074345,
9382             2.28768115912702794202525264301585,
9383             2.3147799369092684021274946755348,
9384             2.34157220782483457076721300512406,
9385             2.36806787963276257263034969490066,
9386             2.39427635443992520016789041085844,
9387             2.42020656255081863955040620243062,
9388             2.44586699364757383088888037359254,
9389             2.47126572552427660024678584642791,
9390             2.49641045058324178349347438430311,
9391             2.52130850028451113942299097584818,
9392             2.54596686772399937214920135190177,
9393             2.5703922285006754089328998222275,
9394             2.59459096001908861492582631591134,
9395             2.61856915936049852435394597597773,
9396             2.64233265984385295286445444361827,
9397             2.66588704638685848486056711408168,
9398             2.68923766976735295746679957665724,
9399             2.71238965987606292679677228666411 };
9400
9401     /* System generated locals */
9402     integer crvlgd_dim1, crvlgd_offset, i__1, i__2;
9403     doublereal d__1;
9404
9405     /* Local variables */
9406     integer ncut, i__;
9407     doublereal bidon, error;
9408     integer ia, nd;
9409     doublereal bid, eps1;
9410
9411
9412
9413 /* ***********************************************************************
9414  */
9415
9416 /*     FUNCTION : */
9417 /*     ---------- */
9418 /*        Lowers the degree of a curve defined on (-1,1) in the direction of */
9419 /*        Legendre to a given precision. */
9420
9421 /*     KEYWORDS : */
9422 /*     ----------- */
9423 /*        LEGENDRE,POLYGON,TRUNCATION,CURVE,SMOOTHING. */
9424
9425 /*     INPUT ARGUMENTS : */
9426 /*     ------------------ */
9427 /*        NCOFMX : Max nb of coeff. of the curve (dimensioning). */
9428 /*        NDIMEN : Dimension of the space. */
9429 /*        NCOEFF : Degree +1 of the polynom. */
9430 /*        EPSI3D : Precision required for the approximation. */
9431 /*        CRVLGD : The curve the degree which of will be lowered. */
9432
9433 /*     OUTPUT ARGUMENTS : */
9434 /*     ------------------- */
9435 /*        YCVMAX : Auxiliary table (max error on each dimension).
9436 /*        EPSTRC : Precision of the approximation. */
9437 /*        NCFNEW : Degree +1 of the resulting polynom. */
9438
9439 /*     COMMONS USED   : */
9440 /*     ---------------- */
9441
9442 /*     REFERENCES CALLED   : */
9443 /*     ----------------------- */
9444
9445 /*     DESCRIPTION/NOTES/LIMITATIONS : */
9446 /*     ----------------------------------- */
9447 /* > */
9448 /* ***********************************************************************
9449  */
9450
9451
9452     /* Parameter adjustments */
9453     --ycvmax;
9454     crvlgd_dim1 = *ncofmx;
9455     crvlgd_offset = crvlgd_dim1 + 1;
9456     crvlgd -= crvlgd_offset;
9457
9458     /* Function Body */
9459
9460
9461
9462 /*   Minimum degree that can be reached : Stop at IA (RBD). -------------
9463 */
9464     ia = 6;
9465     *ncfnew = ia;
9466 /* Init for error calculation. */
9467     i__1 = *ndimen;
9468     for (i__ = 1; i__ <= i__1; ++i__) {
9469         ycvmax[i__] = 0.;
9470 /* L100: */
9471     }
9472     *epstrc = 0.;
9473     error = 0.;
9474
9475 /*   Cutting of coefficients. */
9476
9477     ncut = ia + 1;
9478 /* ------ Loop on the series of Jacobi :NCOEFF --> IA+1 (RBD) ----------
9479 */
9480     i__1 = ncut;
9481     for (i__ = *ncoeff; i__ >= i__1; --i__) {
9482 /*   Factor of renormalization. */
9483         bidon = xmaxj[i__ - ncut];
9484         i__2 = *ndimen;
9485         for (nd = 1; nd <= i__2; ++nd) {
9486             ycvmax[nd] += (d__1 = crvlgd[i__ + nd * crvlgd_dim1], advapp_abs(d__1)) *
9487                      bidon;
9488 /* L310: */
9489         }
9490 /*   Stop cutting if the norm becomes too great. */
9491         error = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
9492         if (error > *epsi3d) {
9493             *ncfnew = i__;
9494             goto L400;
9495         }
9496
9497 /* --- Max error cumulated when the I-th coeff is removed. */
9498
9499         *epstrc = error;
9500
9501 /* L300: */
9502     }
9503
9504 /* ------- Cutting of zero coeff. of the pole of interpolation (RBD) -------
9505 */
9506
9507 L400:
9508     if (*ncfnew == ia) {
9509         AdvApp2Var_MathBase::mmeps1_(&eps1);
9510         for (i__ = ia; i__ >= 2; --i__) {
9511             bid = 0.;
9512             i__1 = *ndimen;
9513             for (nd = 1; nd <= i__1; ++nd) {
9514                 bid += (d__1 = crvlgd[i__ + nd * crvlgd_dim1], advapp_abs(d__1));
9515 /* L600: */
9516             }
9517             if (bid > eps1) {
9518                 *ncfnew = i__;
9519                 goto L9999;
9520             }
9521 /* L500: */
9522         }
9523 /* --- If all coeffs can be removed, this is a point. */
9524         *ncfnew = 1;
9525     }
9526
9527 /* --------------------------------- End --------------------------------
9528 */
9529
9530 L9999:
9531     return 0;
9532 } /* mmtrpj6_ */
9533
9534 //=======================================================================
9535 //function : AdvApp2Var_MathBase::mmtrpjj_
9536 //purpose  :
9537 //=======================================================================
9538  int AdvApp2Var_MathBase::mmtrpjj_(integer *ncofmx,
9539                             integer *ndimen,
9540                             integer *ncoeff,
9541                             doublereal *epsi3d,
9542                             integer *iordre,
9543                             doublereal *crvlgd,
9544                             doublereal *ycvmax,
9545                             doublereal *errmax,
9546                             integer *ncfnew)
9547 {
9548     /* System generated locals */
9549     integer crvlgd_dim1, crvlgd_offset;
9550
9551     /* Local variables */
9552     integer ia;
9553
9554
9555 /* ***********************************************************************
9556  */
9557
9558 /*     FUNCTION : */
9559 /*     ---------- */
9560 /*        Lower the degree of a curve defined on (-1,1) in the direction of */
9561 /*        Legendre with a given precision. */
9562
9563 /*     KEYWORDS : */
9564 /*     ----------- */
9565 /*        LEGENDRE, POLYGON, TRUNCATION, CURVE, SMOOTHING. */
9566
9567 /*     INPUT ARGUMENTS : */
9568 /*     ------------------ */
9569 /*        NCOFMX : Max Nb coeff. of the curve (dimensioning). */
9570 /*        NDIMEN : Dimension of the space. */
9571 /*        NCOEFF : Degree +1 of the polynom. */
9572 /*        EPSI3D : Precision required for the approximation. */
9573 /*        IORDRE : Order of continuity at the extremities. */
9574 /*        CRVLGD : The curve the degree which of should be lowered. */
9575
9576 /*     OUTPUT ARGUMENTS : */
9577 /*     ------------------- */
9578 /*        ERRMAX : Precision of the approximation. */
9579 /*        NCFNEW : Degree +1 of the resulting polynom. */
9580
9581 /*     COMMONS USED   : */
9582 /*     ---------------- */
9583
9584 /*     REFERENCES CALLED : */
9585 /*     ----------------------- */
9586
9587 /*     DESCRIPTION/NOTES/LIMITATIONS : */
9588 /*     ----------------------------------- */
9589 /* > */
9590 /* ***********************************************************************
9591  */
9592
9593
9594     /* Parameter adjustments */
9595     --ycvmax;
9596     crvlgd_dim1 = *ncofmx;
9597     crvlgd_offset = crvlgd_dim1 + 1;
9598     crvlgd -= crvlgd_offset;
9599
9600     /* Function Body */
9601     ia = (*iordre + 1) << 1;
9602
9603     if (ia == 0) {
9604         mmtrpj0_(ncofmx, ndimen, ncoeff, epsi3d, &crvlgd[crvlgd_offset], &
9605                 ycvmax[1], errmax, ncfnew);
9606     } else if (ia == 2) {
9607         mmtrpj2_(ncofmx, ndimen, ncoeff, epsi3d, &crvlgd[crvlgd_offset], &
9608                 ycvmax[1], errmax, ncfnew);
9609     } else if (ia == 4) {
9610         mmtrpj4_(ncofmx, ndimen, ncoeff, epsi3d, &crvlgd[crvlgd_offset], &
9611                 ycvmax[1], errmax, ncfnew);
9612     } else {
9613         mmtrpj6_(ncofmx, ndimen, ncoeff, epsi3d, &crvlgd[crvlgd_offset], &
9614                 ycvmax[1], errmax, ncfnew);
9615     }
9616
9617 /* ------------------------ End -----------------------------------------
9618 */
9619
9620     return 0;
9621 } /* mmtrpjj_ */
9622
9623 //=======================================================================
9624 //function : AdvApp2Var_MathBase::mmunivt_
9625 //purpose  :
9626 //=======================================================================
9627  int AdvApp2Var_MathBase::mmunivt_(integer *ndimen,
9628              doublereal *vector,
9629              doublereal *vecnrm,
9630              doublereal *epsiln,
9631              integer *iercod)
9632 {
9633
9634   doublereal c_b2 = 10.;
9635
9636     /* System generated locals */
9637     integer i__1;
9638     doublereal d__1;
9639
9640     /* Local variables */
9641     integer nchif, iunit, izero;
9642     doublereal vnorm;
9643     integer ii;
9644     doublereal bid;
9645     doublereal eps0;
9646
9647
9648
9649
9650 /* ***********************************************************************
9651  */
9652
9653 /*     FUNCTION : */
9654 /*     ---------- */
9655 /*        CALCULATE THE NORMAL VECTOR BASING ON ANY VECTOR */
9656 /*        WITH PRECISION GIVEN BY THE USER. */
9657
9658 /*     KEYWORDS : */
9659 /*     ----------- */
9660 /*        ALL, MATH_ACCES :: */
9661 /*        VECTEUR&, NORMALISATION, &VECTEUR */
9662
9663 /*     INPUT ARGUMENTS : */
9664 /*     ------------------ */
9665 /*        NDIMEN   : DIMENSION OF THE SPACE */
9666 /*        VECTOR   : VECTOR TO BE NORMED */
9667 /*        EPSILN   : EPSILON BELOW WHICH IT IS CONSIDERED THAT THE */
9668 /*                 NORM OF THE VECTOR IS NULL. IF EPSILN<=0, A DEFAULT VALUE */
9669 /*                 IS IMPOSED (10.D-17 ON VAX). */
9670
9671 /*     OUTPUT ARGUMENTS : */
9672 /*     ------------------- */
9673 /*        VECNRM : NORMED VECTOR */
9674 /*        IERCOD  101 : THE VECTOR IS NULL UP TO EPSILN. */
9675 /*                  0 : OK. */
9676
9677 /*     COMMONS USED   : */
9678 /*     ---------------- */
9679
9680 /*     REFERENCES CALLED   : */
9681 /*     ----------------------- */
9682
9683 /*     DESCRIPTION/NOTES/LIMITATIONS : */
9684 /*     ----------------------------------- */
9685 /*     VECTOR and VECNRM can be identic. */
9686
9687 /*     The norm of vector is calculated and each component is divided by
9688 /*     this norm. After this it is checked if all componentes of the */
9689 /*     vector except for one cost 0 with machine precision. In */
9690 /*     this case the quasi-null components are set to 0.D0. */
9691 /* > */
9692 /* ***********************************************************************
9693  */
9694
9695
9696     /* Parameter adjustments */
9697     --vecnrm;
9698     --vector;
9699
9700     /* Function Body */
9701     *iercod = 0;
9702
9703 /* -------- Precision by default : zero machine 10.D-17 on Vax ------
9704 */
9705
9706     AdvApp2Var_SysBase::maovsr8_(&nchif);
9707     if (*epsiln <= 0.) {
9708         i__1 = -nchif;
9709         eps0 = AdvApp2Var_MathBase::pow__di(&c_b2, &i__1);
9710     } else {
9711         eps0 = *epsiln;
9712     }
9713
9714 /* ------------------------- Calculation of the norm --------------------
9715 */
9716
9717     vnorm = AdvApp2Var_MathBase::mzsnorm_(ndimen, &vector[1]);
9718     if (vnorm <= eps0) {
9719         AdvApp2Var_SysBase::mvriraz_(ndimen, &vecnrm[1]);
9720         *iercod = 101;
9721         goto L9999;
9722     }
9723
9724 /* ---------------------- Calculation of the vector norm  ---------------
9725 */
9726
9727     izero = 0;
9728     i__1 = (-nchif - 1) / 2;
9729     eps0 = AdvApp2Var_MathBase::pow__di(&c_b2, &i__1);
9730     i__1 = *ndimen;
9731     for (ii = 1; ii <= i__1; ++ii) {
9732         vecnrm[ii] = vector[ii] / vnorm;
9733         if ((d__1 = vecnrm[ii], advapp_abs(d__1)) <= eps0) {
9734             ++izero;
9735         } else {
9736             iunit = ii;
9737         }
9738 /* L20: */
9739     }
9740
9741 /* ------ Case when all coordinates except for one are almost null ----
9742 */
9743 /* ------------- then one of coordinates costs 1.D0 or -1.D0 --------
9744 */
9745
9746     if (izero == *ndimen - 1) {
9747         bid = vecnrm[iunit];
9748         i__1 = *ndimen;
9749         for (ii = 1; ii <= i__1; ++ii) {
9750             vecnrm[ii] = 0.;
9751 /* L30: */
9752         }
9753         if (bid > 0.) {
9754             vecnrm[iunit] = 1.;
9755         } else {
9756             vecnrm[iunit] = -1.;
9757         }
9758     }
9759
9760 /* -------------------------------- The end -----------------------------
9761 */
9762
9763 L9999:
9764     return 0;
9765 } /* mmunivt_ */
9766
9767 //=======================================================================
9768 //function : AdvApp2Var_MathBase::mmveps3_
9769 //purpose  :
9770 //=======================================================================
9771  int AdvApp2Var_MathBase::mmveps3_(doublereal *eps03)
9772 {
9773   /* Initialized data */
9774
9775   static char nomprg[8+1] = "MMEPS1  ";
9776
9777   integer ibb;
9778
9779
9780
9781 /************************************************************************
9782 *******/
9783
9784 /*     FUNCTION : */
9785 /*     ---------- */
9786 /*        Extraction of EPS1 from COMMON MPRCSN. */
9787
9788 /*     KEYWORDS : */
9789 /*     ----------- */
9790 /*        MPRCSN,PRECISON,EPS3. */
9791
9792 /*     INPUT ARGUMENTS : */
9793 /*     ------------------ */
9794 /*       Humm. */
9795
9796 /*     OUTPUT ARGUMENTS : */
9797 /*     ------------------- */
9798 /*        EPS3 :  space zero of the denominator (10**-9) */
9799 /*        EPS3 should value 10**-15 */
9800
9801 /*     COMMONS USED   : */
9802 /*     ---------------- */
9803
9804 /*     REFERENCES CALLED   : */
9805 /*     ----------------------- */
9806
9807 /*     DESCRIPTION/NOTES/LIMITATIONS : */
9808 /*     ----------------------------------- */
9809
9810 /* > */
9811 /* ***********************************************************************
9812  */
9813
9814
9815
9816 /* ***********************************************************************
9817  */
9818
9819 /*     FUNCTION : */
9820 /*     ---------- */
9821 /*          GIVES TOLERANCES OF NULLITY IN STRIM */
9822 /*          AND LIMITS OF ITERATIVE PROCESSES */
9823
9824 /*          GENERAL CONTEXT, MODIFIABLE BY THE UTILISER */
9825
9826 /*     KEYWORDS : */
9827 /*     ----------- */
9828 /*          PARAMETER , TOLERANCE */
9829
9830 /*     DESCRIPTION/NOTES/LIMITATIONS : */
9831 /*     ----------------------------------- */
9832 /*       INITIALISATION   :  PROFILE , **VIA MPRFTX** AT INPUT IN STRIM*/
9833 /*       LOADING OF DEFAULT VALUES OF THE PROFILE IN MPRFTX AT INPUT*/
9834 /*       IN STRIM. THEY ARE PRESERVED IN THE LOCAL VARIABLES OF MPRFTX */
9835
9836 /*        RESET DEFAULT VALUES                   : MDFINT */
9837 /*        MODIFICATION INTERACTIVE BY THE USER   : MDBINT */
9838
9839 /*        ACCESS FUNCTION  :  MMEPS1  ...  EPS1 */
9840 /*                            MEPSPB  ...  EPS3,EPS4 */
9841 /*                            MEPSLN  ...  EPS2, NITERM , NITERR */
9842 /*                            MEPSNR  ...  EPS2 , NITERM */
9843 /*                            MITERR  ...  NITERR */
9844
9845 /* > */
9846 /* ***********************************************************************
9847  */
9848
9849 /*     NITERM : MAX NB OF ITERATIONS */
9850 /*     NITERR : NB OF RAPID ITERATIONS */
9851 /*     EPS1   : TOLERANCE OF 3D NULL DISTANCE */
9852 /*     EPS2   : TOLERANCE OF ZERO PARAMETRIC DISTANCE */
9853 /*     EPS3   : TOLERANCE TO AVOID DIVISION BY 0.. */
9854 /*     EPS4   : TOLERANCE ANGULAR */
9855
9856
9857
9858 /* ***********************************************************************
9859  */
9860
9861     ibb = AdvApp2Var_SysBase::mnfndeb_();
9862     if (ibb >= 5) {
9863         AdvApp2Var_SysBase::mgenmsg_(nomprg, 6L);
9864     }
9865
9866     *eps03 = mmprcsn_.eps3;
9867
9868     return 0;
9869 } /* mmveps3_ */
9870
9871 //=======================================================================
9872 //function : AdvApp2Var_MathBase::mmvncol_
9873 //purpose  :
9874 //=======================================================================
9875  int AdvApp2Var_MathBase::mmvncol_(integer *ndimen,
9876                             doublereal *vecin,
9877                             doublereal *vecout,
9878                             integer *iercod)
9879
9880 {
9881   /* System generated locals */
9882   integer i__1;
9883
9884   /* Local variables */
9885   logical ldbg;
9886   integer d__;
9887   doublereal vaux1[3], vaux2[3];
9888   logical colin;
9889   doublereal valaux;
9890   integer aux;
9891   logical nul;
9892
9893 /* ***********************************************************************
9894  */
9895
9896 /*     FUNCTION : */
9897 /*     ---------- */
9898 /*       CALCULATE A VECTOR NON-COLINEAR TO A GIVEN NON-NULL VECTOR */
9899
9900 /*     KEYWORDS : */
9901 /*     ----------- */
9902 /*      PUBLIC, VECTOR, FREE */
9903
9904 /*     INPUT ARGUMENTS  : */
9905 /*     -------------------- */
9906 /*       ndimen : dimension of the space */
9907 /*       vecin  : input vector */
9908
9909 /*     OUTPUT ARGUMENTS : */
9910 /*     --------------------- */
9911
9912 /*       vecout : vector non colinear to vecin */
9913
9914 /*     COMMONS USED : */
9915 /*     ------------------ */
9916
9917
9918 /*     REFERENCES CALLED : */
9919 /*     --------------------- */
9920
9921
9922 /*     DESCRIPTION/NOTES/LIMITATIONS : */
9923 /*     ----------------------------------- */
9924 /* > */
9925 /* ***********************************************************************
9926  */
9927 /*                            DECLARATIONS */
9928 /* ***********************************************************************
9929  */
9930
9931
9932
9933 /* ***********************************************************************
9934  */
9935 /*                      INITIALISATIONS */
9936 /* ***********************************************************************
9937  */
9938
9939     /* Parameter adjustments */
9940     --vecout;
9941     --vecin;
9942
9943     /* Function Body */
9944     ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 2;
9945     if (ldbg) {
9946         AdvApp2Var_SysBase::mgenmsg_("MMVNCOL", 7L);
9947     }
9948     *iercod = 0;
9949
9950 /* ***********************************************************************
9951  */
9952 /*                     PROCESSING */
9953 /* ***********************************************************************
9954  */
9955
9956     if (*ndimen <= 1 || *ndimen > 3) {
9957         goto L9101;
9958     }
9959     nul = FALSE_;
9960     d__ = 1;
9961     aux = 0;
9962     while(d__ <= *ndimen) {
9963         if (vecin[d__] == 0.) {
9964             ++aux;
9965         }
9966         ++d__;
9967     }
9968     if (aux == *ndimen) {
9969         goto L9101;
9970     }
9971
9972
9973     for (d__ = 1; d__ <= 3; ++d__) {
9974         vaux1[d__ - 1] = 0.;
9975     }
9976     i__1 = *ndimen;
9977     for (d__ = 1; d__ <= i__1; ++d__) {
9978         vaux1[d__ - 1] = vecin[d__];
9979         vaux2[d__ - 1] = vecin[d__];
9980     }
9981     colin = TRUE_;
9982     d__ = 0;
9983     while(colin) {
9984         ++d__;
9985         if (d__ > 3) {
9986             goto L9101;
9987         }
9988         vaux2[d__ - 1] += 1;
9989         valaux = vaux1[1] * vaux2[2] - vaux1[2] * vaux2[1];
9990         if (valaux == 0.) {
9991             valaux = vaux1[2] * vaux2[0] - vaux1[0] * vaux2[2];
9992             if (valaux == 0.) {
9993                 valaux = vaux1[0] * vaux2[1] - vaux1[1] * vaux2[0];
9994                 if (valaux != 0.) {
9995                     colin = FALSE_;
9996                 }
9997             } else {
9998                 colin = FALSE_;
9999             }
10000         } else {
10001             colin = FALSE_;
10002         }
10003     }
10004     if (colin) {
10005         goto L9101;
10006     }
10007     i__1 = *ndimen;
10008     for (d__ = 1; d__ <= i__1; ++d__) {
10009         vecout[d__] = vaux2[d__ - 1];
10010     }
10011
10012     goto L9999;
10013
10014 /* ***********************************************************************
10015  */
10016 /*                   ERROR PROCESSING */
10017 /* ***********************************************************************
10018  */
10019
10020
10021 L9101:
10022     *iercod = 1;
10023     goto L9999;
10024
10025
10026 /* ***********************************************************************
10027  */
10028 /*                   RETURN CALLING PROGRAM */
10029 /* ***********************************************************************
10030  */
10031
10032 L9999:
10033
10034
10035     AdvApp2Var_SysBase::maermsg_("MMVNCOL", iercod, 7L);
10036     if (ldbg) {
10037         AdvApp2Var_SysBase::mgsomsg_("MMVNCOL", 7L);
10038     }
10039  return 0 ;
10040 } /* mmvncol_ */
10041
10042 //=======================================================================
10043 //function : AdvApp2Var_MathBase::mmwprcs_
10044 //purpose  :
10045 //=======================================================================
10046 void AdvApp2Var_MathBase::mmwprcs_(doublereal *epsil1,
10047                                    doublereal *epsil2,
10048                                    doublereal *epsil3,
10049                                    doublereal *epsil4,
10050                                    integer *niter1,
10051                                    integer *niter2)
10052
10053 {
10054
10055
10056 /* ***********************************************************************
10057  */
10058
10059 /*     FUNCTION : */
10060 /*     ---------- */
10061 /*     ACCESS IN WRITING FOR COMMON MPRCSN */
10062
10063 /*     KEYWORDS : */
10064 /*     ----------- */
10065 /*     WRITING */
10066
10067 /*     INPUT ARGUMENTS : */
10068 /*     -------------------- */
10069 /*     EPSIL1  : TOLERANCE OF 3D NULL DISTANCE */
10070 /*     EPSIL2  : TOLERANCE OF PARAMETRIC NULL DISTANCE */
10071 /*     EPSIL3  : TOLERANCE TO AVOID DIVISION BY 0.. */
10072 /*     EPSIL4  : ANGULAR TOLERANCE */
10073 /*     NITER1  : MAX NB OF ITERATIONS */
10074 /*     NITER2  : NB OF RAPID ITERATIONS */
10075
10076 /*     OUTPUT ARGUMENTS : */
10077 /*     --------------------- */
10078 /*     NONE */
10079
10080 /*     COMMONS USED : */
10081 /*     ------------------ */
10082
10083
10084 /*     REFERENCES CALLED : */
10085 /*     --------------------- */
10086
10087
10088 /*     DESCRIPTION/NOTES/LIMITATIONS : */
10089 /*     ----------------------------------- */
10090
10091 /* > */
10092 /* ***********************************************************************
10093  */
10094 /*                            DECLARATIONS */
10095 /* ***********************************************************************
10096  */
10097
10098
10099 /* ***********************************************************************
10100  */
10101 /*                      INITIALIZATIONS */
10102 /* ***********************************************************************
10103  */
10104
10105 /* ***********************************************************************
10106  */
10107 /*                      PROCESSING */
10108 /* ***********************************************************************
10109  */
10110
10111 /* ***********************************************************************
10112  */
10113
10114 /*     FUNCTION : */
10115 /*     ---------- */
10116 /*          GIVES TOLERANCES OF NULLITY IN STRIM */
10117 /*          AND  LIMITS OF ITERATIVE PROCESSES */
10118
10119 /*          GENERAL CONTEXT, MODIFIABLE BY THE UTILISER */
10120
10121 /*     KEYWORDS : */
10122 /*     ----------- */
10123 /*          PARAMETER , TOLERANCE */
10124
10125 /*     DESCRIPTION/NOTES/LIMITATIONS : */
10126 /*     ----------------------------------- */
10127 /*       INITIALISATION   :  PROFILE , **VIA MPRFTX** AT INPUT IN STRIM*/
10128 /*       LOADING OF DEFAULT VALUES OF THE PROFILE IN MPRFTX AT INPUT*/
10129 /*       IN STRIM. THEY ARE PRESERVED IN THE LOCAL VARIABLES OF MPRFTX */
10130
10131 /*        RESET DEFAULT VALUES                   : MDFINT */
10132 /*        MODIFICATION INTERACTIVE BY THE USER   : MDBINT */
10133
10134 /*        ACCESS FUNCTION  :  MMEPS1  ...  EPS1 */
10135 /*                            MEPSPB  ...  EPS3,EPS4 */
10136 /*                            MEPSLN  ...  EPS2, NITERM , NITERR */
10137 /*                            MEPSNR  ...  EPS2 , NITERM */
10138 /*                            MITERR  ...  NITERR */
10139
10140 /* > */
10141 /* ***********************************************************************
10142  */
10143
10144 /*     NITERM : MAX NB OF ITERATIONS */
10145 /*     NITERR : NB OF RAPID ITERATIONS */
10146 /*     EPS1   : TOLERANCE OF 3D NULL DISTANCE */
10147 /*     EPS2   : TOLERANCE OF ZERO PARAMETRIC DISTANCE */
10148 /*     EPS3   : TOLERANCE TO AVOID DIVISION BY 0.. */
10149 /*     EPS4   : TOLERANCE ANGULAR */
10150
10151
10152 /* ***********************************************************************
10153  */
10154     mmprcsn_.eps1 = *epsil1;
10155     mmprcsn_.eps2 = *epsil2;
10156     mmprcsn_.eps3 = *epsil3;
10157     mmprcsn_.eps4 = *epsil4;
10158     mmprcsn_.niterm = *niter1;
10159     mmprcsn_.niterr = *niter2;
10160  return ;
10161 } /* mmwprcs_  */
10162
10163
10164 //=======================================================================
10165 //function : AdvApp2Var_MathBase::pow__di
10166 //purpose  :
10167 //=======================================================================
10168  doublereal AdvApp2Var_MathBase::pow__di (doublereal *x,
10169                                    integer *n)
10170 {
10171
10172   register integer ii ;
10173   doublereal result ;
10174   integer    absolute ;
10175   result = 1.0e0 ;
10176   if ( *n > 0 ) {absolute = *n;}
10177   else {absolute = -*n;}
10178     /* System generated locals */
10179   for(ii = 0 ; ii < absolute ; ii++) {
10180       result *=  *x ;
10181    }
10182   if (*n < 0) {
10183    result = 1.0e0 / result ;
10184  }
10185  return result ;
10186 }
10187
10188
10189 /* **********************************************************************
10190 */
10191
10192 /*     FUNCTION : */
10193 /*     ---------- */
10194 /*        Calculate integer function power not obligatory in the most efficient way ;
10195 */
10196
10197 /*     KEYWORDS : */
10198 /*     ----------- */
10199 /*       POWER */
10200
10201 /*     INPUT ARGUMENTS : */
10202 /*     ------------------ */
10203 /*        X      :  argument of X**N */
10204 /*        N      :  power */
10205
10206 /*     OUTPUT ARGUMENTS : */
10207 /*     ------------------- */
10208 /*        return X**N */
10209
10210 /*     COMMONS USED   : */
10211 /*     ---------------- */
10212
10213 /*     REFERENCES CALLED   : */
10214 /*     ----------------------- */
10215
10216 /*     DESCRIPTION/NOTES/LIMITATIONS : */
10217 /*     ----------------------------------- */
10218
10219 /* > */
10220 /* ***********************************************************************/
10221
10222 //=======================================================================
10223 //function : pow__ii
10224 //purpose  :
10225 //=======================================================================
10226 integer pow__ii(integer *x,
10227                 integer *n)
10228
10229 {
10230   register integer ii ;
10231   integer result ;
10232   integer    absolute ;
10233   result = 1 ;
10234   if ( *n > 0 ) {absolute = *n;}
10235   else {absolute = -*n;}
10236     /* System generated locals */
10237   for(ii = 0 ; ii < absolute ; ii++) {
10238       result *=  *x ;
10239    }
10240   if (*n < 0) {
10241    result = 1 / result ;
10242  }
10243  return result ;
10244 }
10245
10246
10247 /* **********************************************************************
10248 */
10249 /* **********************************************************************
10250 */
10251
10252 /*     FUNCTION : */
10253 /*     ---------- */
10254 /*        Calculate integer function power not obligatory in the most efficient way ;
10255 */
10256
10257 /*     KEYWORDS : */
10258 /*     ----------- */
10259 /*       POWER */
10260
10261 /*     INPUT ARGUMENTS : */
10262 /*     ------------------ */
10263 /*        X      :  argument of X**N */
10264 /*        N      :  power */
10265
10266 /*     OUTPUT ARGUMENTS : */
10267 /*     ------------------- */
10268 /*        return X**N */
10269
10270 /*     COMMONS USED   : */
10271 /*     ---------------- */
10272
10273 /*     REFERENCES CALLED   : */
10274 /*     ----------------------- */
10275
10276 /*     DESCRIPTION/NOTES/LIMITATIONS : */
10277 /*     ----------------------------------- */
10278
10279 /* > */
10280 /* ***********************************************************************/
10281
10282 //=======================================================================
10283 //function : AdvApp2Var_MathBase::msc_
10284 //purpose  :
10285 //=======================================================================
10286  doublereal AdvApp2Var_MathBase::msc_(integer *ndimen,
10287                                doublereal *vecte1,
10288                                doublereal *vecte2)
10289
10290 {
10291   /* System generated locals */
10292   integer i__1;
10293   doublereal ret_val;
10294
10295   /* Local variables */
10296   integer i__;
10297   doublereal x;
10298
10299
10300
10301 /************************************************************************
10302 *******/
10303
10304 /*     FUNCTION : */
10305 /*     ---------- */
10306 /*        Calculate the scalar product of 2 vectors in the space */
10307 /*        of dimension NDIMEN. */
10308
10309 /*     KEYWORDS : */
10310 /*     ----------- */
10311 /*        PRODUCT MSCALAIRE. */
10312
10313 /*     INPUT ARGUMENTS  : */
10314 /*     ------------------ */
10315 /*        NDIMEN : Dimension of the space. */
10316 /*        VECTE1,VECTE2: Vectors. */
10317
10318 /*     OUTPUT ARGUMENTS : */
10319 /*     ------------------- */
10320
10321 /*     COMMONS USED     : */
10322 /*     ---------------- */
10323
10324 /*     REFERENCES CALLED : */
10325 /*     ----------------------- */
10326
10327 /*     DESCRIPTION/NOTES/LIMITATIONS : */
10328 /*     ----------------------------------- */
10329
10330 /* > */
10331 /* ***********************************************************************
10332  */
10333
10334
10335 /*     PRODUIT MSCALAIRE */
10336     /* Parameter adjustments */
10337     --vecte2;
10338     --vecte1;
10339
10340     /* Function Body */
10341     x = 0.;
10342
10343     i__1 = *ndimen;
10344     for (i__ = 1; i__ <= i__1; ++i__) {
10345         x += vecte1[i__] * vecte2[i__];
10346 /* L100: */
10347     }
10348     ret_val = x;
10349
10350 /* ----------------------------------- THE END --------------------------
10351 */
10352
10353     return ret_val;
10354 } /* msc_ */
10355
10356 //=======================================================================
10357 //function : mvcvin2_
10358 //purpose  :
10359 //=======================================================================
10360 int mvcvin2_(integer *ncoeff,
10361              doublereal *crvold,
10362              doublereal *crvnew,
10363              integer *iercod)
10364
10365 {
10366   /* System generated locals */
10367   integer i__1, i__2;
10368
10369   /* Local variables */
10370   integer m1jm1, ncfm1, j, k;
10371   doublereal bid;
10372   doublereal cij1, cij2;
10373
10374
10375
10376 /************************************************************************
10377 *******/
10378
10379 /*     FONCTION : */
10380 /*     ---------- */
10381 /*        INVERSION OF THE PARAMETERS ON CURVE 2D. */
10382
10383 /*     KEYWORDS : */
10384 /*     ----------- */
10385 /*        CURVE,2D,INVERSION,PARAMETER. */
10386
10387 /*     INPUT ARGUMENTS : */
10388 /*     ------------------ */
10389 /*        NCOEFF   : NB OF COEFF OF THE CURVE. */
10390 /*        CRVOLD   : CURVE OF ORIGIN */
10391
10392 /*     OUTPUT ARGUMENTS : */
10393 /*     ------------------- */
10394 /*        CRVNEW   : THE RESULTING CURVE AFTER CHANGE OF T BY 1-T */
10395 /*        IERCOD   :  0 OK, */
10396 /*                   10 NB OF COEFF NULL OR TOO GREAT. */
10397
10398 /*     COMMONS USED   : */
10399 /*     ---------------- */
10400 /*    MCCNP */
10401
10402 /*     REFERENCES CALLED   : */
10403 /*     ---------------------- */
10404 /*            Neant */
10405 /*     DESCRIPTION/NOTES/LIMITATIONS : */
10406 /*     ----------------------------------- */
10407 /*     THE FOLLOWING CALL IS ABSOLUTELY LEGAL : */
10408 /*          CALL MVCVIN2(NCOEFF,CURVE,CURVE,IERCOD), THE TABLE CURVE */
10409 /*     BECOMES INPUT AND OUTPUT ARGUMENT (RBD). */
10410 /*     BECAUSE OF MCCNP, THE NB OF COEFF OF THE CURVE IS LIMITED TO */
10411 /*     NDGCNP+1 = 61. */
10412
10413 /* > */
10414 /* ***********************************************************************
10415  */
10416
10417
10418 /* **********************************************************************
10419 */
10420
10421 /*     FUNCTION : */
10422 /*     ---------- */
10423 /*      Serves to provide coefficients of the binome (triangle of Pascal). */
10424
10425 /*     KEYWORDS : */
10426 /*     ----------- */
10427 /*      Coeff of binome from 0 to 60. read only . init par block data */
10428
10429 /*     DEMSCRIPTION/NOTES/LIMITATIONS : */
10430 /*     ----------------------------------- */
10431 /*     The coefficients of the binome form a triangular matrix. */
10432 /*     This matrix is completed in table CNP by transposition. */
10433 /*     So: CNP(I,J) = CNP(J,I) for I and J = 0, ..., 60. */
10434
10435 /*     Initialization is done by block-data MMLLL09.RES, */
10436 /*     created by program MQINICNP.FOR (see the team (AC) ). */
10437
10438
10439 /* > */
10440 /* **********************************************************************
10441 */
10442
10443
10444
10445 /* ***********************************************************************
10446  */
10447
10448     /* Parameter adjustments */
10449     crvnew -= 3;
10450     crvold -= 3;
10451
10452     /* Function Body */
10453     if (*ncoeff < 1 || *ncoeff - 1 > 60) {
10454         *iercod = 10;
10455         goto L9999;
10456     }
10457     *iercod = 0;
10458
10459
10460 /* CONSTANT TERM OF THE NEW CURVE */
10461
10462     cij1 = crvold[3];
10463     cij2 = crvold[4];
10464     i__1 = *ncoeff;
10465     for (k = 2; k <= i__1; ++k) {
10466         cij1 += crvold[(k << 1) + 1];
10467         cij2 += crvold[(k << 1) + 2];
10468     }
10469     crvnew[3] = cij1;
10470     crvnew[4] = cij2;
10471     if (*ncoeff == 1) {
10472         goto L9999;
10473     }
10474
10475 /* INTERMEDIARY POWERS OF THE PARAMETER */
10476
10477     ncfm1 = *ncoeff - 1;
10478     m1jm1 = 1;
10479     i__1 = ncfm1;
10480     for (j = 2; j <= i__1; ++j) {
10481         m1jm1 = -m1jm1;
10482         cij1 = crvold[(j << 1) + 1];
10483         cij2 = crvold[(j << 1) + 2];
10484         i__2 = *ncoeff;
10485         for (k = j + 1; k <= i__2; ++k) {
10486             bid = mmcmcnp_.cnp[k - 1 + (j - 1) * 61];
10487             cij1 += crvold[(k << 1) + 1] * bid;
10488             cij2 += crvold[(k << 1) + 2] * bid;
10489         }
10490         crvnew[(j << 1) + 1] = cij1 * m1jm1;
10491         crvnew[(j << 1) + 2] = cij2 * m1jm1;
10492     }
10493
10494 /* TERM OF THE HIGHEST  DEGREE */
10495
10496     crvnew[(*ncoeff << 1) + 1] = -crvold[(*ncoeff << 1) + 1] * m1jm1;
10497     crvnew[(*ncoeff << 1) + 2] = -crvold[(*ncoeff << 1) + 2] * m1jm1;
10498
10499 L9999:
10500     if (*iercod > 0) {
10501         AdvApp2Var_SysBase::maermsg_("MVCVIN2", iercod, 7L);
10502     }
10503  return 0 ;
10504 } /* mvcvin2_ */
10505
10506 //=======================================================================
10507 //function : mvcvinv_
10508 //purpose  :
10509 //=======================================================================
10510 int mvcvinv_(integer *ncoeff,
10511              doublereal *crvold,
10512              doublereal *crvnew,
10513              integer *iercod)
10514
10515 {
10516   /* System generated locals */
10517   integer i__1, i__2;
10518
10519   /* Local variables */
10520   integer m1jm1, ncfm1, j, k;
10521   doublereal bid;
10522   //extern /* Subroutine */ int maermsg_();
10523   doublereal cij1, cij2, cij3;
10524
10525
10526 /* **********************************************************************
10527 */
10528
10529 /*     FUNCTION : */
10530 /*     ---------- */
10531 /*        INVERSION OF THE PARAMETER ON A CURBE 3D (I.E. INVERSION */
10532 /*        OF THE DIRECTION OF PARSING). */
10533
10534 /*     KEYWORDS : */
10535 /*     ----------- */
10536 /*        CURVE,INVERSION,PARAMETER. */
10537
10538 /*     INPUT ARGUMENTS : */
10539 /*     ------------------ */
10540 /*        NCOEFF   : NB OF COEFF OF THE CURVE. */
10541 /*        CRVOLD   : CURVE OF ORIGIN */
10542
10543 /*     OUTPUT ARGUMENTS : */
10544 /*     ------------------- */
10545 /*        CRVNEW   : RESULTING CURVE AFTER CHANGE OF T INTO 1-T */
10546 /*        IERCOD   :  0 OK, */
10547 /*                   10 NB OF COEFF NULL OR TOO GREAT. */
10548
10549 /*     COMMONS USED   : */
10550 /*     ---------------- */
10551 /*    MCCNP */
10552
10553 /*     REFERENCES CALLED   : */
10554 /*     ---------------------- */
10555 /*            Neant */
10556 /*     DESCRIPTION/NOTES/LIMITATIONS : */
10557 /*     ----------------------------------- */
10558 /*     THE FOLLOWING CALL IS ABSOLUTELY LEGAL : */
10559 /*          CALL MVCVINV(NCOEFF,CURVE,CURVE,IERCOD), TABLE CURVE */
10560 /*     BECOMES INPUT AND OUTPUT ARGUMENT (RBD). */
10561 /*     THE NUMBER OF COEFF OF THE CURVE IS LIMITED TO NDGCNP+1 = 61 */
10562 /*     BECAUSE OF USE OF COMMON MCCNP. */
10563 /* > */
10564 /* ***********************************************************************
10565  */
10566
10567 /* **********************************************************************
10568 */
10569
10570 /*     FUNCTION : */
10571 /*     ---------- */
10572 /*      Serves to provide the binomial coefficients (triangle of Pascal). */
10573
10574 /*     KEYWORDS : */
10575 /*     ----------- */
10576 /*      Binomial Coeff from 0 to 60. read only . init par block data */
10577
10578 /*     DEMSCRIPTION/NOTES/LIMITATIONS : */
10579 /*     ----------------------------------- */
10580 /*     The binomial coefficients form a triangular matrix. */
10581 /*     This matrix is completed in table CNP by its transposition. */
10582 /*     So: CNP(I,J) = CNP(J,I) for I and J = 0, ..., 60. */
10583
10584 /*     Initialisation is done by block-data MMLLL09.RES, */
10585 /*     created by program MQINICNP.FOR (see the team (AC) ). */
10586 /* > */
10587 /* **********************************************************************
10588 */
10589
10590
10591
10592 /* ***********************************************************************
10593  */
10594
10595     /* Parameter adjustments */
10596     crvnew -= 4;
10597     crvold -= 4;
10598
10599     /* Function Body */
10600     if (*ncoeff < 1 || *ncoeff - 1 > 60) {
10601         *iercod = 10;
10602         goto L9999;
10603     }
10604     *iercod = 0;
10605
10606 /* CONSTANT TERM OF THE NEW CURVE */
10607
10608     cij1 = crvold[4];
10609     cij2 = crvold[5];
10610     cij3 = crvold[6];
10611     i__1 = *ncoeff;
10612     for (k = 2; k <= i__1; ++k) {
10613         cij1 += crvold[k * 3 + 1];
10614         cij2 += crvold[k * 3 + 2];
10615         cij3 += crvold[k * 3 + 3];
10616 /* L30: */
10617     }
10618     crvnew[4] = cij1;
10619     crvnew[5] = cij2;
10620     crvnew[6] = cij3;
10621     if (*ncoeff == 1) {
10622         goto L9999;
10623     }
10624
10625 /* INTERMEDIARY POWER OF THE PARAMETER */
10626
10627     ncfm1 = *ncoeff - 1;
10628     m1jm1 = 1;
10629     i__1 = ncfm1;
10630     for (j = 2; j <= i__1; ++j) {
10631         m1jm1 = -m1jm1;
10632         cij1 = crvold[j * 3 + 1];
10633         cij2 = crvold[j * 3 + 2];
10634         cij3 = crvold[j * 3 + 3];
10635         i__2 = *ncoeff;
10636         for (k = j + 1; k <= i__2; ++k) {
10637             bid = mmcmcnp_.cnp[k - 1 + (j - 1) * 61];
10638             cij1 += crvold[k * 3 + 1] * bid;
10639             cij2 += crvold[k * 3 + 2] * bid;
10640             cij3 += crvold[k * 3 + 3] * bid;
10641 /* L40: */
10642         }
10643         crvnew[j * 3 + 1] = cij1 * m1jm1;
10644         crvnew[j * 3 + 2] = cij2 * m1jm1;
10645         crvnew[j * 3 + 3] = cij3 * m1jm1;
10646 /* L50: */
10647     }
10648
10649     /* TERM OF THE HIGHEST DEGREE */
10650
10651     crvnew[*ncoeff * 3 + 1] = -crvold[*ncoeff * 3 + 1] * m1jm1;
10652     crvnew[*ncoeff * 3 + 2] = -crvold[*ncoeff * 3 + 2] * m1jm1;
10653     crvnew[*ncoeff * 3 + 3] = -crvold[*ncoeff * 3 + 3] * m1jm1;
10654
10655 L9999:
10656     AdvApp2Var_SysBase::maermsg_("MVCVINV", iercod, 7L);
10657     return 0;
10658 } /* mvcvinv_ */
10659
10660 //=======================================================================
10661 //function : mvgaus0_
10662 //purpose  :
10663 //=======================================================================
10664 int mvgaus0_(integer *kindic,
10665              doublereal *urootl,
10666              doublereal *hiltab,
10667              integer *nbrval,
10668              integer *iercod)
10669
10670 {
10671     /* System generated locals */
10672     integer i__1;
10673
10674     /* Local variables */
10675     doublereal tamp[40];
10676     integer ndegl, kg, ii;
10677
10678 /* **********************************************************************
10679 */
10680
10681 /*      FUNCTION : */
10682 /*      -------- */
10683 /*  Loading of a degree gives roots of LEGENDRE polynom */
10684 /*  DEFINED on [-1,1] and weights of Gauss quadrature formulas */
10685 /*  (based on corresponding LAGRANGIAN interpolators). */
10686 /*  The symmetry relative to 0 is used between [-1,0] and [0,1]. */
10687
10688 /*      KEYWORDS : */
10689 /*      --------- */
10690 /*         . VOLUMIC, LEGENDRE, LAGRANGE, GAUSS */
10691
10692 /*      INPUT ARGUMENTSE : */
10693 /*      ------------------ */
10694
10695 /*  KINDIC : Takes values from 1 to 10 depending of the degree */
10696 /*           of the used polynom. */
10697 /*           The degree of the polynom is equal to 4 k, i.e. 4, 8, */
10698 /*           12, 16, 20, 24, 28, 32, 36 and 40. */
10699
10700 /*      OUTPUT ARGUMENTS : */
10701 /*      ------------------- */
10702
10703 /*  UROOTL : Roots of LEGENDRE polynom in domain [1,0] */
10704 /*           given in decreasing order. For domain [-1,0], it is */
10705 /*           necessary to take the opposite values. */
10706 /*  HILTAB : LAGRANGE interpolators associated to roots. For */
10707 /*           opposed roots, interpolatorsare equal. */
10708 /*  NBRVAL : Nb of coefficients. Is equal to the half of degree */
10709 /*           depending on the symmetry (i.e. 2*KINDIC). */
10710
10711 /*  IERCOD  :  Error code: */
10712 /*          < 0 ==> Attention - Warning */
10713 /*          =-1 ==> Value of false KINDIC. NBRVAL is forced to 20 */
10714 /*                  (order 40) */
10715 /*          = 0 ==> Everything is OK */
10716
10717 /*      COMMON USED : */
10718 /*      ---------------- */
10719
10720 /*      REFERENCES CALLED : */
10721 /*      ------------------- */
10722
10723 /*      DESCRIPTION/NOTES/LIMITATIONS : */
10724 /*      --------------------------------- */
10725 /*      If KINDIC is not correct (i.e < 1 or > 10), the degree is set */
10726 /*      to 40 directly (ATTENTION to overload - to avoid it, */
10727 /*      preview UROOTL and HILTAB dimensioned at least to 20). */
10728
10729 /*      The value of coefficients was calculated with quadruple precision
10730 /*      by JJM with help of GD. */
10731 /*      Checking of roots was done by GD. */
10732
10733 /*      See detailed explications on the listing */
10734 /* > */
10735 /* **********************************************************************
10736 */
10737
10738
10739 /* ------------------------------------ */
10740 /* ****** Test  validity of KINDIC ** */
10741 /* ------------------------------------ */
10742
10743     /* Parameter adjustments */
10744     --hiltab;
10745     --urootl;
10746
10747     /* Function Body */
10748     *iercod = 0;
10749     kg = *kindic;
10750     if (kg < 1 || kg > 10) {
10751         kg = 10;
10752         *iercod = -1;
10753     }
10754     *nbrval = kg << 1;
10755     ndegl = *nbrval << 1;
10756
10757 /* ----------------------------------------------------------------------
10758 */
10759 /* ****** Load NBRVAL positive roots depending on the degree **
10760 */
10761 /* ----------------------------------------------------------------------
10762 */
10763 /* ATTENTION : Sign minus (-) in the loop is intentional. */
10764
10765     mmextrl_(&ndegl, tamp);
10766     i__1 = *nbrval;
10767     for (ii = 1; ii <= i__1; ++ii) {
10768         urootl[ii] = -tamp[ii - 1];
10769 /* L100: */
10770     }
10771
10772 /* ------------------------------------------------------------------- */
10773 /* ****** Loading of NBRVAL Gauss weight depending on the degree ** */
10774 /* ------------------------------------------------------------------- */
10775
10776     mmexthi_(&ndegl, tamp);
10777     i__1 = *nbrval;
10778     for (ii = 1; ii <= i__1; ++ii) {
10779         hiltab[ii] = tamp[ii - 1];
10780 /* L200: */
10781     }
10782
10783 /* ------------------------------- */
10784 /* ****** End of sub-program ** */
10785 /* ------------------------------- */
10786
10787     return 0;
10788 } /* mvgaus0_ */
10789
10790 //=======================================================================
10791 //function : mvpscr2_
10792 //purpose  :
10793 //=======================================================================
10794 int mvpscr2_(integer *ncoeff,
10795              doublereal *curve2,
10796              doublereal *tparam,
10797              doublereal *pntcrb)
10798 {
10799   /* System generated locals */
10800   integer i__1;
10801
10802   /* Local variables */
10803   integer ndeg, kk;
10804   doublereal xxx, yyy;
10805
10806
10807
10808 /* **********************************************************************
10809 */
10810
10811 /*     FUNCTION : */
10812 /*     ---------- */
10813 /*  POSITIONING ON CURVE (NCF,2) IN SPACE OF DIMENSION 2. */
10814
10815 /*     KEYWORDS : */
10816 /*     ----------- */
10817 /*     TOUS,MATH_ACCES:: COURBE&,POSITIONNEMENT,&POINT. */
10818
10819 /*     INPUT ARGUMENTS : */
10820 /*     ------------------ */
10821 /*     NCOEFF : NUMBER OF COEFFICIENTS OF THE CURVE */
10822 /*     CURVE2 : EQUATION OF CURVE 2D */
10823 /*     TPARAM : VALUE OF PARAMETER AT GIVEN POINT */
10824
10825 /*     OUTPUT ARGUMENTS : */
10826 /*     ------------------- */
10827 /*     PNTCRB : COORDINATES OF POINT CORRESPONDING TO PARAMETER */
10828 /*              TPARAM ON CURVE 2D CURVE2. */
10829
10830 /*     COMMONS USED   : */
10831 /*     ---------------- */
10832
10833 /*     REFERENCES CALLED   : */
10834 /*     ---------------------- */
10835
10836 /*     DESCRIPTION/NOTES/LIMITATIONS : */
10837 /*     ----------------------------------- */
10838 /*     MSCHEMA OF HORNER. */
10839
10840 /* > */
10841 /* **********************************************************************
10842 */
10843
10844
10845 /* -------- INITIALIZATIONS AND PROCESSING OF PARTICULAR CASES ----------
10846 */
10847
10848 /* ---> Cas when NCOEFF > 1 (case STANDARD). */
10849     /* Parameter adjustments */
10850     --pntcrb;
10851     curve2 -= 3;
10852
10853     /* Function Body */
10854     if (*ncoeff >= 2) {
10855         goto L1000;
10856     }
10857 /* ---> Case when NCOEFF <= 1. */
10858     if (*ncoeff <= 0) {
10859         pntcrb[1] = 0.;
10860         pntcrb[2] = 0.;
10861         goto L9999;
10862     } else if (*ncoeff == 1) {
10863         pntcrb[1] = curve2[3];
10864         pntcrb[2] = curve2[4];
10865         goto L9999;
10866     }
10867
10868 /* -------------------- MSCHEMA OF HORNER (PARTICULAR CASE) --------------
10869  */
10870
10871 L1000:
10872
10873     if (*tparam == 1.) {
10874         xxx = 0.;
10875         yyy = 0.;
10876         i__1 = *ncoeff;
10877         for (kk = 1; kk <= i__1; ++kk) {
10878             xxx += curve2[(kk << 1) + 1];
10879             yyy += curve2[(kk << 1) + 2];
10880 /* L100: */
10881         }
10882         goto L5000;
10883     } else if (*tparam == 0.) {
10884         pntcrb[1] = curve2[3];
10885         pntcrb[2] = curve2[4];
10886         goto L9999;
10887     }
10888
10889 /* ---------------------------- MSCHEMA OF HORNER ------------------------
10890  */
10891 /* ---> TPARAM is different from 1.D0 and 0.D0. */
10892
10893     ndeg = *ncoeff - 1;
10894     xxx = curve2[(*ncoeff << 1) + 1];
10895     yyy = curve2[(*ncoeff << 1) + 2];
10896     for (kk = ndeg; kk >= 1; --kk) {
10897         xxx = xxx * *tparam + curve2[(kk << 1) + 1];
10898         yyy = yyy * *tparam + curve2[(kk << 1) + 2];
10899 /* L200: */
10900     }
10901     goto L5000;
10902
10903 /* ------------------------ RECOVER THE CALCULATED POINT ---------------
10904 */
10905
10906 L5000:
10907     pntcrb[1] = xxx;
10908     pntcrb[2] = yyy;
10909
10910 /* ------------------------------ THE END -------------------------------
10911 */
10912
10913 L9999:
10914     return 0;
10915 } /* mvpscr2_ */
10916
10917 //=======================================================================
10918 //function : mvpscr3_
10919 //purpose  :
10920 //=======================================================================
10921 int mvpscr3_(integer *ncoeff,
10922              doublereal *curve3,
10923              doublereal *tparam,
10924              doublereal *pntcrb)
10925
10926 {
10927   /* System generated locals */
10928   integer i__1;
10929
10930   /* Local variables */
10931   integer ndeg, kk;
10932   doublereal xxx, yyy, zzz;
10933
10934
10935
10936 /* **********************************************************************
10937 */
10938
10939 /*     FUNCTION : */
10940 /*     ---------- */
10941 /* POSITIONING ON A CURVE (3,NCF) IN THE SPACE OF DIMENSION 3. */
10942
10943 /*     KEYWORDS : */
10944 /*     ----------- */
10945 /*     TOUS, MATH_ACCES:: COURBE&,POSITIONNEMENT,&POINT. */
10946
10947 /*     INPUT ARGUMENTS  : */
10948 /*     ------------------ */
10949 /*     NCOEFF : NB OF COEFFICIENTS OF THE CURVE */
10950 /*     CURVE3 : EQUATION OF CURVE 3D */
10951 /*     TPARAM : VALUE OF THE PARAMETER AT THE GIVEN POINT */
10952
10953 /*     OUTPUT ARGUMENTS : */
10954 /*     ------------------- */
10955 /*     PNTCRB : COORDINATES OF THE POINT CORRESPONDING TO PARAMETER */
10956 /*              TPARAM ON CURVE 3D CURVE3. */
10957
10958 /*     COMMONS USED   : */
10959 /*     ---------------- */
10960
10961 /*     REFERENCES CALLED   : */
10962 /*     ---------------------- */
10963 /*            Neant */
10964
10965 /*     DESCRIPTION/NOTES/LIMITATIONS : */
10966 /*     ----------------------------------- */
10967 /*     MSCHEMA OF HORNER. */
10968 /* > */
10969 /* **********************************************************************
10970 */
10971 /*                           DECLARATIONS */
10972 /* **********************************************************************
10973 */
10974
10975
10976 /* -------- INITIALISATIONS AND PROCESSING OF PARTICULAR CASES ----------
10977 */
10978
10979 /* ---> Case when NCOEFF > 1 (cas STANDARD). */
10980     /* Parameter adjustments */
10981     --pntcrb;
10982     curve3 -= 4;
10983
10984     /* Function Body */
10985     if (*ncoeff >= 2) {
10986         goto L1000;
10987     }
10988 /* ---> Case when NCOEFF <= 1. */
10989     if (*ncoeff <= 0) {
10990         pntcrb[1] = 0.;
10991         pntcrb[2] = 0.;
10992         pntcrb[3] = 0.;
10993         goto L9999;
10994     } else if (*ncoeff == 1) {
10995         pntcrb[1] = curve3[4];
10996         pntcrb[2] = curve3[5];
10997         pntcrb[3] = curve3[6];
10998         goto L9999;
10999     }
11000
11001 /* -------------------- MSCHEMA OF HORNER (PARTICULAR CASE) --------------
11002  */
11003
11004 L1000:
11005
11006     if (*tparam == 1.) {
11007         xxx = 0.;
11008         yyy = 0.;
11009         zzz = 0.;
11010         i__1 = *ncoeff;
11011         for (kk = 1; kk <= i__1; ++kk) {
11012             xxx += curve3[kk * 3 + 1];
11013             yyy += curve3[kk * 3 + 2];
11014             zzz += curve3[kk * 3 + 3];
11015 /* L100: */
11016         }
11017         goto L5000;
11018     } else if (*tparam == 0.) {
11019         pntcrb[1] = curve3[4];
11020         pntcrb[2] = curve3[5];
11021         pntcrb[3] = curve3[6];
11022         goto L9999;
11023     }
11024
11025 /* ---------------------------- MSCHEMA OF HORNER ------------------------
11026  */
11027 /* ---> Here TPARAM is different from 1.D0 and 0.D0. */
11028
11029     ndeg = *ncoeff - 1;
11030     xxx = curve3[*ncoeff * 3 + 1];
11031     yyy = curve3[*ncoeff * 3 + 2];
11032     zzz = curve3[*ncoeff * 3 + 3];
11033     for (kk = ndeg; kk >= 1; --kk) {
11034         xxx = xxx * *tparam + curve3[kk * 3 + 1];
11035         yyy = yyy * *tparam + curve3[kk * 3 + 2];
11036         zzz = zzz * *tparam + curve3[kk * 3 + 3];
11037 /* L200: */
11038     }
11039     goto L5000;
11040
11041 /* ------------------------ RETURN THE CALCULATED POINT ------------------
11042 */
11043
11044 L5000:
11045     pntcrb[1] = xxx;
11046     pntcrb[2] = yyy;
11047     pntcrb[3] = zzz;
11048
11049 /* ------------------------------ THE END -------------------------------
11050 */
11051
11052 L9999:
11053     return 0;
11054 } /* mvpscr3_ */
11055
11056 //=======================================================================
11057 //function : AdvApp2Var_MathBase::mvsheld_
11058 //purpose  :
11059 //=======================================================================
11060  int AdvApp2Var_MathBase::mvsheld_(integer *n,
11061                             integer *is,
11062                             doublereal *dtab,
11063                             integer *icle)
11064
11065 {
11066   /* System generated locals */
11067   integer dtab_dim1, dtab_offset, i__1, i__2;
11068
11069   /* Local variables */
11070   integer incr;
11071   doublereal dsave;
11072   integer i3, i4, i5, incrp1;
11073
11074
11075 /************************************************************************
11076 *******/
11077
11078 /*     FUNCTION : */
11079 /*     ---------- */
11080 /*       PARSING OF COLUMNS OF TABLE OF REAL*8 BY SHELL METHOD*/
11081 /*        (IN INCREASING ORDER) */
11082
11083 /*     KEYWORDS : */
11084 /*     ----------- */
11085 /*        POINT-ENTRY, PARSING, SHELL */
11086
11087 /*     INPUT ARGUMENTS : */
11088 /*     ------------------ */
11089 /*        N      : NUMBER OF COLUMNS OF THE TABLE */
11090 /*        IS     : NUMBER OF LINE OF THE TABLE */
11091 /*        DTAB   : TABLE OF REAL*8 TO BE PARSED */
11092 /*        ICLE   : POSITION OF THE KEY ON THE COLUMN */
11093
11094 /*     OUTPUT ARGUMENTS : */
11095 /*     ------------------- */
11096 /*        DTAB   : PARSED TABLE */
11097
11098 /*     COMMONS USED   : */
11099 /*     ---------------- */
11100
11101
11102 /*     REFERENCES CALLED   : */
11103 /*     ---------------------- */
11104 /*            Neant */
11105
11106 /*     DESCRIPTION/NOTES/LIMITATIONS : */
11107 /*     ----------------------------------- */
11108 /*     CLASSIC SHELL METHOD : PARSING BY SERIES */
11109 /*     Declaration DTAB(IS, 1) corresponds to DTAB(IS, *) */
11110 /* > */
11111 /* ***********************************************************************
11112  */
11113
11114
11115     /* Parameter adjustments */
11116     dtab_dim1 = *is;
11117     dtab_offset = dtab_dim1 + 1;
11118     dtab -= dtab_offset;
11119
11120     /* Function Body */
11121     if (*n <= 1) {
11122         goto L9900;
11123     }
11124 /*     ------------------------ */
11125
11126 /*  INITIALIZATION OF THE SEQUENCE OF INCREMENTS */
11127 /*  FIND THE GREATEST INCREMENT SO THAT INCR < N/9 */
11128
11129     incr = 1;
11130 L1001:
11131     if (incr >= *n / 9) {
11132         goto L1002;
11133     }
11134 /*     ----------------------------- */
11135     incr = incr * 3 + 1;
11136     goto L1001;
11137
11138 /*  LOOP ON INCREMENTS TILL INCR = 1 */
11139 /*  PARSING BY SERIES DISTANT FROM INCR */
11140
11141 L1002:
11142     incrp1 = incr + 1;
11143 /*     ----------------- */
11144     i__1 = *n;
11145     for (i3 = incrp1; i3 <= i__1; ++i3) {
11146 /*        ---------------------- */
11147
11148 /*  SET ELEMENT I3 AT ITS PLACE IN THE SERIES */
11149
11150         i4 = i3 - incr;
11151 L1004:
11152         if (i4 < 1) {
11153             goto L1003;
11154         }
11155 /*           ------------------------- */
11156         if (dtab[*icle + i4 * dtab_dim1] <= dtab[*icle + (i4 + incr) *
11157                 dtab_dim1]) {
11158             goto L1003;
11159         }
11160
11161         i__2 = *is;
11162         for (i5 = 1; i5 <= i__2; ++i5) {
11163 /*              ------------------ */
11164             dsave = dtab[i5 + i4 * dtab_dim1];
11165             dtab[i5 + i4 * dtab_dim1] = dtab[i5 + (i4 + incr) * dtab_dim1];
11166             dtab[i5 + (i4 + incr) * dtab_dim1] = dsave;
11167         }
11168 /*              -------- */
11169         i4 -= incr;
11170         goto L1004;
11171
11172 L1003:
11173         ;
11174     }
11175 /*           -------- */
11176
11177 /*  PASSAGE TO THE NEXT INCREMENT */
11178
11179     incr /= 3;
11180     if (incr >= 1) {
11181         goto L1002;
11182     }
11183
11184 L9900:
11185  return 0   ;
11186 } /* mvsheld_ */
11187
11188 //=======================================================================
11189 //function : AdvApp2Var_MathBase::mzsnorm_
11190 //purpose  :
11191 //=======================================================================
11192  doublereal AdvApp2Var_MathBase::mzsnorm_(integer *ndimen,
11193                                    doublereal *vecteu)
11194
11195 {
11196   /* System generated locals */
11197   integer i__1;
11198   doublereal ret_val, d__1, d__2;
11199
11200   /* Local variables */
11201   doublereal xsom;
11202   integer i__, irmax;
11203
11204
11205
11206 /* ***********************************************************************
11207  */
11208
11209 /*     FUNCTION : */
11210 /*     ---------- */
11211 /*        SERVES to calculate the euclidian norm of a vector : */
11212 /*                       ____________________________ */
11213 /*                  Z = V  V(1)**2 + V(2)**2 + ... */
11214
11215 /*     KEYWORDS : */
11216 /*     ----------- */
11217 /*        SURMFACIQUE, */
11218
11219 /*     INPUT ARGUMENTS : */
11220 /*     ------------------ */
11221 /*        NDIMEN : Dimension of the vector */
11222 /*        VECTEU : vector of dimension NDIMEN */
11223
11224 /*     OUTPUT ARGUMENTS : */
11225 /*     ------------------- */
11226 /*        MZSNORM : Value of the euclidian norm of vector VECTEU */
11227
11228 /*     COMMONS USED   : */
11229 /*     ---------------- */
11230
11231 /*      .Neant. */
11232
11233 /*     REFERENCES CALLED   : */
11234 /*     ---------------------- */
11235 /*     Type  Name */
11236 /*      R*8  ABS            R*8  SQRT */
11237
11238 /*     DESCRIPTION/NOTESS/LIMITATIONS : */
11239 /*     ----------------------------------- */
11240 /*     To limit the risks of overflow, */
11241 /*     the term of the strongest absolute value is factorized : */
11242 /*                                _______________________ */
11243 /*                  Z = !V(1)! * V  1 + (V(2)/V(1))**2 + ... */
11244
11245 /* > */
11246 /* ***********************************************************************
11247  */
11248 /*                      DECLARATIONS */
11249 /* ***********************************************************************
11250  */
11251
11252
11253 /* ***********************************************************************
11254  */
11255 /*                     PROCESSING */
11256 /* ***********************************************************************
11257  */
11258
11259 /* ___ Find the strongest absolute value term */
11260
11261     /* Parameter adjustments */
11262     --vecteu;
11263
11264     /* Function Body */
11265     irmax = 1;
11266     i__1 = *ndimen;
11267     for (i__ = 2; i__ <= i__1; ++i__) {
11268         if ((d__1 = vecteu[irmax], advapp_abs(d__1)) < (d__2 = vecteu[i__], advapp_abs(d__2)
11269                 )) {
11270             irmax = i__;
11271         }
11272 /* L100: */
11273     }
11274
11275 /* ___ Calculate the norme */
11276
11277     if ((d__1 = vecteu[irmax], advapp_abs(d__1)) < 1.) {
11278         xsom = 0.;
11279         i__1 = *ndimen;
11280         for (i__ = 1; i__ <= i__1; ++i__) {
11281 /* Computing 2nd power */
11282             d__1 = vecteu[i__];
11283             xsom += d__1 * d__1;
11284 /* L200: */
11285         }
11286         ret_val = sqrt(xsom);
11287     } else {
11288         xsom = 0.;
11289         i__1 = *ndimen;
11290         for (i__ = 1; i__ <= i__1; ++i__) {
11291             if (i__ == irmax) {
11292                 xsom += 1.;
11293             } else {
11294 /* Computing 2nd power */
11295                 d__1 = vecteu[i__] / vecteu[irmax];
11296                 xsom += d__1 * d__1;
11297             }
11298 /* L300: */
11299         }
11300         ret_val = (d__1 = vecteu[irmax], advapp_abs(d__1)) * sqrt(xsom);
11301     }
11302
11303 /* ***********************************************************************
11304  */
11305 /*                   RETURN CALLING PROGRAM */
11306 /* ***********************************************************************
11307  */
11308
11309     return ret_val;
11310 } /* mzsnorm_ */
11311