src/AdvApp2Var/AdvApp2Var_MathBase.cxx

   1 // Copyright (c) 1999-2014 OPEN CASCADE SAS
   2 //
   3 // This file is part of Open CASCADE Technology software library.
   4 //
   5 // This library is free software; you can redistribute it and / or modify it
   6 // under the terms of the GNU Lesser General Public version 2.1 as published
   7 // by the Free Software Foundation, with special exception defined in the file
   8 // OCCT_LGPL_EXCEPTION.txt. Consult the file LICENSE_LGPL_21.txt included in OCCT
   9 // distribution for complete text of the license and disclaimer of any warranty.
  10 //
  11 // Alternatively, this file may be used under the terms of Open CASCADE
  12 // commercial license or contractual agreement.
  13
  14 // AdvApp2Var_MathBase.cxx
  15 #include <math.h>
  16 #include <AdvApp2Var_SysBase.hxx>
  17 #include <AdvApp2Var_Data_f2c.hxx>
  18 #include <AdvApp2Var_MathBase.hxx>
  19 #include <AdvApp2Var_Data.hxx>
  20
  21 // statics
  22 static
  23 int mmchole_(integer *mxcoef,
  24              integer *dimens,
  25              doublereal *amatri,
  26              integer *aposit,
  27              integer *posuiv,
  28              doublereal *chomat,
  29              integer *iercod);
  30
  31
  32
  33
  34 static
  35 int mmrslss_(integer *mxcoef,
  36              integer *dimens,
  37              doublereal *smatri,
  38              integer *sposit,
  39              integer *posuiv,
  40              doublereal *mscnmbr,
  41              doublereal *soluti,
  42              integer *iercod);
  43
  44 static
  45 int mfac_(doublereal *f,
  46           integer *n);
  47
  48 static
  49 int mmaper0_(integer *ncofmx,
  50              integer *ndimen,
  51              integer *ncoeff,
  52              doublereal *crvlgd,
  53              integer *ncfnew,
  54              doublereal *ycvmax,
  55              doublereal *errmax);
  56 static
  57 int mmaper2_(integer *ncofmx,
  58              integer *ndimen,
  59              integer *ncoeff,
  60              doublereal *crvjac,
  61              integer *ncfnew,
  62              doublereal *ycvmax,
  63              doublereal *errmax);
  64
  65 static
  66 int mmaper4_(integer *ncofmx,
  67              integer *ndimen,
  68              integer *ncoeff,
  69              doublereal *crvjac,
  70              integer *ncfnew,
  71              doublereal *ycvmax,
  72              doublereal *errmax);
  73
  74 static
  75 int mmaper6_(integer *ncofmx,
  76              integer *ndimen,
  77              integer *ncoeff,
  78              doublereal *crvjac,
  79              integer *ncfnew,
  80              doublereal *ycvmax,
  81              doublereal *errmax);
  82
  83 static
  84 int mmarc41_(integer *ndimax,
  85              integer *ndimen,
  86              integer *ncoeff,
  87              doublereal *crvold,
  88              doublereal *upara0,
  89              doublereal *upara1,
  90              doublereal *crvnew,
  91              integer *iercod);
  92
  93 static
  94 int mmatvec_(integer *nligne,
  95              integer *ncolon,
  96              integer *gposit,
  97              integer *gnstoc,
  98              doublereal *gmatri,
  99              doublereal *vecin,
 100              integer *deblig,
 101              doublereal *vecout,
 102              integer *iercod);
 103
 104 static
 105 int mmcvstd_(integer *ncofmx,
 106              integer *ndimax,
 107              integer *ncoeff,
 108              integer *ndimen,
 109              doublereal *crvcan,
 110              doublereal *courbe);
 111
 112 static
 113 int mmdrvcb_(integer *ideriv,
 114              integer *ndim,
 115              integer *ncoeff,
 116              doublereal *courbe,
 117              doublereal *tparam,
 118              doublereal *tabpnt,
 119              integer *iercod);
 120
 121 static
 122 int mmexthi_(integer *ndegre,
 123              doublereal *hwgaus);
 124
 125 static
 126 int mmextrl_(integer *ndegre,
 127              doublereal *rootlg);
 128
 129
 130
 131 static
 132 int mmherm0_(doublereal *debfin,
 133              integer *iercod);
 134
 135 static
 136 int mmherm1_(doublereal *debfin,
 137              integer *ordrmx,
 138              integer *iordre,
 139              doublereal *hermit,
 140              integer *iercod);
 141 static
 142 int mmloncv_(integer *ndimax,
 143              integer *ndimen,
 144              integer *ncoeff,
 145              doublereal *courbe,
 146              doublereal *tdebut,
 147              doublereal *tfinal,
 148              doublereal *xlongc,
 149              integer *iercod);
 150 static
 151 int mmpojac_(doublereal *tparam,
 152              integer *iordre,
 153              integer *ncoeff,
 154              integer *nderiv,
 155              doublereal *valjac,
 156              integer *iercod);
 157
 158 static
 159 int mmrslw_(integer *normax,
 160             integer *nordre,
 161             integer *ndimen,
 162             doublereal *epspiv,
 163             doublereal *abmatr,
 164             doublereal *xmatri,
 165             integer *iercod);
 166 static
 167 int mmtmave_(integer *nligne,
 168              integer *ncolon,
 169              integer *gposit,
 170              integer *gnstoc,
 171              doublereal *gmatri,
 172              doublereal *vecin,
 173              doublereal *vecout,
 174              integer *iercod);
 175 static
 176 int mmtrpj0_(integer *ncofmx,
 177              integer *ndimen,
 178              integer *ncoeff,
 179              doublereal *epsi3d,
 180              doublereal *crvlgd,
 181              doublereal *ycvmax,
 182              doublereal *epstrc,
 183              integer *ncfnew);
 184 static
 185 int mmtrpj2_(integer *ncofmx,
 186              integer *ndimen,
 187              integer *ncoeff,
 188              doublereal *epsi3d,
 189              doublereal *crvlgd,
 190              doublereal *ycvmax,
 191              doublereal *epstrc,
 192              integer *ncfnew);
 193
 194 static
 195 int mmtrpj4_(integer *ncofmx,
 196              integer *ndimen,
 197              integer *ncoeff,
 198              doublereal *epsi3d,
 199              doublereal *crvlgd,
 200              doublereal *ycvmax,
 201              doublereal *epstrc,
 202              integer *ncfnew);
 203 static
 204 int mmtrpj6_(integer *ncofmx,
 205              integer *ndimen,
 206              integer *ncoeff,
 207              doublereal *epsi3d,
 208              doublereal *crvlgd,
 209              doublereal *ycvmax,
 210              doublereal *epstrc,
 211              integer *ncfnew);
 212 static
 213 integer  pow__ii(integer *x,
 214                  integer *n);
 215
 216 static
 217 int mvcvin2_(integer *ncoeff,
 218              doublereal *crvold,
 219              doublereal *crvnew,
 220              integer *iercod);
 221
 222 static
 223 int mvcvinv_(integer *ncoeff,
 224              doublereal *crvold,
 225              doublereal *crvnew,
 226              integer *iercod);
 227
 228 static
 229 int mvgaus0_(integer *kindic,
 230              doublereal *urootl,
 231              doublereal *hiltab,
 232              integer *nbrval,
 233              integer *iercod);
 234 static
 235 int mvpscr2_(integer *ncoeff,
 236              doublereal *curve2,
 237              doublereal *tparam,
 238              doublereal *pntcrb);
 239
 240 static
 241 int mvpscr3_(integer *ncoeff,
 242              doublereal *curve2,
 243              doublereal *tparam,
 244              doublereal *pntcrb);
 245
 246 static struct {
 247     doublereal eps1, eps2, eps3, eps4;
 248     integer niterm, niterr;
 249 } mmprcsn_;
 250
 251 static struct {
 252     doublereal tdebut, tfinal, verifi, cmherm[576];
 253 } mmcmher_;
 254
 255 //=======================================================================
 256 //function : AdvApp2Var_MathBase::mdsptpt_
 257 //purpose  :
 258 //=======================================================================
 259 int AdvApp2Var_MathBase::mdsptpt_(integer *ndimen,
 260                                   doublereal *point1,
 261                                   doublereal *point2,
 262                                   doublereal *distan)
 263
 264 {
 265   integer c__8 = 8;
 266   /* System generated locals */
 267   integer i__1;
 268   doublereal d__1;
 269
 270   /* Local variables */
 271   integer i__;
 272   doublereal* differ = 0;
 273   integer  ier;
 274   intptr_t iofset, j;
 275
 276 /* **********************************************************************
 277 */
 278
 279 /*     FUNCTION : */
 280 /*     ---------- */
 281 /*        CALCULATE DISTANCE BETWEEN TWO POINTS */
 282
 283 /*     KEYWORDS : */
 284 /*     ----------- */
 285 /*        DISTANCE,POINT. */
 286
 287 /*     INPUT ARGUMENTS : */
 288 /*     ------------------ */
 289 /*        NDIMEN: Space Dimension. */
 290 /*        POINT1: Table of coordinates of the 1st point. */
 291 /*        POINT2: Table of coordinates of the 2nd point. */
 292
 293 /*     OUTPUT ARGUMENTS : */
 294 /*     ------------------- */
 295 /*        DISTAN: Distance between 2 points. */
 296
 297 /*     COMMONS USED   : */
 298 /*     ---------------- */
 299
 300 /*     REFERENCES CALLED   : */
 301 /*     ----------------------- */
 302
 303 /*     DESCRIPTION/NOTES/LIMITATIONS : */
 304 /*     ----------------------------------- */
 305 /* > */
 306 /* **********************************************************************
 307 */
 308
 309
 310 /* ***********************************************************************
 311  */
 312 /*                      INITIALISATION */
 313 /* ***********************************************************************
 314  */
 315
 316     /* Parameter adjustment */
 317     --point2;
 318     --point1;
 319
 320     /* Function Body */
 321     iofset = 0;
 322     ier = 0;
 323
 324 /* ***********************************************************************
 325  */
 326 /*                     TRAITEMENT */
 327 /* ***********************************************************************
 328  */
 329
 330     AdvApp2Var_SysBase anAdvApp2Var_SysBase;
 331     if (*ndimen > 100) {
 332         anAdvApp2Var_SysBase.mcrrqst_(&c__8, ndimen, differ, &iofset, &ier);
 333     }
 334
 335 /* --- If allocation is refused, the trivial method is applied. */
 336
 337     if (ier > 0) {
 338
 339         *distan = 0.;
 340         i__1 = *ndimen;
 341         for (i__ = 1; i__ <= i__1; ++i__) {
 342 /* Computing 2nd power */
 343             d__1 = point1[i__] - point2[i__];
 344             *distan += d__1 * d__1;
 345         }
 346         *distan = sqrt(*distan);
 347
 348 /* --- Otherwise MZSNORM is used to minimize the risks of overflow
 349 */
 350
 351     } else {
 352         i__1 = *ndimen;
 353         for (i__ = 1; i__ <= i__1; ++i__) {
 354             j=iofset + i__ - 1;
 355             differ[j] = point2[i__] - point1[i__];
 356         }
 357
 358         *distan = AdvApp2Var_MathBase::mzsnorm_(ndimen, &differ[iofset]);
 359
 360     }
 361
 362 /* ***********************************************************************
 363  */
 364 /*                   RETURN CALLING PROGRAM */
 365 /* ***********************************************************************
 366  */
 367
 368 /* --- Dynamic Desallocation */
 369
 370     if (iofset != 0) {
 371         anAdvApp2Var_SysBase.mcrdelt_(&c__8, ndimen, differ, &iofset, &ier);
 372     }
 373
 374  return 0 ;
 375 } /* mdsptpt_ */
 376
 377 //=======================================================================
 378 //function : mfac_
 379 //purpose  :
 380 //=======================================================================
 381 int mfac_(doublereal *f,
 382           integer *n)
 383
 384 {
 385     /* System generated locals */
 386     integer i__1;
 387
 388     /* Local variables */
 389     integer i__;
 390
 391 /*    FORTRAN CONFORME AU TEXT */
 392 /*     CALCUL DE MFACTORIEL N */
 393     /* Parameter adjustments */
 394     --f;
 395
 396     /* Function Body */
 397     f[1] = (float)1.;
 398     i__1 = *n;
 399     for (i__ = 2; i__ <= i__1; ++i__) {
 400 /* L10: */
 401         f[i__] = i__ * f[i__ - 1];
 402     }
 403     return 0;
 404 } /* mfac_ */
 405
 406 //=======================================================================
 407 //function : AdvApp2Var_MathBase::mmapcmp_
 408 //purpose  :
 409 //=======================================================================
 410 int AdvApp2Var_MathBase::mmapcmp_(integer *ndim,
 411                                   integer *ncofmx,
 412                                   integer *ncoeff,
 413                                   doublereal *crvold,
 414                                   doublereal *crvnew)
 415
 416 {
 417   /* System generated locals */
 418   integer crvold_dim1, crvold_offset, crvnew_dim1, crvnew_offset, i__1,
 419   i__2;
 420
 421   /* Local variables */
 422   integer ipair, nd, ndegre, impair, ibb, idg;
 423   //extern  int  mgsomsg_();//mgenmsg_(),
 424
 425 /* **********************************************************************
 426 */
 427
 428 /*     FUNCTION : */
 429 /*     ---------- */
 430 /*        Compression of curve CRVOLD in a table of  */
 431 /*        coeff. of even : CRVNEW(*,0,*) */
 432 /*        and uneven range : CRVNEW(*,1,*). */
 433
 434 /*     KEYWORDS : */
 435 /*     ----------- */
 436 /*        COMPRESSION,CURVE. */
 437
 438 /*     INPUT ARGUMENTS : */
 439 /*     ------------------ */
 440 /*     NDIM   : Space Dimension. */
 441 /*     NCOFMX : Max nb of coeff. of the curve to compress. */
 442 /*     NCOEFF : Max nb of coeff. of the compressed curve. */
 443 /*     CRVOLD : The curve (0:NCOFMX-1,NDIM) to compress. */
 444
 445 /*     OUTPUT ARGUMENTS : */
 446 /*     ------------------- */
 447 /*     CRVNEW : Curve compacted in (0:(NCOEFF-1)/2,0,NDIM) (containing
 448 */
 449 /*              even terms) and in (0:(NCOEFF-1)/2,1,NDIM) */
 450 /*              (containing uneven terms). */
 451
 452 /*     COMMONS USED   : */
 453 /*     ---------------- */
 454
 455 /*     REFERENCES CALLED   : */
 456 /*     ----------------------- */
 457
 458 /*     DESCRIPTION/NOTES/LIMITATIONS : */
 459 /*     ----------------------------------- */
 460 /*     This routine is useful to prepare coefficients of a */
 461 /*     curve in an orthogonal base (Legendre or Jacobi) before */
 462 /*     calculating the coefficients in the canonical; base [-1,1] by */
 463 /*     MMJACAN. */
 464 /* ***********************************************************************
 465  */
 466
 467 /*   Name of the routine */
 468
 469     /* Parameter adjustments */
 470     crvold_dim1 = *ncofmx;
 471     crvold_offset = crvold_dim1;
 472     crvold -= crvold_offset;
 473     crvnew_dim1 = (*ncoeff - 1) / 2 + 1;
 474     crvnew_offset = crvnew_dim1 << 1;
 475     crvnew -= crvnew_offset;
 476
 477     /* Function Body */
 478     ibb = AdvApp2Var_SysBase::mnfndeb_();
 479     if (ibb >= 3) {
 480         AdvApp2Var_SysBase::mgenmsg_("MMAPCMP", 7L);
 481     }
 482
 483     ndegre = *ncoeff - 1;
 484     i__1 = *ndim;
 485     for (nd = 1; nd <= i__1; ++nd) {
 486         ipair = 0;
 487         i__2 = ndegre / 2;
 488         for (idg = 0; idg <= i__2; ++idg) {
 489             crvnew[idg + (nd << 1) * crvnew_dim1] = crvold[ipair + nd *
 490                     crvold_dim1];
 491             ipair += 2;
 492 /* L200: */
 493         }
 494         if (ndegre < 1) {
 495             goto L400;
 496         }
 497         impair = 1;
 498         i__2 = (ndegre - 1) / 2;
 499         for (idg = 0; idg <= i__2; ++idg) {
 500             crvnew[idg + ((nd << 1) + 1) * crvnew_dim1] = crvold[impair + nd *
 501                      crvold_dim1];
 502             impair += 2;
 503 /* L300: */
 504         }
 505
 506 L400:
 507 /* L100: */
 508         ;
 509     }
 510
 511 /* ---------------------------------- The end ---------------------------
 512 */
 513
 514     if (ibb >= 3) {
 515         AdvApp2Var_SysBase::mgsomsg_("MMAPCMP", 7L);
 516     }
 517     return 0;
 518 } /* mmapcmp_ */
 519
 520 //=======================================================================
 521 //function : mmaper0_
 522 //purpose  :
 523 //=======================================================================
 524 int mmaper0_(integer *ncofmx,
 525              integer *ndimen,
 526              integer *ncoeff,
 527              doublereal *crvlgd,
 528              integer *ncfnew,
 529              doublereal *ycvmax,
 530              doublereal *errmax)
 531
 532 {
 533   /* System generated locals */
 534   integer crvlgd_dim1, crvlgd_offset, i__1, i__2;
 535   doublereal d__1;
 536
 537   /* Local variables */
 538   integer ncut;
 539   doublereal bidon;
 540   integer ii, nd;
 541
 542 /* ***********************************************************************
 543  */
 544
 545 /*     FUNCTION : */
 546 /*     ---------- */
 547 /*        Calculate the max error of approximation done when */
 548 /*        only the first NCFNEW coefficients of a curve are preserved.
 549 */
 550 /*        Degree NCOEFF-1 written in the base of Legendre (Jacobi */
 551 /*        of  order 0). */
 552
 553 /*     KEYWORDS : */
 554 /*     ----------- */
 555 /*        LEGENDRE,POLYGON,APPROXIMATION,ERROR. */
 556
 557 /*     INPUT ARGUMENTS : */
 558 /*     ------------------ */
 559 /*        NCOFMX : Max. degree of the curve. */
 560 /*        NDIMEN : Space dimension. */
 561 /*        NCOEFF : Degree +1 of the curve. */
 562 /*        CRVLGD : Curve the degree which of should be lowered. */
 563 /*        NCFNEW : Degree +1 of the resulting polynom. */
 564
 565 /*     OUTPUT ARGUMENTS : */
 566 /*     ------------------- */
 567 /*        YCVMAX : Auxiliary Table (max error on each dimension).
 568 */
 569 /*        ERRMAX : Precision of the approximation. */
 570
 571 /*     COMMONS USED   : */
 572 /*     ---------------- */
 573
 574 /*     REFERENCES CALLED   : */
 575 /*     ----------------------- */
 576
 577 /*     DESCRIPTION/NOTES/LIMITATIONS : */
 578 /*     ----------------------------------- */
 579 /* ***********************************************************************
 580  */
 581
 582
 583 /* ------------------- Init to calculate an error -----------------------
 584 */
 585
 586     /* Parameter adjustments */
 587     --ycvmax;
 588     crvlgd_dim1 = *ncofmx;
 589     crvlgd_offset = crvlgd_dim1 + 1;
 590     crvlgd -= crvlgd_offset;
 591
 592     /* Function Body */
 593     i__1 = *ndimen;
 594     for (ii = 1; ii <= i__1; ++ii) {
 595         ycvmax[ii] = 0.;
 596 /* L100: */
 597     }
 598
 599 /* ------ Minimum that can be reached : Stop at 1 or NCFNEW ------
 600 */
 601
 602     ncut = 1;
 603     if (*ncfnew + 1 > ncut) {
 604         ncut = *ncfnew + 1;
 605     }
 606
 607 /* -------------- Elimination of high degree coefficients-----------
 608 */
 609 /* ----------- Loop on the series of Legendre: NCUT --> NCOEFF --------
 610 */
 611
 612     i__1 = *ncoeff;
 613     for (ii = ncut; ii <= i__1; ++ii) {
 614 /*   Factor of renormalization (Maximum of Li(t)). */
 615         bidon = ((ii - 1) * 2. + 1.) / 2.;
 616         bidon = sqrt(bidon);
 617
 618         i__2 = *ndimen;
 619         for (nd = 1; nd <= i__2; ++nd) {
 620             ycvmax[nd] += (d__1 = crvlgd[ii + nd * crvlgd_dim1], advapp_abs(d__1)) *
 621                     bidon;
 622 /* L310: */
 623         }
 624 /* L300: */
 625     }
 626
 627 /* -------------- The error is the norm of the vector error ---------------
 628 */
 629
 630     *errmax = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
 631
 632 /* --------------------------------- Fin --------------------------------
 633 */
 634
 635     return 0;
 636 } /* mmaper0_ */
 637
 638 //=======================================================================
 639 //function : mmaper2_
 640 //purpose  :
 641 //=======================================================================
 642 int mmaper2_(integer *ncofmx,
 643              integer *ndimen,
 644              integer *ncoeff,
 645              doublereal *crvjac,
 646              integer *ncfnew,
 647              doublereal *ycvmax,
 648              doublereal *errmax)
 649
 650 {
 651   /* Initialized data */
 652
 653     static doublereal xmaxj[57] = { .9682458365518542212948163499456,
 654             .986013297183269340427888048593603,
 655             1.07810420343739860362585159028115,
 656             1.17325804490920057010925920756025,
 657             1.26476561266905634732910520370741,
 658             1.35169950227289626684434056681946,
 659             1.43424378958284137759129885012494,
 660             1.51281316274895465689402798226634,
 661             1.5878364329591908800533936587012,
 662             1.65970112228228167018443636171226,
 663             1.72874345388622461848433443013543,
 664             1.7952515611463877544077632304216,
 665             1.85947199025328260370244491818047,
 666             1.92161634324190018916351663207101,
 667             1.98186713586472025397859895825157,
 668             2.04038269834980146276967984252188,
 669             2.09730119173852573441223706382076,
 670             2.15274387655763462685970799663412,
 671             2.20681777186342079455059961912859,
 672             2.25961782459354604684402726624239,
 673             2.31122868752403808176824020121524,
 674             2.36172618435386566570998793688131,
 675             2.41117852396114589446497298177554,
 676             2.45964731268663657873849811095449,
 677             2.50718840313973523778244737914028,
 678             2.55385260994795361951813645784034,
 679             2.59968631659221867834697883938297,
 680             2.64473199258285846332860663371298,
 681             2.68902863641518586789566216064557,
 682             2.73261215675199397407027673053895,
 683             2.77551570192374483822124304745691,
 684             2.8177699459714315371037628127545,
 685             2.85940333797200948896046563785957,
 686             2.90044232019793636101516293333324,
 687             2.94091151970640874812265419871976,
 688             2.98083391718088702956696303389061,
 689             3.02023099621926980436221568258656,
 690             3.05912287574998661724731962377847,
 691             3.09752842783622025614245706196447,
 692             3.13546538278134559341444834866301,
 693             3.17295042316122606504398054547289,
 694             3.2099992681699613513775259670214,
 695             3.24662674946606137764916854570219,
 696             3.28284687953866689817670991319787,
 697             3.31867291347259485044591136879087,
 698             3.35411740487202127264475726990106,
 699             3.38919225660177218727305224515862,
 700             3.42390876691942143189170489271753,
 701             3.45827767149820230182596660024454,
 702             3.49230918177808483937957161007792,
 703             3.5260130200285724149540352829756,
 704             3.55939845146044235497103883695448,
 705             3.59247431368364585025958062194665,
 706             3.62524904377393592090180712976368,
 707             3.65773070318071087226169680450936,
 708             3.68992700068237648299565823810245,
 709             3.72184531357268220291630708234186 };
 710
 711     /* System generated locals */
 712     integer crvjac_dim1, crvjac_offset, i__1, i__2;
 713     doublereal d__1;
 714
 715     /* Local variables */
 716     integer idec, ncut;
 717     doublereal bidon;
 718     integer ii, nd;
 719
 720
 721
 722 /* ***********************************************************************
 723  */
 724
 725 /*     FONCTION : */
 726 /*     ---------- */
 727 /*        Calculate max approximation error i faite lorsque l' on */
 728 /*        ne conserve que les premiers NCFNEW coefficients d' une courbe
 729 */
 730 /*        de degre NCOEFF-1 ecrite dans la base de Jacobi d' ordre 2. */
 731
 732 /*     KEYWORDS : */
 733 /*     ----------- */
 734 /*        JACOBI, POLYGON, APPROXIMATION, ERROR. */
 735 /**/
 736 /*  INPUT ARGUMENTS : */
 737 /*     ------------------ */
 738 /*        NCOFMX : Max. degree of the curve. */
 739 /*        NDIMEN : Space dimension. */
 740 /*        NCOEFF : Degree +1 of the curve. */
 741 /*        CRVLGD : Curve the degree which of should be lowered. */
 742 /*        NCFNEW : Degree +1 of the resulting polynom. */
 743
 744 /*     OUTPUT ARGUMENTS : */
 745 /*     ------------------- */
 746 /*        YCVMAX : Auxiliary Table (max error on each dimension).
 747 */
 748 /*        ERRMAX : Precision of the approximation. */
 749
 750 /*     COMMONS USED   : */
 751 /*     ---------------- */
 752
 753 /*     REFERENCES CALLED   : */
 754 /*     ----------------------- */
 755 /*     DESCRIPTION/NOTES/LIMITATIONS : */
 756 /*     ----------------------------------- */
 757
 758
 759
 760 /* ------------------ Table of maximums of (1-t2)*Ji(t) ----------------
 761 */
 762
 763     /* Parameter adjustments */
 764     --ycvmax;
 765     crvjac_dim1 = *ncofmx;
 766     crvjac_offset = crvjac_dim1 + 1;
 767     crvjac -= crvjac_offset;
 768
 769     /* Function Body */
 770
 771
 772
 773 /* ------------------- Init for error  calculation -----------------------
 774 */
 775
 776     i__1 = *ndimen;
 777     for (ii = 1; ii <= i__1; ++ii) {
 778         ycvmax[ii] = 0.;
 779 /* L100: */
 780     }
 781
 782 /* ------ Min. Degree that can be attained : Stop at 3 or NCFNEW ------
 783 */
 784
 785     idec = 3;
 786 /* Computing MAX */
 787     i__1 = idec, i__2 = *ncfnew + 1;
 788     ncut = advapp_max(i__1,i__2);
 789
 790 /* -------------- Removal of coefficients of high degree -----------
 791 */
 792 /* ----------- Loop on the series of Jacobi :NCUT --> NCOEFF ----------
 793 */
 794
 795     i__1 = *ncoeff;
 796     for (ii = ncut; ii <= i__1; ++ii) {
 797 /*   Factor of renormalization. */
 798         bidon = xmaxj[ii - idec];
 799         i__2 = *ndimen;
 800         for (nd = 1; nd <= i__2; ++nd) {
 801             ycvmax[nd] += (d__1 = crvjac[ii + nd * crvjac_dim1], advapp_abs(d__1)) *
 802                     bidon;
 803 /* L310: */
 804         }
 805 /* L300: */
 806     }
 807
 808 /* -------------- The error is the norm of the vector error ---------------
 809 */
 810
 811     *errmax = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
 812
 813 /* --------------------------------- Fin --------------------------------
 814 */
 815
 816     return 0;
 817 } /* mmaper2_ */
 818
 819 /* MAPER4.f -- translated by f2c (version 19960827).
 820    You must link the resulting object file with the libraries:
 821         -lf2c -lm   (in that order)
 822 */
 823
 824 /* Subroutine */
 825 //=======================================================================
 826 //function : mmaper4_
 827 //purpose  :
 828 //=======================================================================
 829 int mmaper4_(integer *ncofmx,
 830              integer *ndimen,
 831              integer *ncoeff,
 832              doublereal *crvjac,
 833              integer *ncfnew,
 834              doublereal *ycvmax,
 835              doublereal *errmax)
 836 {
 837     /* Initialized data */
 838
 839     static doublereal xmaxj[55] = { 1.1092649593311780079813740546678,
 840             1.05299572648705464724876659688996,
 841             1.0949715351434178709281698645813,
 842             1.15078388379719068145021100764647,
 843             1.2094863084718701596278219811869,
 844             1.26806623151369531323304177532868,
 845             1.32549784426476978866302826176202,
 846             1.38142537365039019558329304432581,
 847             1.43575531950773585146867625840552,
 848             1.48850442653629641402403231015299,
 849             1.53973611681876234549146350844736,
 850             1.58953193485272191557448229046492,
 851             1.63797820416306624705258190017418,
 852             1.68515974143594899185621942934906,
 853             1.73115699602477936547107755854868,
 854             1.77604489805513552087086912113251,
 855             1.81989256661534438347398400420601,
 856             1.86276344480103110090865609776681,
 857             1.90471563564740808542244678597105,
 858             1.94580231994751044968731427898046,
 859             1.98607219357764450634552790950067,
 860             2.02556989246317857340333585562678,
 861             2.06433638992049685189059517340452,
 862             2.10240936014742726236706004607473,
 863             2.13982350649113222745523925190532,
 864             2.17661085564771614285379929798896,
 865             2.21280102016879766322589373557048,
 866             2.2484214321456956597803794333791,
 867             2.28349755104077956674135810027654,
 868             2.31805304852593774867640120860446,
 869             2.35210997297725685169643559615022,
 870             2.38568889602346315560143377261814,
 871             2.41880904328694215730192284109322,
 872             2.45148841120796359750021227795539,
 873             2.48374387161372199992570528025315,
 874             2.5155912654873773953959098501893,
 875             2.54704548720896557684101746505398,
 876             2.57812056037881628390134077704127,
 877             2.60882970619319538196517982945269,
 878             2.63918540521920497868347679257107,
 879             2.66919945330942891495458446613851,
 880             2.69888301230439621709803756505788,
 881             2.72824665609081486737132853370048,
 882             2.75730041251405791603760003778285,
 883             2.78605380158311346185098508516203,
 884             2.81451587035387403267676338931454,
 885             2.84269522483114290814009184272637,
 886             2.87060005919012917988363332454033,
 887             2.89823818258367657739520912946934,
 888             2.92561704377132528239806135133273,
 889             2.95274375377994262301217318010209,
 890             2.97962510678256471794289060402033,
 891             3.00626759936182712291041810228171,
 892             3.03267744830655121818899164295959,
 893             3.05886060707437081434964933864149 };
 894
 895     /* System generated locals */
 896     integer crvjac_dim1, crvjac_offset, i__1, i__2;
 897     doublereal d__1;
 898
 899     /* Local variables */
 900     integer idec, ncut;
 901     doublereal bidon;
 902     integer ii, nd;
 903
 904
 905
 906 /* ***********************************************************************
 907  */
 908
 909 /*     FUNCTION : */
 910 /*     ---------- */
 911 /*        Calculate the max. error of approximation made when  */
 912 /*        only first NCFNEW coefficients of a curve are preserved
 913 */
 914 /*        degree NCOEFF-1 is written in the base of Jacobi of order 4. */
 915 /*        KEYWORDS : */
 916 /*     ----------- */
 917 /*        LEGENDRE,POLYGON,APPROXIMATION,ERROR. */
 918
 919 /*     INPUT ARGUMENTS : */
 920 /*     ------------------ */
 921 /*        NCOFMX : Max. degree of the curve. */
 922 /*        NDIMEN : Space dimension. */
 923 /*        NCOEFF : Degree +1 of the curve. */
 924 /*        CRVJAC : Curve the degree which of should be lowered. */
 925 /*        NCFNEW : Degree +1 of the resulting polynom. */
 926
 927 /*     OUTPUT ARGUMENTS : */
 928 /*     ------------------- */
 929 /*        YCVMAX : Auxiliary Table (max error on each dimension).
 930 */
 931 /*        ERRMAX : Precision of the approximation. */
 932
 933 /*     COMMONS USED   : */
 934 /*     ---------------- */
 935
 936 /*     REFERENCES CALLED   : */
 937 /*     ----------------------- */
 938
 939 /*     DESCRIPTION/NOTES/LIMITATIONS : */
 940
 941
 942 /* ***********************************************************************
 943  */
 944
 945
 946 /* ---------------- Table of maximums of ((1-t2)2)*Ji(t) ---------------
 947 */
 948
 949     /* Parameter adjustments */
 950     --ycvmax;
 951     crvjac_dim1 = *ncofmx;
 952     crvjac_offset = crvjac_dim1 + 1;
 953     crvjac -= crvjac_offset;
 954
 955     /* Function Body */
 956
 957
 958
 959 /* ------------------- Init for error calculation -----------------------
 960 */
 961
 962     i__1 = *ndimen;
 963     for (ii = 1; ii <= i__1; ++ii) {
 964         ycvmax[ii] = 0.;
 965 /* L100: */
 966     }
 967
 968 /* ------ Min. Degree that can be attained : Stop at 5 or NCFNEW ------
 969 */
 970
 971     idec = 5;
 972 /* Computing MAX */
 973     i__1 = idec, i__2 = *ncfnew + 1;
 974     ncut = advapp_max(i__1,i__2);
 975
 976 /* -------------- Removal of high degree coefficients -----------
 977 */
 978 /* ----------- Loop on the series of Jacobi :NCUT --> NCOEFF ----------
 979 */
 980
 981     i__1 = *ncoeff;
 982     for (ii = ncut; ii <= i__1; ++ii) {
 983 /*   Factor of renormalisation. */
 984         bidon = xmaxj[ii - idec];
 985         i__2 = *ndimen;
 986         for (nd = 1; nd <= i__2; ++nd) {
 987             ycvmax[nd] += (d__1 = crvjac[ii + nd * crvjac_dim1], advapp_abs(d__1)) *
 988                     bidon;
 989 /* L310: */
 990         }
 991 /* L300: */
 992     }
 993
 994 /* -------------- The error is the norm of the error vector ---------------
 995 */
 996
 997     *errmax = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
 998
 999 /* --------------------------------- End --------------------------------
1000 */
1001
1002     return 0;
1003 } /* mmaper4_ */
1004
1005 //=======================================================================
1006 //function : mmaper6_
1007 //purpose  :
1008 //=======================================================================
1009 int mmaper6_(integer *ncofmx,
1010              integer *ndimen,
1011              integer *ncoeff,
1012              doublereal *crvjac,
1013              integer *ncfnew,
1014              doublereal *ycvmax,
1015              doublereal *errmax)
1016
1017 {
1018     /* Initialized data */
1019
1020     static doublereal xmaxj[53] = { 1.21091229812484768570102219548814,
1021             1.11626917091567929907256116528817,
1022             1.1327140810290884106278510474203,
1023             1.1679452722668028753522098022171,
1024             1.20910611986279066645602153641334,
1025             1.25228283758701572089625983127043,
1026             1.29591971597287895911380446311508,
1027             1.3393138157481884258308028584917,
1028             1.3821288728999671920677617491385,
1029             1.42420414683357356104823573391816,
1030             1.46546895108549501306970087318319,
1031             1.50590085198398789708599726315869,
1032             1.54550385142820987194251585145013,
1033             1.58429644271680300005206185490937,
1034             1.62230484071440103826322971668038,
1035             1.65955905239130512405565733793667,
1036             1.69609056468292429853775667485212,
1037             1.73193098017228915881592458573809,
1038             1.7671112206990325429863426635397,
1039             1.80166107681586964987277458875667,
1040             1.83560897003644959204940535551721,
1041             1.86898184653271388435058371983316,
1042             1.90180515174518670797686768515502,
1043             1.93410285411785808749237200054739,
1044             1.96589749778987993293150856865539,
1045             1.99721027139062501070081653790635,
1046             2.02806108474738744005306947877164,
1047             2.05846864831762572089033752595401,
1048             2.08845055210580131460156962214748,
1049             2.11802334209486194329576724042253,
1050             2.14720259305166593214642386780469,
1051             2.17600297710595096918495785742803,
1052             2.20443832785205516555772788192013,
1053             2.2325216999457379530416998244706,
1054             2.2602654243075083168599953074345,
1055             2.28768115912702794202525264301585,
1056             2.3147799369092684021274946755348,
1057             2.34157220782483457076721300512406,
1058             2.36806787963276257263034969490066,
1059             2.39427635443992520016789041085844,
1060             2.42020656255081863955040620243062,
1061             2.44586699364757383088888037359254,
1062             2.47126572552427660024678584642791,
1063             2.49641045058324178349347438430311,
1064             2.52130850028451113942299097584818,
1065             2.54596686772399937214920135190177,
1066             2.5703922285006754089328998222275,
1067             2.59459096001908861492582631591134,
1068             2.61856915936049852435394597597773,
1069             2.64233265984385295286445444361827,
1070             2.66588704638685848486056711408168,
1071             2.68923766976735295746679957665724,
1072             2.71238965987606292679677228666411 };
1073
1074     /* System generated locals */
1075     integer crvjac_dim1, crvjac_offset, i__1, i__2;
1076     doublereal d__1;
1077
1078     /* Local variables */
1079     integer idec, ncut;
1080     doublereal bidon;
1081     integer ii, nd;
1082
1083
1084
1085 /* ***********************************************************************
1086  */
1087 /*     FUNCTION : */
1088 /*     ---------- */
1089 /*        Calculate the max. error of approximation made when  */
1090 /*        only first NCFNEW coefficients of a curve are preserved
1091 */
1092 /*        degree NCOEFF-1 is written in the base of Jacobi of order 6. */
1093 /*        KEYWORDS : */
1094 /*     ----------- */
1095 /*        JACOBI,POLYGON,APPROXIMATION,ERROR. */
1096
1097 /*     INPUT ARGUMENTS : */
1098 /*     ------------------ */
1099 /*        NCOFMX : Max. degree of the curve. */
1100 /*        NDIMEN : Space dimension. */
1101 /*        NCOEFF : Degree +1 of the curve. */
1102 /*        CRVJAC : Curve the degree which of should be lowered. */
1103 /*        NCFNEW : Degree +1 of the resulting polynom. */
1104
1105 /*     OUTPUT ARGUMENTS : */
1106 /*     ------------------- */
1107 /*        YCVMAX : Auxiliary Table (max error on each dimension).
1108 */
1109 /*        ERRMAX : Precision of the approximation. */
1110
1111 /*     COMMONS USED   : */
1112 /*     ---------------- */
1113
1114 /*     REFERENCES CALLED   : */
1115 /*     ----------------------- */
1116
1117 /*     DESCRIPTION/NOTES/LIMITATIONS : */
1118 /* > */
1119 /* ***********************************************************************
1120  */
1121
1122
1123 /* ---------------- Table of maximums of ((1-t2)3)*Ji(t) ---------------
1124 */
1125
1126     /* Parameter adjustments */
1127     --ycvmax;
1128     crvjac_dim1 = *ncofmx;
1129     crvjac_offset = crvjac_dim1 + 1;
1130     crvjac -= crvjac_offset;
1131
1132     /* Function Body */
1133
1134
1135
1136 /* ------------------- Init for error calculation -----------------------
1137 */
1138
1139     i__1 = *ndimen;
1140     for (ii = 1; ii <= i__1; ++ii) {
1141         ycvmax[ii] = 0.;
1142 /* L100: */
1143     }
1144
1145 /* ------ Min Degree that can be attained : Stop at 3 or NCFNEW ------
1146 */
1147
1148     idec = 7;
1149 /* Computing MAX */
1150     i__1 = idec, i__2 = *ncfnew + 1;
1151     ncut = advapp_max(i__1,i__2);
1152
1153 /* -------------- Removal of high degree coefficients -----------
1154 */
1155 /* ----------- Loop on the series of Jacobi :NCUT --> NCOEFF ----------
1156 */
1157
1158     i__1 = *ncoeff;
1159     for (ii = ncut; ii <= i__1; ++ii) {
1160 /*   Factor of renormalization. */
1161         bidon = xmaxj[ii - idec];
1162         i__2 = *ndimen;
1163         for (nd = 1; nd <= i__2; ++nd) {
1164             ycvmax[nd] += (d__1 = crvjac[ii + nd * crvjac_dim1], advapp_abs(d__1)) *
1165                     bidon;
1166 /* L310: */
1167         }
1168 /* L300: */
1169     }
1170
1171 /* -------------- The error is the norm of the vector error ---------------
1172 */
1173
1174     *errmax = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
1175
1176 /* --------------------------------- END --------------------------------
1177 */
1178
1179     return 0;
1180 } /* mmaper6_ */
1181
1182 //=======================================================================
1183 //function : AdvApp2Var_MathBase::mmaperx_
1184 //purpose  :
1185 //=======================================================================
1186 int AdvApp2Var_MathBase::mmaperx_(integer *ncofmx,
1187                                   integer *ndimen,
1188                                   integer *ncoeff,
1189                                   integer *iordre,
1190                                   doublereal *crvjac,
1191                                   integer *ncfnew,
1192                                   doublereal *ycvmax,
1193                                   doublereal *errmax,
1194                                   integer *iercod)
1195
1196 {
1197   /* System generated locals */
1198   integer crvjac_dim1, crvjac_offset;
1199
1200   /* Local variables */
1201   integer jord;
1202
1203 /* **********************************************************************
1204 */
1205 /*     FUNCTION : */
1206 /*     ---------- */
1207 /*        Calculate the max. error of approximation made when  */
1208 /*        only first NCFNEW coefficients of a curve are preserved
1209 */
1210 /*        degree NCOEFF-1 is written in the base of Jacobi of order IORDRE. */
1211 /*        KEYWORDS : */
1212 /*     ----------- */
1213 /*        JACOBI,LEGENDRE,POLYGON,APPROXIMATION,ERROR. */
1214
1215 /*     INPUT ARGUMENTS : */
1216 /*     ------------------ */
1217 /*        NCOFMX : Max. degree of the curve. */
1218 /*        NDIMEN : Space dimension. */
1219 /*        NCOEFF : Degree +1 of the curve. */
1220 /*        IORDRE : Order of continuity at the extremities. */
1221 /*        CRVJAC : Curve the degree which of should be lowered. */
1222 /*        NCFNEW : Degree +1 of the resulting polynom. */
1223
1224 /*     OUTPUT ARGUMENTS : */
1225 /*     ------------------- */
1226 /*        YCVMAX : Auxiliary Table (max error on each dimension).
1227 */
1228 /*        ERRMAX : Precision of the approximation. */
1229 /*        IERCOD = 0, OK */
1230 /*               = 1, order of constraints (IORDRE) is not within the */
1231 /*                    autorized values. */
1232 /*     COMMONS USED   : */
1233 /*     ---------------- */
1234
1235 /*     REFERENCES CALLED   : */
1236 /*     ----------------------- */
1237
1238 /*     DESCRIPTION/NOTES/LIMITATIONS : */
1239 /*     ----------------------------------- */
1240 /*     Canceled and replaced MMAPERR. */
1241 /* ***********************************************************************
1242  */
1243
1244
1245     /* Parameter adjustments */
1246     --ycvmax;
1247     crvjac_dim1 = *ncofmx;
1248     crvjac_offset = crvjac_dim1 + 1;
1249     crvjac -= crvjac_offset;
1250
1251     /* Function Body */
1252     *iercod = 0;
1253 /* --> Order of Jacobi polynoms */
1254     jord = ( *iordre + 1) << 1;
1255
1256     if (jord == 0) {
1257         mmaper0_(ncofmx, ndimen, ncoeff, &crvjac[crvjac_offset], ncfnew, &
1258                 ycvmax[1], errmax);
1259     } else if (jord == 2) {
1260         mmaper2_(ncofmx, ndimen, ncoeff, &crvjac[crvjac_offset], ncfnew, &
1261                 ycvmax[1], errmax);
1262     } else if (jord == 4) {
1263         mmaper4_(ncofmx, ndimen, ncoeff, &crvjac[crvjac_offset], ncfnew, &
1264                 ycvmax[1], errmax);
1265     } else if (jord == 6) {
1266         mmaper6_(ncofmx, ndimen, ncoeff, &crvjac[crvjac_offset], ncfnew, &
1267                 ycvmax[1], errmax);
1268     } else {
1269         *iercod = 1;
1270     }
1271
1272 /* ----------------------------------- Fin ------------------------------
1273 */
1274
1275     return 0;
1276 } /* mmaperx_ */
1277
1278 //=======================================================================
1279 //function : mmarc41_
1280 //purpose  :
1281 //=======================================================================
1282  int mmarc41_(integer *ndimax,
1283               integer *ndimen,
1284               integer *ncoeff,
1285               doublereal *crvold,
1286               doublereal *upara0,
1287               doublereal *upara1,
1288               doublereal *crvnew,
1289               integer *iercod)
1290
1291 {
1292   /* System generated locals */
1293     integer crvold_dim1, crvold_offset, crvnew_dim1, crvnew_offset, i__1,
1294     i__2, i__3;
1295
1296     /* Local variables */
1297     integer nboct;
1298     doublereal tbaux[61];
1299     integer nd;
1300     doublereal bid;
1301     integer ncf, ncj;
1302
1303
1304 /*      IMPLICIT DOUBLE PRECISION(A-H,O-Z) */
1305 /*      IMPLICIT INTEGER (I-N) */
1306
1307 /* ***********************************************************************
1308  */
1309
1310 /*     FUNCTION : */
1311 /*     ---------- */
1312 /*     Creation of curve C2(v) defined on (0,1) identic to */
1313 /*     curve C1(u) defined on (U0,U1) (change of parameter */
1314 /*     of a curve). */
1315
1316 /*     KEYWORDS : */
1317 /*     ----------- */
1318 /*        LIMITATION, RESTRICTION, CURVE */
1319
1320 /*     INPUT ARGUMENTS : */
1321 /*     ------------------ */
1322 /*   NDIMAX : Space Dimensioning. */
1323 /*   NDIMEN : Curve Dimension. */
1324 /*   NCOEFF : Nb of coefficients of the curve. */
1325 /*   CRVOLD : Curve to be limited. */
1326 /*   UPARA0     : Min limit of the interval limiting the curve.
1327 */
1328 /*   UPARA1     : Max limit of the interval limiting the curve.
1329 */
1330
1331 /*     OUTPUT ARGUMENTS : */
1332 /*     ------------------- */
1333 /*   CRVNEW : Relimited curve, defined on (0,1) and equal to */
1334 /*            CRVOLD defined on (U0,U1). */
1335 /*   IERCOD : = 0, OK */
1336 /*            =10, Nb of coeff. <1 or > 61. */
1337
1338 /*     COMMONS USED   : */
1339 /*     ---------------- */
1340 /*     REFERENCES CALLED   : */
1341 /*     ---------------------- */
1342 /*     Type  Name */
1343 /*           MAERMSG              MCRFILL              MVCVIN2 */
1344 /*           MVCVINV */
1345
1346 /*     DESCRIPTION/NOTES/LIMITATIONS : */
1347 /*     ----------------------------------- */
1348 /* ---> Algorithm used in this general case is based on the */
1349 /*     following principle  : */
1350 /*        Let S(t) = a0 + a1*t + a2*t**2 + ... of degree NCOEFF-1, and */
1351 /*               U(t) = b0 + b1*t, then the coeff. of */
1352 /*        S(U(t)) are calculated step by step with help of table TBAUX. */
1353 /*        At each step number N (N=2 to NCOEFF), TBAUX(n) contains */
1354 /*        the n-th coefficient of U(t)**N for n=1 to N. (RBD) */
1355 /* ---> Reference : KNUTH, 'The Art of Computer Programming', */
1356 /*                        Vol. 2/'Seminumerical Algorithms', */
1357 /*                        Ex. 11 p:451 et solution p:562. (RBD) */
1358
1359 /* ---> Removal of the input argument CRVOLD by CRVNEW is */
1360 /*     possible, which means that the call : */
1361 /*       CALL MMARC41(NDIMAX,NDIMEN,NCOEFF,CURVE,UPARA0,UPARA1 */
1362 /*                  ,CURVE,IERCOD) */
1363 /*     is absolutely LEGAL. (RBD) */
1364
1365 /* > */
1366 /* **********************************************************************
1367 */
1368
1369 /*   Name of the routine */
1370
1371 /*   Auxiliary table of coefficients of (UPARA1-UPARA0)T+UPARA0  */
1372 /*   with power N=1 to NCOEFF-1. */
1373
1374
1375     /* Parameter adjustments */
1376     crvnew_dim1 = *ndimax;
1377     crvnew_offset = crvnew_dim1 + 1;
1378     crvnew -= crvnew_offset;
1379     crvold_dim1 = *ndimax;
1380     crvold_offset = crvold_dim1 + 1;
1381     crvold -= crvold_offset;
1382
1383     /* Function Body */
1384     *iercod = 0;
1385 /* **********************************************************************
1386 */
1387 /*                CASE WHEN PROCESSING CAN'T BE DONE */
1388 /* **********************************************************************
1389 */
1390     if (*ncoeff > 61 || *ncoeff < 1) {
1391         *iercod = 10;
1392         goto L9999;
1393     }
1394 /* **********************************************************************
1395 */
1396 /*                         IF NO CHANGES */
1397 /* **********************************************************************
1398 */
1399     if (*ndimen == *ndimax && *upara0 == 0. && *upara1 == 1.) {
1400         nboct = (*ndimax << 3) * *ncoeff;
1401         AdvApp2Var_SysBase::mcrfill_(&nboct,
1402                  &crvold[crvold_offset],
1403                  &crvnew[crvnew_offset]);
1404         goto L9999;
1405     }
1406 /* **********************************************************************
1407 */
1408 /*                    INVERSION 3D : FAST PROCESSING */
1409 /* **********************************************************************
1410 */
1411     if (*upara0 == 1. && *upara1 == 0.) {
1412         if (*ndimen == 3 && *ndimax == 3 && *ncoeff <= 21) {
1413             mvcvinv_(ncoeff, &crvold[crvold_offset], &crvnew[crvnew_offset],
1414                     iercod);
1415             goto L9999;
1416         }
1417 /* ******************************************************************
1418 **** */
1419 /*                    INVERSION 2D : FAST PROCESSING */
1420 /* ******************************************************************
1421 **** */
1422         if (*ndimen == 2 && *ndimax == 2 && *ncoeff <= 21) {
1423             mvcvin2_(ncoeff, &crvold[crvold_offset], &crvnew[crvnew_offset],
1424                     iercod);
1425             goto L9999;
1426         }
1427     }
1428 /* **********************************************************************
1429 */
1430 /*                          GENERAL PROCESSING */
1431 /* **********************************************************************
1432 */
1433 /* -------------------------- Initializations ---------------------------
1434 */
1435
1436     i__1 = *ndimen;
1437     for (nd = 1; nd <= i__1; ++nd) {
1438         crvnew[nd + crvnew_dim1] = crvold[nd + crvold_dim1];
1439 /* L100: */
1440     }
1441     if (*ncoeff == 1) {
1442         goto L9999;
1443     }
1444     tbaux[0] = *upara0;
1445     tbaux[1] = *upara1 - *upara0;
1446
1447 /* ----------------------- Calculation of coeff. of CRVNEW ------------------
1448 */
1449
1450     i__1 = *ncoeff - 1;
1451     for (ncf = 2; ncf <= i__1; ++ncf) {
1452
1453 /* ------------ Take into account NCF-th coeff. of CRVOLD --------
1454 ---- */
1455
1456         i__2 = ncf - 1;
1457         for (ncj = 1; ncj <= i__2; ++ncj) {
1458             bid = tbaux[ncj - 1];
1459             i__3 = *ndimen;
1460             for (nd = 1; nd <= i__3; ++nd) {
1461                 crvnew[nd + ncj * crvnew_dim1] += crvold[nd + ncf *
1462                         crvold_dim1] * bid;
1463 /* L400: */
1464             }
1465 /* L300: */
1466         }
1467
1468         bid = tbaux[ncf - 1];
1469         i__2 = *ndimen;
1470         for (nd = 1; nd <= i__2; ++nd) {
1471             crvnew[nd + ncf * crvnew_dim1] = crvold[nd + ncf * crvold_dim1] *
1472                     bid;
1473 /* L500: */
1474         }
1475
1476 /* --------- Calculate (NCF+1) coeff. of ((U1-U0)*t + U0)**(NCF) ---
1477 ---- */
1478
1479         bid = *upara1 - *upara0;
1480         tbaux[ncf] = tbaux[ncf - 1] * bid;
1481         for (ncj = ncf; ncj >= 2; --ncj) {
1482             tbaux[ncj - 1] = tbaux[ncj - 1] * *upara0 + tbaux[ncj - 2] * bid;
1483 /* L600: */
1484         }
1485         tbaux[0] *= *upara0;
1486
1487 /* L200: */
1488     }
1489
1490 /* -------------- Take into account the last coeff. of CRVOLD -----------
1491 */
1492
1493     i__1 = *ncoeff - 1;
1494     for (ncj = 1; ncj <= i__1; ++ncj) {
1495         bid = tbaux[ncj - 1];
1496         i__2 = *ndimen;
1497         for (nd = 1; nd <= i__2; ++nd) {
1498             crvnew[nd + ncj * crvnew_dim1] += crvold[nd + *ncoeff *
1499                     crvold_dim1] * bid;
1500 /* L800: */
1501         }
1502 /* L700: */
1503     }
1504     i__1 = *ndimen;
1505     for (nd = 1; nd <= i__1; ++nd) {
1506         crvnew[nd + *ncoeff * crvnew_dim1] = crvold[nd + *ncoeff *
1507                 crvold_dim1] * tbaux[*ncoeff - 1];
1508 /* L900: */
1509     }
1510
1511 /* ---------------------------- The end ---------------------------------
1512 */
1513
1514 L9999:
1515     if (*iercod != 0) {
1516         AdvApp2Var_SysBase::maermsg_("MMARC41", iercod, 7L);
1517     }
1518
1519  return 0 ;
1520 } /* mmarc41_ */
1521
1522 //=======================================================================
1523 //function : AdvApp2Var_MathBase::mmarcin_
1524 //purpose  :
1525 //=======================================================================
1526 int AdvApp2Var_MathBase::mmarcin_(integer *ndimax,
1527                                   integer *ndim,
1528                                   integer *ncoeff,
1529                                   doublereal *crvold,
1530                                   doublereal *u0,
1531                                   doublereal *u1,
1532                                   doublereal *crvnew,
1533                                   integer *iercod)
1534
1535 {
1536   /* System generated locals */
1537   integer crvold_dim1, crvold_offset, crvnew_dim1, crvnew_offset, i__1,
1538   i__2, i__3;
1539   doublereal d__1;
1540
1541   /* Local variables */
1542   doublereal x0, x1;
1543   integer nd;
1544   doublereal tabaux[61];
1545   integer ibb;
1546   doublereal bid;
1547   integer ncf;
1548   integer ncj;
1549   doublereal eps3;
1550
1551
1552
1553 /* **********************************************************************
1554 *//*     FUNCTION : */
1555 /*     ---------- */
1556 /*     Creation of curve C2(v) defined on [U0,U1] identic to */
1557 /*     curve C1(u) defined on [-1,1] (change of parameter */
1558 /*     of a curve) with INVERSION of indices of the resulting table. */
1559
1560 /*     KEYWORDS : */
1561 /*     ----------- */
1562 /*        GENERALIZED LIMITATION, RESTRICTION, INVERSION, CURVE */
1563
1564 /*     INPUT ARGUMENTS : */
1565 /*     ------------------ */
1566 /*   NDIMAX : Maximum Space Dimensioning. */
1567 /*   NDIMEN : Curve Dimension. */
1568 /*   NCOEFF : Nb of coefficients of the curve. */
1569 /*   CRVOLD : Curve to be limited. */
1570 /*   U0     : Min limit of the interval limiting the curve.
1571 */
1572 /*   U1     : Max limit of the interval limiting the curve.
1573 */
1574
1575 /*     OUTPUT ARGUMENTS : */
1576 /*     ------------------- */
1577 /*   CRVNEW : Relimited curve, defined on  [U0,U1] and equal to */
1578 /*            CRVOLD defined on [-1,1]. */
1579 /*   IERCOD : = 0, OK */
1580 /*            =10, Nb of coeff. <1 or > 61. */
1581 /*            =13, the requested interval of variation is null. */
1582 /*     COMMONS USED   : */
1583 /*     ---------------- */
1584 /*     REFERENCES CALLED   : */
1585 /*     ---------------------- */
1586 /*     DESCRIPTION/NOTES/LIMITATIONS : */
1587 /*     ----------------------------------- */
1588 /* > */
1589 /* **********************************************************************
1590 */
1591
1592 /*   Name of the routine */
1593
1594 /*   Auxiliary table of coefficients of X1*T+X0 */
1595 /*   with power N=1 to NCOEFF-1. */
1596
1597
1598     /* Parameter adjustments */
1599     crvnew_dim1 = *ndimax;
1600     crvnew_offset = crvnew_dim1 + 1;
1601     crvnew -= crvnew_offset;
1602     crvold_dim1 = *ncoeff;
1603     crvold_offset = crvold_dim1 + 1;
1604     crvold -= crvold_offset;
1605
1606     /* Function Body */
1607     ibb = AdvApp2Var_SysBase::mnfndeb_();
1608     if (ibb >= 2) {
1609         AdvApp2Var_SysBase::mgenmsg_("MMARCIN", 7L);
1610     }
1611
1612 /* At zero machine it is tested if the output interval is not null */
1613
1614     AdvApp2Var_MathBase::mmveps3_(&eps3);
1615     if ((d__1 = *u1 - *u0, advapp_abs(d__1)) < eps3) {
1616         *iercod = 13;
1617         goto L9999;
1618     }
1619     *iercod = 0;
1620
1621 /* **********************************************************************
1622 */
1623 /*                CASE WHEN THE PROCESSING IS IMPOSSIBLE */
1624 /* **********************************************************************
1625 */
1626     if (*ncoeff > 61 || *ncoeff < 1) {
1627         *iercod = 10;
1628         goto L9999;
1629     }
1630 /* **********************************************************************
1631 */
1632 /*          IF NO CHANGE OF THE INTERVAL OF DEFINITION */
1633 /*          (ONLY INVERSION OF INDICES OF TABLE CRVOLD) */
1634 /* **********************************************************************
1635 */
1636     if (*ndim == *ndimax && *u0 == -1. && *u1 == 1.) {
1637         AdvApp2Var_MathBase::mmcvinv_(ndim, ncoeff, ndim, &crvold[crvold_offset], &crvnew[
1638                 crvnew_offset]);
1639         goto L9999;
1640     }
1641 /* **********************************************************************
1642 */
1643 /*          CASE WHEN THE NEW INTERVAL OF DEFINITION IS [0,1] */
1644 /* **********************************************************************
1645 */
1646     if (*u0 == 0. && *u1 == 1.) {
1647         mmcvstd_(ncoeff, ndimax, ncoeff, ndim, &crvold[crvold_offset], &
1648                 crvnew[crvnew_offset]);
1649         goto L9999;
1650     }
1651 /* **********************************************************************
1652 */
1653 /*                          GENERAL PROCESSING */
1654 /* **********************************************************************
1655 */
1656 /* -------------------------- Initialization ---------------------------
1657 */
1658
1659     x0 = -(*u1 + *u0) / (*u1 - *u0);
1660     x1 = 2. / (*u1 - *u0);
1661     i__1 = *ndim;
1662     for (nd = 1; nd <= i__1; ++nd) {
1663         crvnew[nd + crvnew_dim1] = crvold[nd * crvold_dim1 + 1];
1664 /* L100: */
1665     }
1666     if (*ncoeff == 1) {
1667         goto L9999;
1668     }
1669     tabaux[0] = x0;
1670     tabaux[1] = x1;
1671
1672 /* ----------------------- Calculation of coeff. of CRVNEW ------------------
1673 */
1674
1675     i__1 = *ncoeff - 1;
1676     for (ncf = 2; ncf <= i__1; ++ncf) {
1677
1678 /* ------------ Take into account the NCF-th coeff. of CRVOLD --------
1679 ---- */
1680
1681         i__2 = ncf - 1;
1682         for (ncj = 1; ncj <= i__2; ++ncj) {
1683             bid = tabaux[ncj - 1];
1684             i__3 = *ndim;
1685             for (nd = 1; nd <= i__3; ++nd) {
1686                 crvnew[nd + ncj * crvnew_dim1] += crvold[ncf + nd *
1687                         crvold_dim1] * bid;
1688 /* L400: */
1689             }
1690 /* L300: */
1691         }
1692
1693         bid = tabaux[ncf - 1];
1694         i__2 = *ndim;
1695         for (nd = 1; nd <= i__2; ++nd) {
1696             crvnew[nd + ncf * crvnew_dim1] = crvold[ncf + nd * crvold_dim1] *
1697                     bid;
1698 /* L500: */
1699         }
1700
1701 /* --------- Calculation of (NCF+1) coeff. of [X1*t + X0]**(NCF) --------
1702 ---- */
1703
1704         tabaux[ncf] = tabaux[ncf - 1] * x1;
1705         for (ncj = ncf; ncj >= 2; --ncj) {
1706             tabaux[ncj - 1] = tabaux[ncj - 1] * x0 + tabaux[ncj - 2] * x1;
1707 /* L600: */
1708         }
1709         tabaux[0] *= x0;
1710
1711 /* L200: */
1712     }
1713
1714 /* -------------- Take into account the last coeff. of CRVOLD -----------
1715 */
1716
1717     i__1 = *ncoeff - 1;
1718     for (ncj = 1; ncj <= i__1; ++ncj) {
1719         bid = tabaux[ncj - 1];
1720         i__2 = *ndim;
1721         for (nd = 1; nd <= i__2; ++nd) {
1722             crvnew[nd + ncj * crvnew_dim1] += crvold[*ncoeff + nd *
1723                     crvold_dim1] * bid;
1724 /* L800: */
1725         }
1726 /* L700: */
1727     }
1728     i__1 = *ndim;
1729     for (nd = 1; nd <= i__1; ++nd) {
1730         crvnew[nd + *ncoeff * crvnew_dim1] = crvold[*ncoeff + nd *
1731                 crvold_dim1] * tabaux[*ncoeff - 1];
1732 /* L900: */
1733     }
1734
1735 /* ---------------------------- The end ---------------------------------
1736 */
1737
1738 L9999:
1739     if (*iercod > 0) {
1740         AdvApp2Var_SysBase::maermsg_("MMARCIN", iercod, 7L);
1741     }
1742     if (ibb >= 2) {
1743         AdvApp2Var_SysBase::mgsomsg_("MMARCIN", 7L);
1744     }
1745     return 0;
1746 } /* mmarcin_ */
1747
1748 //=======================================================================
1749 //function : mmatvec_
1750 //purpose  :
1751 //=======================================================================
1752 int mmatvec_(integer *nligne,
1753              integer *,//ncolon,
1754              integer *gposit,
1755              integer *,//gnstoc,
1756              doublereal *gmatri,
1757              doublereal *vecin,
1758              integer *deblig,
1759              doublereal *vecout,
1760              integer *iercod)
1761
1762 {
1763   /* System generated locals */
1764   integer i__1, i__2;
1765
1766   /* Local variables */
1767     logical ldbg;
1768   integer jmin, jmax, i__, j, k;
1769   doublereal somme;
1770   integer aux;
1771
1772
1773 /* ***********************************************************************
1774  */
1775
1776 /*     FUNCTION : */
1777 /*     ---------- */
1778 /*      Produce vector matrix in form of profile */
1779
1780
1781 /*     MOTS CLES : */
1782 /*     ----------- */
1783 /*      RESERVE, MATRIX, PRODUCT, VECTOR, PROFILE */
1784
1785 /*     INPUT ARGUMENTS : */
1786 /*     -------------------- */
1787 /*       NLIGNE : Line number of the matrix of constraints */
1788 /*       NCOLON : Number of column of the matrix of constraints */
1789 /*       GNSTOC: Number of coefficients in the profile of matrix GMATRI */
1790
1791 /*       GPOSIT: Table of positioning of terms of storage */
1792 /*               GPOSIT(1,I) contains the number of terms-1 on the line I */
1793 /*               in the profile of the matrix. */
1794 /*              GPOSIT(2,I) contains the index of storage of diagonal term*/
1795 /*               of line I */
1796 /*               GPOSIT(3,I) contains the index of column of the first term of */
1797 /*                           profile of line I */
1798 /*       GNSTOC: Number of coefficients in the profile of matrix */
1799 /*               GMATRI */
1800 /*       GMATRI : Matrix of constraints in form of profile */
1801 /*       VECIN  : Input vector */
1802 /*       DEBLIG : Line indexusing which the vector matrix is calculated */
1803 /**/
1804 /*     OUTPUT ARGUMENTS */
1805 /*     --------------------- */
1806 /*       VECOUT : VECTOR PRODUCT */
1807
1808 /*       IERCOD : ERROR CODE */
1809
1810
1811 /*     COMMONS USED : */
1812 /*     ------------------ */
1813
1814
1815 /*     REFERENCES CALLED : */
1816 /*     --------------------- */
1817
1818
1819 /*     DESCRIPTION/NOTES/LIMITATIONS : */
1820 /*     ----------------------------------- */
1821
1822 /* ***********************************************************************
1823  */
1824 /*                            DECLARATIONS */
1825 /* ***********************************************************************
1826  */
1827
1828
1829
1830 /* ***********************************************************************
1831  */
1832 /*                      INITIALISATIONS */
1833 /* ***********************************************************************
1834  */
1835
1836     /* Parameter adjustments */
1837     --vecout;
1838     gposit -= 4;
1839     --vecin;
1840     --gmatri;
1841
1842     /* Function Body */
1843     ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 2;
1844     if (ldbg) {
1845         AdvApp2Var_SysBase::mgenmsg_("MMATVEC", 7L);
1846     }
1847     *iercod = 0;
1848
1849 /* ***********************************************************************
1850  */
1851 /*                    Processing */
1852 /* ***********************************************************************
1853  */
1854     AdvApp2Var_SysBase::mvriraz_(nligne,
1855              &vecout[1]);
1856     i__1 = *nligne;
1857     for (i__ = *deblig; i__ <= i__1; ++i__) {
1858         somme = 0.;
1859         jmin = gposit[i__ * 3 + 3];
1860         jmax = gposit[i__ * 3 + 1] + gposit[i__ * 3 + 3] - 1;
1861         aux = gposit[i__ * 3 + 2] - gposit[i__ * 3 + 1] - jmin + 1;
1862         i__2 = jmax;
1863         for (j = jmin; j <= i__2; ++j) {
1864             k = j + aux;
1865             somme += gmatri[k] * vecin[j];
1866         }
1867         vecout[i__] = somme;
1868     }
1869
1870
1871
1872
1873
1874     goto L9999;
1875
1876 /* ***********************************************************************
1877  */
1878 /*                   ERROR PROCESSING */
1879 /* ***********************************************************************
1880  */
1881
1882
1883
1884
1885 /* ***********************************************************************
1886  */
1887 /*                   RETURN CALLING PROGRAM */
1888 /* ***********************************************************************
1889  */
1890
1891 L9999:
1892
1893 /* ___ DESALLOCATION, ... */
1894
1895     AdvApp2Var_SysBase::maermsg_("MMATVEC", iercod, 7L);
1896     if (ldbg) {
1897         AdvApp2Var_SysBase::mgsomsg_("MMATVEC", 7L);
1898     }
1899
1900  return 0 ;
1901 } /* mmatvec_ */
1902
1903 //=======================================================================
1904 //function : mmbulld_
1905 //purpose  :
1906 //=======================================================================
1907 int AdvApp2Var_MathBase::mmbulld_(integer *nbcoln,
1908                                   integer *nblign,
1909                                   doublereal *dtabtr,
1910                                   integer *numcle)
1911
1912 {
1913   /* System generated locals */
1914   integer dtabtr_dim1, dtabtr_offset, i__1, i__2;
1915
1916   /* Local variables */
1917   logical ldbg;
1918   doublereal daux;
1919   integer nite1, nite2, nchan, i1, i2;
1920
1921 /* ***********************************************************************
1922  */
1923
1924 /*     FUNCTION : */
1925 /*     ---------- */
1926 /*        Parsing of columns of a table of integers in increasing order */
1927 /*     KEYWORDS : */
1928 /*     ----------- */
1929 /*     POINT-ENTRY, PARSING */
1930 /*     INPUT ARGUMENTS : */
1931 /*     -------------------- */
1932 /*       - NBCOLN : Number of columns in the table */
1933 /*       - NBLIGN : Number of lines in the table */
1934 /*       - DTABTR : Table of integers to be parsed */
1935 /*       - NUMCLE : Position of the key on the column */
1936
1937 /*     OUTPUT ARGUMENTS : */
1938 /*     --------------------- */
1939 /*       - DTABTR : Parsed table */
1940
1941 /*     COMMONS USED : */
1942 /*     ------------------ */
1943
1944
1945 /*     REFERENCES CALLED : */
1946 /*     --------------------- */
1947
1948
1949 /*     DESCRIPTION/NOTES/LIMITATIONS : */
1950 /*     ----------------------------------- */
1951 /*     Particularly performant if the table is almost parsed */
1952 /*     In the opposite case it is better to use MVSHELD */
1953 /* ***********************************************************************
1954  */
1955
1956     /* Parameter adjustments */
1957     dtabtr_dim1 = *nblign;
1958     dtabtr_offset = dtabtr_dim1 + 1;
1959     dtabtr -= dtabtr_offset;
1960
1961     /* Function Body */
1962     ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 2;
1963     if (ldbg) {
1964         AdvApp2Var_SysBase::mgenmsg_("MMBULLD", 7L);
1965     }
1966     nchan = 1;
1967     nite1 = *nbcoln;
1968     nite2 = 2;
1969
1970 /* ***********************************************************************
1971  */
1972 /*                     PROCESSING */
1973 /* ***********************************************************************
1974  */
1975
1976 /* ---->ALGORITHM in N^2 / 2 additional iteration */
1977
1978     while(nchan != 0) {
1979
1980 /* ----> Parsing from left to the right */
1981
1982         nchan = 0;
1983         i__1 = nite1;
1984         for (i1 = nite2; i1 <= i__1; ++i1) {
1985             if (dtabtr[*numcle + i1 * dtabtr_dim1] < dtabtr[*numcle + (i1 - 1)
1986                      * dtabtr_dim1]) {
1987                 i__2 = *nblign;
1988                 for (i2 = 1; i2 <= i__2; ++i2) {
1989                     daux = dtabtr[i2 + (i1 - 1) * dtabtr_dim1];
1990                     dtabtr[i2 + (i1 - 1) * dtabtr_dim1] = dtabtr[i2 + i1 *
1991                             dtabtr_dim1];
1992                     dtabtr[i2 + i1 * dtabtr_dim1] = daux;
1993                 }
1994                 if (nchan == 0) {
1995                     nchan = 1;
1996                 }
1997             }
1998         }
1999         --nite1;
2000
2001 /* ----> Parsing from right to the left */
2002
2003         if (nchan != 0) {
2004             nchan = 0;
2005             i__1 = nite2;
2006             for (i1 = nite1; i1 >= i__1; --i1) {
2007                 if (dtabtr[*numcle + i1 * dtabtr_dim1] < dtabtr[*numcle + (i1
2008                         - 1) * dtabtr_dim1]) {
2009                     i__2 = *nblign;
2010                     for (i2 = 1; i2 <= i__2; ++i2) {
2011                         daux = dtabtr[i2 + (i1 - 1) * dtabtr_dim1];
2012                         dtabtr[i2 + (i1 - 1) * dtabtr_dim1] = dtabtr[i2 + i1 *
2013                                  dtabtr_dim1];
2014                         dtabtr[i2 + i1 * dtabtr_dim1] = daux;
2015                     }
2016                     if (nchan == 0) {
2017                         nchan = 1;
2018                     }
2019                 }
2020             }
2021             ++nite2;
2022         }
2023     }
2024
2025
2026     goto L9999;
2027
2028 /* ***********************************************************************
2029  */
2030 /*                   ERROR PROCESSING */
2031 /* ***********************************************************************
2032  */
2033
2034 /* ----> No errors at calling functions, only tests and loops. */
2035
2036 /* ***********************************************************************
2037  */
2038 /*                   RETURN CALLING PROGRAM */
2039 /* ***********************************************************************
2040  */
2041
2042 L9999:
2043
2044     if (ldbg) {
2045         AdvApp2Var_SysBase::mgsomsg_("MMBULLD", 7L);
2046     }
2047
2048  return 0 ;
2049 } /* mmbulld_ */
2050
2051
2052 //=======================================================================
2053 //function : AdvApp2Var_MathBase::mmcdriv_
2054 //purpose  :
2055 //=======================================================================
2056 int AdvApp2Var_MathBase::mmcdriv_(integer *ndimen,
2057                                   integer *ncoeff,
2058                                   doublereal *courbe,
2059                                   integer *ideriv,
2060                                   integer *ncofdv,
2061                                   doublereal *crvdrv)
2062
2063
2064 {
2065   /* System generated locals */
2066   integer courbe_dim1, courbe_offset, crvdrv_dim1, crvdrv_offset, i__1,
2067   i__2;
2068
2069   /* Local variables */
2070   integer i__, j, k;
2071   doublereal mfactk, bid;
2072
2073
2074 /* ***********************************************************************
2075  */
2076
2077 /*     FUNCTION : */
2078 /*     ---------- */
2079 /*     Calculate matrix of a derivate curve of order IDERIV. */
2080 /*     with input parameters other than output parameters. */
2081
2082
2083 /*     KEYWORDS : */
2084 /*     ----------- */
2085 /*     COEFFICIENTS,CURVE,DERIVATE I-EME. */
2086
2087 /*     INPUT ARGUMENTS : */
2088 /*     ------------------ */
2089 /*   NDIMEN  : Space dimension (2 or 3 in general) */
2090 /*   NCOEFF  : Degree +1 of the curve. */
2091 /*   COURBE  : Table of coefficients of the curve. */
2092 /*   IDERIV  : Required order of derivation : 1=1st derivate, etc... */
2093
2094 /*     OUTPUT ARGUMENTS : */
2095 /*     ------------------- */
2096 /*   NCOFDV  : Degree +1 of the derivative of order IDERIV of the curve. */
2097 /*   CRVDRV  : Table of coefficients of the derivative of order IDERIV */
2098 /*            of the curve. */
2099
2100 /*     COMMONS USED   : */
2101 /*     ---------------- */
2102
2103 /*     REFERENCES CALLED   : */
2104 /*     ----------------------- */
2105
2106 /*     DESCRIPTION/NOTES/LIMITATIONS : */
2107 /*     ----------------------------------- */
2108
2109 /* ---> It is possible to take as output argument the curve */
2110 /*     and the number of coeff passed at input by making : */
2111 /*        CALL MMCDRIV(NDIMEN,NCOEFF,COURBE,IDERIV,NCOEFF,COURBE). */
2112 /*     After this call, NCOEFF does the number of coeff of the derived */
2113 /*     curve the coefficients which of are stored in CURVE. */
2114 /*     Attention to the coefficients of CURVE of rank superior to */
2115 /*     NCOEFF : they are not set to zero. */
2116
2117 /* ---> Algorithm : */
2118 /*     The code below was written basing on the following algorithm:
2119 */
2120
2121 /*     Let P(t) = a1 + a2*t + ... an*t**n. Derivate of order k of P */
2122 /*     (containing n-k coefficients) is calculated as follows : */
2123
2124 /*       Pk(t) = a(k+1)*CNP(k,k)*k! */
2125 /*             + a(k+2)*CNP(k+1,k)*k! * t */
2126 /*             . */
2127 /*             . */
2128 /*             . */
2129 /*             + a(n)*CNP(n-1,k)*k! * t**(n-k-1). */
2130 /* ***********************************************************************
2131  */
2132
2133
2134 /* -------------- Case when the order of derivative is  -------------------
2135 */
2136 /* ---------------- greater than the degree of the curve ---------------------
2137 */
2138
2139 /* **********************************************************************
2140 */
2141
2142 /*     FUNCTION : */
2143 /*     ---------- */
2144 /*      Serves to provide the coefficients of binome (Pascal's triangle). */
2145
2146 /*     KEYWORDS : */
2147 /*     ----------- */
2148 /*      Binomial coeff from 0 to 60. read only . init par block data */
2149
2150 /*     DEMSCRIPTION/NOTES/LIMITATIONS : */
2151 /*     ----------------------------------- */
2152 /*     Binomial coefficients form a triangular matrix. */
2153 /*     This matrix is completed in table CNP by its transposition. */
2154 /*     So: CNP(I,J) = CNP(J,I) for I and J = 0, ..., 60. */
2155
2156 /*     Initialization is done by block-data MMLLL09.RES, */
2157 /*     created by program MQINICNP.FOR). */
2158 /* **********************************************************************
2159 */
2160
2161
2162
2163 /* ***********************************************************************
2164  */
2165
2166     /* Parameter adjustments */
2167     crvdrv_dim1 = *ndimen;
2168     crvdrv_offset = crvdrv_dim1 + 1;
2169     crvdrv -= crvdrv_offset;
2170     courbe_dim1 = *ndimen;
2171     courbe_offset = courbe_dim1 + 1;
2172     courbe -= courbe_offset;
2173
2174     /* Function Body */
2175     if (*ideriv >= *ncoeff) {
2176         i__1 = *ndimen;
2177         for (i__ = 1; i__ <= i__1; ++i__) {
2178             crvdrv[i__ + crvdrv_dim1] = 0.;
2179 /* L10: */
2180         }
2181         *ncofdv = 1;
2182         goto L9999;
2183     }
2184 /* **********************************************************************
2185 */
2186 /*                        General processing */
2187 /* **********************************************************************
2188 */
2189 /* --------------------- Calculation of Factorial(IDERIV) ------------------
2190 */
2191
2192     k = *ideriv;
2193     mfactk = 1.;
2194     i__1 = k;
2195     for (i__ = 2; i__ <= i__1; ++i__) {
2196         mfactk *= i__;
2197 /* L50: */
2198     }
2199
2200 /* ------------ Calculation of coeff of the derived of order IDERIV ----------
2201 */
2202 /* ---> Attention :  coefficient binomial C(n,m) is represented in */
2203 /*                 MCCNP by CNP(N+1,M+1). */
2204
2205     i__1 = *ncoeff;
2206     for (j = k + 1; j <= i__1; ++j) {
2207         bid = mmcmcnp_.cnp[j - 1 + k * 61] * mfactk;
2208         i__2 = *ndimen;
2209         for (i__ = 1; i__ <= i__2; ++i__) {
2210             crvdrv[i__ + (j - k) * crvdrv_dim1] = bid * courbe[i__ + j *
2211                     courbe_dim1];
2212 /* L200: */
2213         }
2214 /* L100: */
2215     }
2216
2217     *ncofdv = *ncoeff - *ideriv;
2218
2219 /* -------------------------------- The end -----------------------------
2220 */
2221
2222 L9999:
2223     return 0;
2224 } /* mmcdriv_ */
2225
2226 //=======================================================================
2227 //function : AdvApp2Var_MathBase::mmcglc1_
2228 //purpose  :
2229 //=======================================================================
2230 int AdvApp2Var_MathBase::mmcglc1_(integer *ndimax,
2231                                   integer *ndimen,
2232                                   integer *ncoeff,
2233                                   doublereal *courbe,
2234                                   doublereal *tdebut,
2235                                   doublereal *tfinal,
2236                                   doublereal *epsiln,
2237                                   doublereal *xlongc,
2238                                   doublereal *erreur,
2239                                   integer *iercod)
2240
2241
2242 {
2243   /* System generated locals */
2244   integer courbe_dim1, courbe_offset, i__1;
2245   doublereal d__1;
2246
2247   /* Local variables */
2248   integer ndec;
2249   doublereal tdeb, tfin;
2250   integer iter;
2251   doublereal oldso = 0.;
2252   integer itmax;
2253   doublereal sottc;
2254   integer kk, ibb;
2255   doublereal dif, pas;
2256   doublereal som;
2257
2258
2259 /* ***********************************************************************
2260  */
2261
2262 /*     FUNCTION : */
2263 /*     ---------- */
2264 /*      Allows calculating the length of an arc of curve POLYNOMIAL */
2265 /*      on an interval [A,B]. */
2266
2267 /*     KEYWORDS : */
2268 /*     ----------- */
2269 /*        LENGTH,CURVE,GAUSS,PRIVATE. */
2270
2271 /*     INPUT ARGUMENTS : */
2272 /*     ------------------ */
2273 /*      NDIMAX : Max. number of lines of tables */
2274 /*               (i.e. max. nb of polynoms). */
2275 /*      NDIMEN : Dimension of the space (nb of polynoms). */
2276 /*      NCOEFF : Nb of coefficients of the polynom. This is degree + 1.
2277 */
2278 /*      COURBE(NDIMAX,NCOEFF) : Coefficients of the curve. */
2279 /*      TDEBUT : Lower limit of the interval of integration for  */
2280 /*               length calculation. */
2281 /*      TFINAL : Upper limit of the interval of integration for */
2282 /*               length calculation. */
2283 /*      EPSILN : REQIRED precision for length calculation. */
2284
2285 /*     OUTPUT ARGUMENTS : */
2286 /*     ------------------- */
2287 /*      XLONGC : Length of the arc of curve */
2288 /*      ERREUR : Precision OBTAINED for the length calculation. */
2289 /*      IERCOD : Error code, 0 OK, >0 Serious error. */
2290 /*               = 1 Too much iterations, the best calculated resultat */
2291 /*                   (is almost ERROR) */
2292 /*               = 2 Pb MMLONCV (no result) */
2293 /*               = 3 NDIM or NCOEFF invalid (no result) */
2294
2295 /*     COMMONS USED : */
2296 /*     ---------------- */
2297
2298 /*     REFERENCES CALLED : */
2299 /*     ----------------------- */
2300
2301 /*     DESCRIPTION/NOTES/LIMITATIONS : */
2302 /*     ----------------------------------- */
2303 /*      The polynom is actually a set of polynoms with */
2304 /*      coefficients arranged in a table of 2 indices, */
2305 /*      each line relative to the polynom. */
2306 /*      The polynom is defined by these coefficients ordered */
2307 /*      by increasing power of the variable. */
2308 /*      All polynoms have the same number of coefficients (the */
2309 /*      same degree). */
2310
2311 /*      This program cancels and replaces LENGCV, MLONGC and MLENCV. */
2312
2313 /*      ATTENTION : if TDEBUT > TFINAL, the length is NEGATIVE. */
2314
2315 /* > */
2316 /* ***********************************************************************
2317  */
2318
2319 /*   Name of the routine */
2320
2321
2322 /* ------------------------ General Initialization ---------------------
2323 */
2324
2325     /* Parameter adjustments */
2326     courbe_dim1 = *ndimax;
2327     courbe_offset = courbe_dim1 + 1;
2328     courbe -= courbe_offset;
2329
2330     /* Function Body */
2331     ibb = AdvApp2Var_SysBase::mnfndeb_();
2332     if (ibb >= 2) {
2333         AdvApp2Var_SysBase::mgenmsg_("MMCGLC1", 7L);
2334     }
2335
2336     *iercod = 0;
2337     *xlongc = 0.;
2338     *erreur = 0.;
2339
2340 /* ------ Test of equity of limits */
2341
2342     if (*tdebut == *tfinal) {
2343         *iercod = 0;
2344         goto L9999;
2345     }
2346
2347 /* ------ Test of the dimension and the number of coefficients */
2348
2349     if (*ndimen <= 0 || *ncoeff <= 0) {
2350         goto L9003;
2351     }
2352
2353 /* ----- Nb of current cutting, nb of iteration, */
2354 /*       max nb of iterations */
2355
2356     ndec = 1;
2357     iter = 1;
2358
2359     itmax = 13;
2360
2361 /* ------ Variation of the nb of intervals */
2362 /*       Multiplied by 2 at each iteration */
2363
2364 L5000:
2365     pas = (*tfinal - *tdebut) / ndec;
2366     sottc = 0.;
2367
2368 /* ------ Loop on all current NDEC intervals */
2369
2370     i__1 = ndec;
2371     for (kk = 1; kk <= i__1; ++kk) {
2372
2373 /* ------ Limits of the current integration interval */
2374
2375         tdeb = *tdebut + (kk - 1) * pas;
2376         tfin = tdeb + pas;
2377         mmloncv_(ndimax, ndimen, ncoeff, &courbe[courbe_offset], &tdeb, &tfin,
2378                  &som, iercod);
2379         if (*iercod > 0) {
2380             goto L9002;
2381         }
2382
2383         sottc += som;
2384
2385 /* L100: */
2386     }
2387
2388
2389 /* ----------------- Test of the maximum number of iterations ------------
2390 */
2391
2392 /*  Test if passes at least once ** */
2393
2394     if (iter == 1) {
2395         oldso = sottc;
2396         ndec <<= 1;
2397         ++iter;
2398         goto L5000;
2399     } else {
2400
2401 /* ------ Take into account DIF - Test of convergence */
2402
2403         ++iter;
2404         dif = (d__1 = sottc - oldso, advapp_abs(d__1));
2405
2406 /* ------ If DIF is OK, leave..., otherwise: */
2407
2408         if (dif > *epsiln) {
2409
2410 /* ------ If nb iteration exceeded, leave */
2411
2412             if (iter > itmax) {
2413                 *iercod = 1;
2414                 goto L9000;
2415             } else {
2416
2417 /* ------ Otherwise continue by cutting the initial interval.
2418  */
2419
2420                 oldso = sottc;
2421                 ndec <<= 1;
2422                 goto L5000;
2423             }
2424         }
2425     }
2426
2427 /* ------------------------------ THE END -------------------------------
2428 */
2429
2430 L9000:
2431     *xlongc = sottc;
2432     *erreur = dif;
2433     goto L9999;
2434
2435 /* ---> PB in MMLONCV */
2436
2437 L9002:
2438     *iercod = 2;
2439     goto L9999;
2440
2441 /* ---> NCOEFF or NDIM invalid. */
2442
2443 L9003:
2444     *iercod = 3;
2445     goto L9999;
2446
2447 L9999:
2448     if (*iercod > 0) {
2449         AdvApp2Var_SysBase::maermsg_("MMCGLC1", iercod, 7L);
2450     }
2451     if (ibb >= 2) {
2452         AdvApp2Var_SysBase::mgsomsg_("MMCGLC1", 7L);
2453     }
2454     return 0;
2455 } /* mmcglc1_ */
2456
2457 //=======================================================================
2458 //function : mmchole_
2459 //purpose  :
2460 //=======================================================================
2461 int mmchole_(integer *,//mxcoef,
2462              integer *dimens,
2463              doublereal *amatri,
2464              integer *aposit,
2465              integer *posuiv,
2466              doublereal *chomat,
2467              integer *iercod)
2468
2469 {
2470   /* System generated locals */
2471   integer i__1, i__2, i__3;
2472   doublereal d__1;
2473
2474   /* Builtin functions */
2475   //double sqrt();
2476
2477     /* Local variables */
2478   logical ldbg;
2479   integer kmin, i__, j, k;
2480   doublereal somme;
2481   integer ptini, ptcou;
2482
2483
2484 /* ***********************************************************************
2485  */
2486
2487 /*     FUNCTION : */
2488 /*     ----------                                                  T */
2489 /*     Produce decomposition of choleski of matrix A in S.S */
2490 /*     Calculate inferior triangular matrix S. */
2491
2492 /*     KEYWORDS : */
2493 /*     ----------- */
2494 /*     RESOLUTION, MFACTORISATION, MATRIX_PROFILE, CHOLESKI */
2495
2496 /*     INPUT ARGUMENTS : */
2497 /*     -------------------- */
2498 /*     MXCOEF : Max number of terms in the hessian profile */
2499 /*     DIMENS : Dimension of the problem */
2500 /*     AMATRI(MXCOEF) : Coefficients of the matrix profile */
2501 /*        APOSIT(1,*) : Distance diagonal-left extremity of the line
2502 */
2503 /*        APOSIT(2,*) : Position of diagonal terms in HESSIE */
2504 /*     POSUIV(MXCOEF) :  first line inferior not out of profile */
2505
2506 /*     OUTPUT ARGUMENTS : */
2507 /*     --------------------- */
2508 /*      CHOMAT(MXCOEF) : Inferior triangular matrix preserving the */
2509 /*                       profile of AMATRI. */
2510 /*      IERCOD : error code */
2511 /*               = 0 : ok */
2512 /*               = 1 : non-defined positive matrix */
2513
2514 /*     COMMONS USED : */
2515 /*     ------------------ */
2516
2517 /*      .Neant. */
2518
2519 /*     REFERENCES CALLED   : */
2520 /*     ---------------------- */
2521
2522 /*     DESCRIPTION/NOTES/LIMITATIONS : */
2523 /*     ----------------------------------- */
2524 /*     DEBUG LEVEL = 4 */
2525 /* ***********************************************************************
2526  */
2527 /*                            DECLARATIONS */
2528 /* ***********************************************************************
2529  */
2530
2531
2532
2533 /* ***********************************************************************
2534  */
2535 /*                      INITIALISATIONS */
2536 /* ***********************************************************************
2537  */
2538
2539     /* Parameter adjustments */
2540     --chomat;
2541     --posuiv;
2542     --amatri;
2543     aposit -= 3;
2544
2545     /* Function Body */
2546     ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 4;
2547     if (ldbg) {
2548         AdvApp2Var_SysBase::mgenmsg_("MMCHOLE", 7L);
2549     }
2550     *iercod = 0;
2551
2552 /* ***********************************************************************
2553  */
2554 /*                    PROCESSING */
2555 /* ***********************************************************************
2556  */
2557
2558     i__1 = *dimens;
2559     for (j = 1; j <= i__1; ++j) {
2560
2561         ptini = aposit[(j << 1) + 2];
2562
2563         somme = 0.;
2564         i__2 = ptini - 1;
2565         for (k = ptini - aposit[(j << 1) + 1]; k <= i__2; ++k) {
2566 /* Computing 2nd power */
2567             d__1 = chomat[k];
2568             somme += d__1 * d__1;
2569         }
2570
2571         if (amatri[ptini] - somme < 1e-32) {
2572             goto L9101;
2573         }
2574         chomat[ptini] = sqrt(amatri[ptini] - somme);
2575
2576         ptcou = ptini;
2577
2578         while(posuiv[ptcou] > 0) {
2579
2580             i__ = posuiv[ptcou];
2581             ptcou = aposit[(i__ << 1) + 2] - (i__ - j);
2582
2583 /*           Calculate the sum of S  .S   for k =1 a j-1 */
2584 /*                               ik  jk */
2585             somme = 0.;
2586 /* Computing MAX */
2587             i__2 = i__ - aposit[(i__ << 1) + 1], i__3 = j - aposit[(j << 1) +
2588                     1];
2589             kmin = advapp_max(i__2,i__3);
2590             i__2 = j - 1;
2591             for (k = kmin; k <= i__2; ++k) {
2592                 somme += chomat[aposit[(i__ << 1) + 2] - (i__ - k)] * chomat[
2593                         aposit[(j << 1) + 2] - (j - k)];
2594             }
2595
2596             chomat[ptcou] = (amatri[ptcou] - somme) / chomat[ptini];
2597         }
2598     }
2599
2600     goto L9999;
2601
2602 /* ***********************************************************************
2603  */
2604 /*                   ERROR PROCESSING */
2605 /* ***********************************************************************
2606  */
2607
2608 L9101:
2609     *iercod = 1;
2610     goto L9999;
2611
2612 /* ***********************************************************************
2613  */
2614 /*                  RETURN CALLING PROGRAM */
2615 /* ***********************************************************************
2616  */
2617
2618 L9999:
2619
2620     AdvApp2Var_SysBase::maermsg_("MMCHOLE", iercod, 7L);
2621     if (ldbg) {
2622         AdvApp2Var_SysBase::mgsomsg_("MMCHOLE", 7L);
2623     }
2624
2625  return 0 ;
2626 } /* mmchole_ */
2627
2628 //=======================================================================
2629 //function : AdvApp2Var_MathBase::mmcvctx_
2630 //purpose  :
2631 //=======================================================================
2632 int AdvApp2Var_MathBase::mmcvctx_(integer *ndimen,
2633                                   integer *ncofmx,
2634                                   integer *nderiv,
2635                                   doublereal *ctrtes,
2636                                   doublereal *crvres,
2637                                   doublereal *tabaux,
2638                                   doublereal *xmatri,
2639                                   integer *iercod)
2640
2641 {
2642   /* System generated locals */
2643   integer ctrtes_dim1, ctrtes_offset, crvres_dim1, crvres_offset,
2644   xmatri_dim1, xmatri_offset, tabaux_dim1, tabaux_offset, i__1,
2645   i__2;
2646
2647   /* Local variables */
2648   integer moup1, nordr;
2649   integer nd;
2650   integer ibb, ncf, ndv;
2651   doublereal eps1;
2652
2653
2654 /* ***********************************************************************
2655  */
2656
2657 /*     FUNCTION : */
2658 /*     ---------- */
2659 /*        Calculate a polynomial curve checking the  */
2660 /*        passage constraints (interpolation) */
2661 /*        from first derivatives, etc... to extremities. */
2662 /*        Parameters at the extremities are supposed to be -1 and 1. */
2663
2664 /*     KEYWORDS : */
2665 /*     ----------- */
2666 /*     ALL, AB_SPECIFI::CONSTRAINTS&,INTERPOLATION,&CURVE */
2667
2668 /*     INPUT ARGUMENTS : */
2669 /*     ------------------ */
2670 /*     NDIMEN : Space Dimension. */
2671 /*     NCOFMX : Nb of coeff. of curve CRVRES on each */
2672 /*              dimension. */
2673 /*     NDERIV : Order of constraint with derivatives : */
2674 /*              0 --> interpolation simple. */
2675 /*              1 --> interpolation+constraints with 1st. */
2676 /*              2 --> cas (0)+ (1) +   "         "   2nd derivatives. */
2677 /*                 etc... */
2678 /*     CTRTES : Table of constraints. */
2679 /*              CTRTES(*,1,*) = contraints at -1. */
2680 /*              CTRTES(*,2,*) = contraints at  1. */
2681
2682 /*     OUTPUT ARGUMENTS : */
2683 /*     ------------------- */
2684 /*     CRVRES : Resulting curve defined on (-1,1). */
2685 /*     TABAUX : Auxilliary matrix. */
2686 /*     XMATRI : Auxilliary matrix. */
2687
2688 /*     COMMONS UTILISES   : */
2689 /*     ---------------- */
2690
2691 /*      .Neant. */
2692
2693 /*     REFERENCES CALLED   : */
2694 /*     ---------------------- */
2695 /*     Type  Name */
2696 /*           MAERMSG         R*8  DFLOAT              MGENMSG */
2697 /*           MGSOMSG              MMEPS1               MMRSLW */
2698 /*      I*4  MNFNDEB */
2699
2700 /*     DESCRIPTION/NOTES/LIMITATIONS : */
2701 /*     ----------------------------------- */
2702 /*        The polynom (or the curve) is calculated by solving a */
2703 /*        system of linear equations. If the imposed degree is great */
2704 /*        it is preferable to call a routine based on */
2705 /*        Lagrange or Hermite interpolation depending on the case. */
2706 /*        (for a high degree the matrix of the system can be badly */
2707 /*        conditionned). */
2708 /*        This routine returns a curve defined in (-1,1). */
2709 /*        In general case, it is necessary to use MCVCTG. */
2710 /* > */
2711 /* ***********************************************************************
2712  */
2713
2714 /*   Name of the routine */
2715
2716
2717     /* Parameter adjustments */
2718     crvres_dim1 = *ncofmx;
2719     crvres_offset = crvres_dim1 + 1;
2720     crvres -= crvres_offset;
2721     xmatri_dim1 = *nderiv + 1;
2722     xmatri_offset = xmatri_dim1 + 1;
2723     xmatri -= xmatri_offset;
2724     tabaux_dim1 = *nderiv + 1 + *ndimen;
2725     tabaux_offset = tabaux_dim1 + 1;
2726     tabaux -= tabaux_offset;
2727     ctrtes_dim1 = *ndimen;
2728     ctrtes_offset = ctrtes_dim1 * 3 + 1;
2729     ctrtes -= ctrtes_offset;
2730
2731     /* Function Body */
2732     ibb = AdvApp2Var_SysBase::mnfndeb_();
2733     if (ibb >= 3) {
2734         AdvApp2Var_SysBase::mgenmsg_("MMCVCTX", 7L);
2735     }
2736 /*   Precision. */
2737     AdvApp2Var_MathBase::mmeps1_(&eps1);
2738
2739 /* ****************** CALCULATION OF EVEN COEFFICIENTS *********************
2740 */
2741 /* ------------------------- Initialization -----------------------------
2742 */
2743
2744     nordr = *nderiv + 1;
2745     i__1 = nordr;
2746     for (ncf = 1; ncf <= i__1; ++ncf) {
2747         tabaux[ncf + tabaux_dim1] = 1.;
2748 /* L100: */
2749     }
2750
2751 /* ---------------- Calculation of terms corresponding to derivatives -------
2752 */
2753
2754     i__1 = nordr;
2755     for (ndv = 2; ndv <= i__1; ++ndv) {
2756         i__2 = nordr;
2757         for (ncf = 1; ncf <= i__2; ++ncf) {
2758             tabaux[ncf + ndv * tabaux_dim1] = tabaux[ncf + (ndv - 1) *
2759                     tabaux_dim1] * (doublereal) ((ncf << 1) - ndv);
2760 /* L300: */
2761         }
2762 /* L200: */
2763     }
2764
2765 /* ------------------ Writing the second member -----------------------
2766 */
2767
2768     moup1 = 1;
2769     i__1 = nordr;
2770     for (ndv = 1; ndv <= i__1; ++ndv) {
2771         i__2 = *ndimen;
2772         for (nd = 1; nd <= i__2; ++nd) {
2773             tabaux[nordr + nd + ndv * tabaux_dim1] = (ctrtes[nd + ((ndv << 1)
2774                     + 2) * ctrtes_dim1] + moup1 * ctrtes[nd + ((ndv << 1) + 1)
2775                      * ctrtes_dim1]) / 2.;
2776 /* L500: */
2777         }
2778         moup1 = -moup1;
2779 /* L400: */
2780     }
2781
2782 /* -------------------- Resolution of the system ---------------------------
2783 */
2784
2785     mmrslw_(&nordr, &nordr, ndimen, &eps1, &tabaux[tabaux_offset], &xmatri[
2786             xmatri_offset], iercod);
2787     if (*iercod > 0) {
2788         goto L9999;
2789     }
2790     i__1 = *ndimen;
2791     for (nd = 1; nd <= i__1; ++nd) {
2792         i__2 = nordr;
2793         for (ncf = 1; ncf <= i__2; ++ncf) {
2794             crvres[(ncf << 1) - 1 + nd * crvres_dim1] = xmatri[ncf + nd *
2795                     xmatri_dim1];
2796 /* L700: */
2797         }
2798 /* L600: */
2799     }
2800
2801 /* ***************** CALCULATION OF UNEVEN COEFFICIENTS ********************
2802 */
2803 /* ------------------------- Initialization -----------------------------
2804 */
2805
2806
2807     i__1 = nordr;
2808     for (ncf = 1; ncf <= i__1; ++ncf) {
2809         tabaux[ncf + tabaux_dim1] = 1.;
2810 /* L1100: */
2811     }
2812
2813 /* ---------------- Calculation of terms corresponding to derivatives -------
2814 */
2815
2816     i__1 = nordr;
2817     for (ndv = 2; ndv <= i__1; ++ndv) {
2818         i__2 = nordr;
2819         for (ncf = 1; ncf <= i__2; ++ncf) {
2820             tabaux[ncf + ndv * tabaux_dim1] = tabaux[ncf + (ndv - 1) *
2821                     tabaux_dim1] * (doublereal) ((ncf << 1) - ndv + 1);
2822 /* L1300: */
2823         }
2824 /* L1200: */
2825     }
2826
2827 /* ------------------ Writing of the second member -----------------------
2828 */
2829
2830     moup1 = -1;
2831     i__1 = nordr;
2832     for (ndv = 1; ndv <= i__1; ++ndv) {
2833         i__2 = *ndimen;
2834         for (nd = 1; nd <= i__2; ++nd) {
2835             tabaux[nordr + nd + ndv * tabaux_dim1] = (ctrtes[nd + ((ndv << 1)
2836                     + 2) * ctrtes_dim1] + moup1 * ctrtes[nd + ((ndv << 1) + 1)
2837                      * ctrtes_dim1]) / 2.;
2838 /* L1500: */
2839         }
2840         moup1 = -moup1;
2841 /* L1400: */
2842     }
2843
2844 /* -------------------- Solution of the system ---------------------------
2845 */
2846
2847     mmrslw_(&nordr, &nordr, ndimen, &eps1, &tabaux[tabaux_offset], &xmatri[
2848             xmatri_offset], iercod);
2849     if (*iercod > 0) {
2850         goto L9999;
2851     }
2852     i__1 = *ndimen;
2853     for (nd = 1; nd <= i__1; ++nd) {
2854         i__2 = nordr;
2855         for (ncf = 1; ncf <= i__2; ++ncf) {
2856             crvres[(ncf << 1) + nd * crvres_dim1] = xmatri[ncf + nd *
2857                     xmatri_dim1];
2858 /* L1700: */
2859         }
2860 /* L1600: */
2861     }
2862
2863 /* --------------------------- The end ----------------------------------
2864 */
2865
2866 L9999:
2867     if (*iercod != 0) {
2868         AdvApp2Var_SysBase::maermsg_("MMCVCTX", iercod, 7L);
2869     }
2870     if (ibb >= 3) {
2871         AdvApp2Var_SysBase::mgsomsg_("MMCVCTX", 7L);
2872     }
2873
2874  return 0 ;
2875 } /* mmcvctx_ */
2876
2877 //=======================================================================
2878 //function : AdvApp2Var_MathBase::mmcvinv_
2879 //purpose  :
2880 //=======================================================================
2881  int AdvApp2Var_MathBase::mmcvinv_(integer *ndimax,
2882                             integer *ncoef,
2883                             integer *ndim,
2884                             doublereal *curveo,
2885                             doublereal *curve)
2886
2887 {
2888   /* Initialized data */
2889
2890   static char nomprg[8+1] = "MMCVINV ";
2891
2892   /* System generated locals */
2893   integer curve_dim1, curve_offset, curveo_dim1, curveo_offset, i__1, i__2;
2894
2895   /* Local variables */
2896   integer i__, nd, ibb;
2897
2898
2899 /* ***********************************************************************
2900  */
2901
2902 /*     FUNCTION : */
2903 /*     ---------- */
2904 /*        Inversion of arguments of the final curve. */
2905
2906 /*     KEYWORDS : */
2907 /*     ----------- */
2908 /*        SMOOTHING,CURVE */
2909
2910
2911 /*     INPUT ARGUMENTS : */
2912 /*     ------------------ */
2913
2914 /*        NDIM: Space Dimension. */
2915 /*        NCOEF: Degree of the polynom. */
2916 /*        CURVEO: The curve before inversion. */
2917
2918 /*     OUTPUT ARGUMENTS : */
2919 /*     ------------------- */
2920 /*        CURVE: The curve after inversion. */
2921
2922 /*     COMMONS USED : */
2923 /*     ---------------- */
2924 /*     REFERENCES APPELEES   : */
2925 /*     ----------------------- */
2926 /*     DESCRIPTION/NOTES/LIMITATIONS : */
2927 /*     ----------------------------------- */
2928 /* ***********************************************************************
2929  */
2930
2931 /*   The name of the routine */
2932     /* Parameter adjustments */
2933     curve_dim1 = *ndimax;
2934     curve_offset = curve_dim1 + 1;
2935     curve -= curve_offset;
2936     curveo_dim1 = *ncoef;
2937     curveo_offset = curveo_dim1 + 1;
2938     curveo -= curveo_offset;
2939
2940     /* Function Body */
2941
2942     ibb = AdvApp2Var_SysBase::mnfndeb_();
2943     if (ibb >= 2) {
2944         AdvApp2Var_SysBase::mgenmsg_(nomprg, 6L);
2945     }
2946
2947     i__1 = *ncoef;
2948     for (i__ = 1; i__ <= i__1; ++i__) {
2949         i__2 = *ndim;
2950         for (nd = 1; nd <= i__2; ++nd) {
2951             curve[nd + i__ * curve_dim1] = curveo[i__ + nd * curveo_dim1];
2952 /* L300: */
2953         }
2954     }
2955
2956 /* L9999: */
2957     return 0;
2958 } /* mmcvinv_ */
2959
2960 //=======================================================================
2961 //function : mmcvstd_
2962 //purpose  :
2963 //=======================================================================
2964 int mmcvstd_(integer *ncofmx,
2965              integer *ndimax,
2966              integer *ncoeff,
2967              integer *ndimen,
2968              doublereal *crvcan,
2969              doublereal *courbe)
2970
2971 {
2972   /* System generated locals */
2973   integer courbe_dim1, crvcan_dim1, crvcan_offset, i__1, i__2, i__3;
2974
2975   /* Local variables */
2976   integer ndeg, i__, j, j1, nd, ibb;
2977   doublereal bid;
2978
2979
2980 /* ***********************************************************************
2981  */
2982
2983 /*     FUNCTION : */
2984 /*     ---------- */
2985 /*        Transform curve defined between [-1,1] into [0,1]. */
2986
2987 /*     KEYWORDS : */
2988 /*     ----------- */
2989 /*        LIMITATION,RESTRICTION,CURVE */
2990
2991 /*     INPUT ARGUMENTS : */
2992 /*     ------------------ */
2993 /*        NDIMAX : Dimension of the space. */
2994 /*        NDIMEN : Dimension of the curve. */
2995 /*        NCOEFF : Degree of the curve. */
2996 /*        CRVCAN(NCOFMX,NDIMEN): The curve is defined at the interval [-1,1]. */
2997
2998 /*     OUTPUT ARGUMENTS : */
2999 /*     ------------------- */
3000 /*        CURVE(NDIMAX,NCOEFF): Curve defined at the interval [0,1]. */
3001
3002 /*     COMMONS USED   : */
3003 /*     ---------------- */
3004
3005 /*     REFERENCES CALLED   : */
3006 /*     ----------------------- */
3007
3008 /*     DESCRIPTION/NOTES/LIMITATIONS : */
3009 /*     ----------------------------------- */
3010 /* > */
3011 /* ***********************************************************************
3012  */
3013
3014 /*   Name of the program. */
3015
3016
3017 /* **********************************************************************
3018 */
3019
3020 /*     FUNCTION : */
3021 /*     ---------- */
3022 /*      Provides binomial coefficients (Pascal triangle). */
3023
3024 /*     KEYWORDS : */
3025 /*     ----------- */
3026 /*      Binomial coefficient from 0 to 60. read only . init by block data */
3027
3028 /*     DEMSCRIPTION/NOTES/LIMITATIONS : */
3029 /*     ----------------------------------- */
3030 /*     Binomial coefficients form a triangular matrix. */
3031 /*     This matrix is completed in table CNP by its transposition. */
3032 /*     So: CNP(I,J) = CNP(J,I) for I and J = 0, ..., 60. */
3033
3034 /*     Initialization is done with block-data MMLLL09.RES, */
3035 /*     created by the program MQINICNP.FOR. */
3036 /* > */
3037 /* **********************************************************************
3038 */
3039
3040
3041
3042 /* ***********************************************************************
3043  */
3044
3045     /* Parameter adjustments */
3046     courbe_dim1 = *ndimax;
3047     --courbe;
3048     crvcan_dim1 = *ncofmx;
3049     crvcan_offset = crvcan_dim1;
3050     crvcan -= crvcan_offset;
3051
3052     /* Function Body */
3053     ibb = AdvApp2Var_SysBase::mnfndeb_();
3054     if (ibb >= 3) {
3055         AdvApp2Var_SysBase::mgenmsg_("MMCVSTD", 7L);
3056     }
3057     ndeg = *ncoeff - 1;
3058
3059 /* ------------------ Construction of the resulting curve ----------------
3060 */
3061
3062     i__1 = *ndimen;
3063     for (nd = 1; nd <= i__1; ++nd) {
3064         i__2 = ndeg;
3065         for (j = 0; j <= i__2; ++j) {
3066             bid = 0.;
3067             i__3 = ndeg;
3068             for (i__ = j; i__ <= i__3; i__ += 2) {
3069                 bid += crvcan[i__ + nd * crvcan_dim1] * mmcmcnp_.cnp[i__ + j
3070                         * 61];
3071 /* L410: */
3072             }
3073             courbe[nd + j * courbe_dim1] = bid;
3074
3075             bid = 0.;
3076             j1 = j + 1;
3077             i__3 = ndeg;
3078             for (i__ = j1; i__ <= i__3; i__ += 2) {
3079                 bid += crvcan[i__ + nd * crvcan_dim1] * mmcmcnp_.cnp[i__ + j
3080                         * 61];
3081 /* L420: */
3082             }
3083             courbe[nd + j * courbe_dim1] -= bid;
3084 /* L400: */
3085         }
3086 /* L300: */
3087     }
3088
3089 /* ------------------- Renormalization of the CURVE -------------------------
3090  */
3091
3092     bid = 1.;
3093     i__1 = ndeg;
3094     for (i__ = 0; i__ <= i__1; ++i__) {
3095         i__2 = *ndimen;
3096         for (nd = 1; nd <= i__2; ++nd) {
3097             courbe[nd + i__ * courbe_dim1] *= bid;
3098 /* L510: */
3099         }
3100         bid *= 2.;
3101 /* L500: */
3102     }
3103
3104 /* ----------------------------- The end --------------------------------
3105 */
3106
3107     if (ibb >= 3) {
3108         AdvApp2Var_SysBase::mgsomsg_("MMCVSTD", 7L);
3109     }
3110     return 0;
3111 } /* mmcvstd_ */
3112
3113 //=======================================================================
3114 //function : AdvApp2Var_MathBase::mmdrc11_
3115 //purpose  :
3116 //=======================================================================
3117 int AdvApp2Var_MathBase::mmdrc11_(integer *iordre,
3118                                   integer *ndimen,
3119                                   integer *ncoeff,
3120                                   doublereal *courbe,
3121                                   doublereal *points,
3122                                   doublereal *mfactab)
3123
3124 {
3125   /* System generated locals */
3126   integer courbe_dim1, courbe_offset, points_dim2, points_offset, i__1,
3127   i__2;
3128
3129   /* Local variables */
3130
3131   integer ndeg, i__, j, ndgcb, nd, ibb;
3132
3133
3134 /* **********************************************************************
3135 */
3136
3137 /*     FUNCTION : */
3138 /*     ---------- */
3139 /*        Calculation of successive derivatives of equation CURVE with */
3140 /*        parameters -1, 1 from order 0 to order IORDRE */
3141 /*        included. The calculation is produced without knowing the coefficients of */
3142 /*        derivatives of the curve. */
3143
3144 /*     KEYWORDS : */
3145 /*     ----------- */
3146 /*        POSITIONING,EXTREMITIES,CURVE,DERIVATIVE. */
3147
3148 /*     INPUT ARGUMENTS : */
3149 /*     ------------------ */
3150 /*        IORDRE  : Maximum order of calculation of derivatives. */
3151 /*        NDIMEN  : Dimension of the space. */
3152 /*        NCOEFF  : Number of coefficients of the curve (degree+1). */
3153 /*        COURBE  : Table of coefficients of the curve. */
3154
3155 /*     OUTPUT ARGUMENTS : */
3156 /*     ------------------- */
3157 /*        POINTS    : Table of values of consecutive derivatives */
3158 /*                 of parameters -1.D0 and 1.D0. */
3159 /*        MFACTAB : Auxiliary table for calculation of factorial(I).
3160 */
3161
3162 /*     COMMONS USED   : */
3163 /*     ---------------- */
3164 /*        None. */
3165
3166 /*     REFERENCES CALLED   : */
3167 /*     ----------------------- */
3168
3169 /*     DESCRIPTION/NOTES/LIMITATIONS : */
3170 /*     ----------------------------------- */
3171
3172 /* ---> ATTENTION, the coefficients of the curve are  */
3173 /*     in a reverse order. */
3174
3175 /* ---> The algorithm of calculation of derivatives is based on */
3176 /*     generalization of Horner scheme : */
3177 /*                          k             2 */
3178 /*          Let C(t) = uk.t  + ... + u2.t  + u1.t + u0 . */
3179
3180
3181 /*      a0 = uk, b0 = 0, c0 = 0 and for 1<=j<=k, it is calculated : */
3182
3183 /*          aj = a(j-1).x + u(k-j) */
3184 /*          bj = b(j-1).x + a(j-1) */
3185 /*          cj = c(j-1).x + b(j-1) */
3186
3187 /*     So : C(x) = ak, C'(x) = bk, C"(x) = 2.ck  . */
3188
3189 /*     The algorithm is generalized easily for calculation of */
3190
3191 /*               (n) */
3192 /*              C  (x)   . */
3193 /*             --------- */
3194 /*                n! */
3195
3196 /*      Reference : D. KNUTH, "The Art of Computer Programming" */
3197 /*      ---------              Vol. 2/Seminumerical Algorithms */
3198 /*                             Addison-Wesley Pub. Co. (1969) */
3199 /*                             pages 423-425. */
3200 /* > */
3201 /* **********************************************************************
3202 */
3203
3204 /*   Name of the routine */
3205
3206     /* Parameter adjustments */
3207     points_dim2 = *iordre + 1;
3208     points_offset = (points_dim2 << 1) + 1;
3209     points -= points_offset;
3210     courbe_dim1 = *ncoeff;
3211     courbe_offset = courbe_dim1;
3212     courbe -= courbe_offset;
3213
3214     /* Function Body */
3215     ibb = AdvApp2Var_SysBase::mnfndeb_();
3216     if (ibb >= 2) {
3217         AdvApp2Var_SysBase::mgenmsg_("MMDRC11", 7L);
3218     }
3219
3220     if (*iordre < 0 || *ncoeff < 1) {
3221         goto L9999;
3222     }
3223
3224 /* ------------------- Initialization of table POINTS -----------------
3225 */
3226
3227     ndgcb = *ncoeff - 1;
3228     i__1 = *ndimen;
3229     for (nd = 1; nd <= i__1; ++nd) {
3230         points[(nd * points_dim2 << 1) + 1] = courbe[ndgcb + nd * courbe_dim1]
3231                 ;
3232         points[(nd * points_dim2 << 1) + 2] = courbe[ndgcb + nd * courbe_dim1]
3233                 ;
3234 /* L100: */
3235     }
3236
3237     i__1 = *ndimen;
3238     for (nd = 1; nd <= i__1; ++nd) {
3239         i__2 = *iordre;
3240         for (j = 1; j <= i__2; ++j) {
3241             points[((j + nd * points_dim2) << 1) + 1] = 0.;
3242             points[((j + nd * points_dim2) << 1) + 2] = 0.;
3243 /* L400: */
3244         }
3245 /* L300: */
3246     }
3247
3248 /*    Calculation with parameter -1 and 1 */
3249
3250     i__1 = *ndimen;
3251     for (nd = 1; nd <= i__1; ++nd) {
3252         i__2 = ndgcb;
3253         for (ndeg = 1; ndeg <= i__2; ++ndeg) {
3254             for (i__ = *iordre; i__ >= 1; --i__) {
3255                 points[((i__ + nd * points_dim2) << 1) + 1] = -points[((i__ + nd
3256                         * points_dim2) << 1) + 1] + points[((i__ - 1 + nd *
3257                         points_dim2) << 1) + 1];
3258                 points[((i__ + nd * points_dim2) << 1) + 2] += points[((i__ - 1
3259                         + nd * points_dim2) << 1) + 2];
3260 /* L800: */
3261             }
3262             points[(nd * points_dim2 << 1) + 1] = -points[(nd * points_dim2 <<
3263                      1) + 1] + courbe[ndgcb - ndeg + nd * courbe_dim1];
3264             points[(nd * points_dim2 << 1) + 2] += courbe[ndgcb - ndeg + nd *
3265                     courbe_dim1];
3266 /* L700: */
3267         }
3268 /* L600: */
3269     }
3270
3271 /* --------------------- Multiplication by factorial(I) --------------
3272 */
3273
3274     if (*iordre > 1) {
3275         mfac_(&mfactab[1], iordre);
3276
3277         i__1 = *ndimen;
3278         for (nd = 1; nd <= i__1; ++nd) {
3279             i__2 = *iordre;
3280             for (i__ = 2; i__ <= i__2; ++i__) {
3281                 points[((i__ + nd * points_dim2) << 1) + 1] = mfactab[i__] *
3282                         points[((i__ + nd * points_dim2) << 1) + 1];
3283                 points[((i__ + nd * points_dim2) << 1) + 2] = mfactab[i__] *
3284                         points[((i__ + nd * points_dim2) << 1) + 2];
3285 /* L1000: */
3286             }
3287 /* L900: */
3288         }
3289     }
3290
3291 /* ---------------------------- End -------------------------------------
3292 */
3293
3294 L9999:
3295     if (ibb >= 2) {
3296         AdvApp2Var_SysBase::mgsomsg_("MMDRC11", 7L);
3297     }
3298     return 0;
3299 } /* mmdrc11_ */
3300
3301 //=======================================================================
3302 //function : mmdrvcb_
3303 //purpose  :
3304 //=======================================================================
3305 int mmdrvcb_(integer *ideriv,
3306              integer *ndim,
3307              integer *ncoeff,
3308              doublereal *courbe,
3309              doublereal *tparam,
3310              doublereal *tabpnt,
3311              integer *iercod)
3312
3313 {
3314   /* System generated locals */
3315   integer courbe_dim1, tabpnt_dim1, i__1, i__2, i__3;
3316
3317   /* Local variables */
3318   integer ndeg, i__, j, nd, ndgcrb, iptpnt, ibb;
3319
3320
3321 /* *********************************************************************** */
3322 /*     FUNCTION : */
3323 /*     ---------- */
3324
3325 /*        Calculation of successive derivatives of equation CURVE with */
3326 /*        parameter TPARAM from order 0 to order IDERIV included. */
3327 /*        The calculation is produced without knowing the coefficients of */
3328 /*        derivatives of the CURVE. */
3329
3330 /*     KEYWORDS : */
3331 /*     ----------- */
3332 /*        POSITIONING,PARAMETER,CURVE,DERIVATIVE. */
3333
3334 /*     INPUT ARGUMENTS : */
3335 /*     ------------------ */
3336 /*        IORDRE  : Maximum order of calculation of derivatives. */
3337 /*        NDIMEN  : Dimension of the space. */
3338 /*        NCOEFF  : Number of coefficients of the curve (degree+1). */
3339 /*        COURBE  : Table of coefficients of the curve. */
3340 /*        TPARAM  : Value of the parameter where the curve should be evaluated. */
3341
3342 /*     OUTPUT ARGUMENTS : */
3343 /*     ------------------- */
3344 /*        TABPNT  : Table of values of consecutive derivatives */
3345 /*                  of parameter TPARAM. */
3346   /*        IERCOD  : 0 = OK, */
3347 /*                    1 = incoherent input. */
3348
3349 /*     COMMONS USED  : */
3350 /*     ---------------- */
3351 /*        None. */
3352
3353 /*     REFERENCES CALLED   : */
3354 /*     ----------------------- */
3355
3356 /*     DESCRIPTION/NOTES/LIMITATIONS : */
3357 /*     ----------------------------------- */
3358
3359 /*     The algorithm of  calculation of derivatives is based on */
3360 /*     generalization of the Horner scheme : */
3361 /*                          k             2 */
3362 /*          Let C(t) = uk.t  + ... + u2.t  + u1.t + u0 . */
3363
3364
3365 /*      a0 = uk, b0 = 0, c0 = 0 and for 1<=j<=k, it is calculated : */
3366
3367 /*          aj = a(j-1).x + u(k-j) */
3368 /*          bj = b(j-1).x + a(j-1) */
3369 /*          cj = c(j-1).x + b(j-1) */
3370
3371 /*     So, it is obtained : C(x) = ak, C'(x) = bk, C"(x) = 2.ck  . */
3372
3373 /*     The algorithm can be easily generalized for the calculation of */
3374
3375 /*               (n) */
3376 /*              C  (x)   . */
3377 /*             --------- */
3378 /*                n! */
3379
3380 /*      Reference : D. KNUTH, "The Art of Computer Programming" */
3381 /*      ---------              Vol. 2/Seminumerical Algorithms */
3382 /*                             Addison-Wesley Pub. Co. (1969) */
3383 /*                             pages 423-425. */
3384
3385 /* ---> To evaluare derivatives at 0 and 1, it is preferable */
3386 /*      to use routine MDRV01.FOR . */
3387 /* > */
3388 /* **********************************************************************
3389 */
3390
3391 /*   Name of the routine */
3392
3393     /* Parameter adjustments */
3394     tabpnt_dim1 = *ndim;
3395     --tabpnt;
3396     courbe_dim1 = *ndim;
3397     --courbe;
3398
3399     /* Function Body */
3400     ibb = AdvApp2Var_SysBase::mnfndeb_();
3401     if (ibb >= 2) {
3402         AdvApp2Var_SysBase::mgenmsg_("MMDRVCB", 7L);
3403     }
3404
3405     if (*ideriv < 0 || *ncoeff < 1) {
3406         *iercod = 1;
3407         goto L9999;
3408     }
3409     *iercod = 0;
3410
3411 /* ------------------- Initialization of table TABPNT -----------------
3412 */
3413
3414     ndgcrb = *ncoeff - 1;
3415     i__1 = *ndim;
3416     for (nd = 1; nd <= i__1; ++nd) {
3417         tabpnt[nd] = courbe[nd + ndgcrb * courbe_dim1];
3418 /* L100: */
3419     }
3420
3421     if (*ideriv < 1) {
3422         goto L200;
3423     }
3424     iptpnt = *ndim * *ideriv;
3425     AdvApp2Var_SysBase::mvriraz_(&iptpnt,
3426              &tabpnt[tabpnt_dim1 + 1]);
3427 L200:
3428
3429 /* ------------------------ Calculation of parameter TPARAM ------------------
3430 */
3431
3432     i__1 = ndgcrb;
3433     for (ndeg = 1; ndeg <= i__1; ++ndeg) {
3434         i__2 = *ndim;
3435         for (nd = 1; nd <= i__2; ++nd) {
3436             for (i__ = *ideriv; i__ >= 1; --i__) {
3437                 tabpnt[nd + i__ * tabpnt_dim1] = tabpnt[nd + i__ *
3438                         tabpnt_dim1] * *tparam + tabpnt[nd + (i__ - 1) *
3439                         tabpnt_dim1];
3440 /* L700: */
3441             }
3442             tabpnt[nd] = tabpnt[nd] * *tparam + courbe[nd + (ndgcrb - ndeg) *
3443                     courbe_dim1];
3444 /* L600: */
3445         }
3446 /* L500: */
3447     }
3448
3449 /* --------------------- Multiplication by factorial(I) -------------
3450 */
3451
3452     i__1 = *ideriv;
3453     for (i__ = 2; i__ <= i__1; ++i__) {
3454         i__2 = i__;
3455         for (j = 2; j <= i__2; ++j) {
3456             i__3 = *ndim;
3457             for (nd = 1; nd <= i__3; ++nd) {
3458                 tabpnt[nd + i__ * tabpnt_dim1] = (doublereal) j * tabpnt[nd +
3459                         i__ * tabpnt_dim1];
3460 /* L1200: */
3461             }
3462 /* L1100: */
3463         }
3464 /* L1000: */
3465     }
3466
3467 /* --------------------------- The end ---------------------------------
3468 */
3469
3470 L9999:
3471     if (*iercod > 0) {
3472         AdvApp2Var_SysBase::maermsg_("MMDRVCB", iercod, 7L);
3473     }
3474     return 0;
3475 } /* mmdrvcb_ */
3476
3477 //=======================================================================
3478 //function : AdvApp2Var_MathBase::mmdrvck_
3479 //purpose  :
3480 //=======================================================================
3481 int AdvApp2Var_MathBase::mmdrvck_(integer *ncoeff,
3482                                   integer *ndimen,
3483                                   doublereal *courbe,
3484                                   integer *ideriv,
3485                                   doublereal *tparam,
3486                                   doublereal *pntcrb)
3487
3488 {
3489   /* Initialized data */
3490
3491   static doublereal mmfack[21] = { 1.,2.,6.,24.,120.,720.,5040.,40320.,
3492             362880.,3628800.,39916800.,479001600.,6227020800.,87178291200.,
3493             1.307674368e12,2.0922789888e13,3.55687428096e14,6.402373705728e15,
3494             1.21645100408832e17,2.43290200817664e18,5.109094217170944e19 };
3495
3496   /* System generated locals */
3497   integer courbe_dim1, courbe_offset, i__1, i__2;
3498
3499   /* Local variables */
3500   integer i__, j, k, nd;
3501   doublereal mfactk, bid;
3502
3503
3504 /*      IMPLICIT INTEGER (I-N) */
3505 /*      IMPLICIT DOUBLE PRECISION(A-H,O-Z) */
3506
3507
3508 /* ***********************************************************************
3509  */
3510
3511 /*     FONCTION : */
3512 /*     ---------- */
3513 /*     Calculate the value of a derived curve of order IDERIV in */
3514 /*     a point of parameter TPARAM. */
3515
3516 /*     KEYWORDS : */
3517 /*     ----------- */
3518 /*     POSITIONING,CURVE,DERIVATIVE of ORDER K. */
3519
3520 /*     INPUT ARGUMENTS  : */
3521 /*     ------------------ */
3522 /*   NCOEFF  : Degree +1 of the curve. */
3523 /*   NDIMEN   : Dimension of the space (2 or 3 in general) */
3524 /*   COURBE  : Table of coefficients of the curve. */
3525 /*   IDERIV : Required order of derivation : 1=1st derivative, etc... */
3526 /*   TPARAM : Value of parameter of the curve. */
3527
3528 /*     OUTPUT ARGUMENTS  : */
3529 /*     ------------------- */
3530 /*   PNTCRB  : Point of parameter TPARAM on the derivative of order */
3531 /*            IDERIV of CURVE. */
3532
3533 /*     COMMONS USED   : */
3534 /*     ---------------- */
3535 /*    MMCMCNP */
3536
3537 /*     REFERENCES CALLED   : */
3538 /*     ---------------------- */
3539 /*      None. */
3540 /*     DESCRIPTION/NOTES/LIMITATIONS : */
3541 /*     ----------------------------------- */
3542
3543 /*    The code below was written basing on the following algorithm :
3544 */
3545
3546 /*    Let P(t) = a1 + a2*t + ... an*t**n. The derivative of order k of P */
3547 /*    (containing n-k coefficients) is calculated as follows : */
3548
3549 /*       Pk(t) = a(k+1)*CNP(k,k)*k! */
3550 /*             + a(k+2)*CNP(k+1,k)*k! * t */
3551 /*             . */
3552 /*             . */
3553 /*             . */
3554 /*             + a(n)*CNP(n-1,k)*k! * t**(n-k-1). */
3555
3556 /*    Evaluation is produced following the classic Horner scheme. */
3557 /* > */
3558 /* ***********************************************************************
3559  */
3560
3561
3562 /*     Factorials (1 to 21)  caculated on VAX in R*16 */
3563
3564
3565 /* **********************************************************************
3566 */
3567
3568 /*     FUNCTION : */
3569 /*     ---------- */
3570 /*      Serves to provide binomial coefficients (Pascal triangle). */
3571
3572 /*     KEYWORDS : */
3573 /*     ----------- */
3574 /*      Binomial Coeff from 0 to 60. read only . init by block data */
3575
3576 /*     DEMSCRIPTION/NOTES/LIMITATIONS : */
3577 /*     ----------------------------------- */
3578 /*     Binomial coefficients form a triangular matrix. */
3579 /*     This matrix is completed in table CNP by its transposition. */
3580 /*     So: CNP(I,J) = CNP(J,I) for I and J = 0, ..., 60. */
3581
3582 /*     Initialization is done by block-data MMLLL09.RES, */
3583 /*     created by program MQINICNP.FOR. */
3584 /* > */
3585 /* **********************************************************************
3586 */
3587
3588
3589
3590 /* ***********************************************************************
3591  */
3592
3593     /* Parameter adjustments */
3594     --pntcrb;
3595     courbe_dim1 = *ndimen;
3596     courbe_offset = courbe_dim1 + 1;
3597     courbe -= courbe_offset;
3598
3599     /* Function Body */
3600
3601 /* -------------- Case when the order of derivative is greater than -------------------
3602 */
3603 /* ---------------- the degree of the curve ---------------------
3604 */
3605
3606     if (*ideriv >= *ncoeff) {
3607         i__1 = *ndimen;
3608         for (nd = 1; nd <= i__1; ++nd) {
3609             pntcrb[nd] = 0.;
3610 /* L100: */
3611         }
3612         goto L9999;
3613     }
3614 /* **********************************************************************
3615 */
3616 /*                         General processing*/
3617 /* **********************************************************************
3618 */
3619 /* --------------------- Calculation of Factorial(IDERIV) ------------------
3620 */
3621
3622     k = *ideriv;
3623     if (*ideriv <= 21 && *ideriv > 0) {
3624         mfactk = mmfack[k - 1];
3625     } else {
3626         mfactk = 1.;
3627         i__1 = k;
3628         for (i__ = 2; i__ <= i__1; ++i__) {
3629             mfactk *= i__;
3630 /* L200: */
3631         }
3632     }
3633
3634 /* ------- Calculation of derivative of order IDERIV of CURVE in TPARAM -----
3635 */
3636 /* ---> Attention : binomial coefficient C(n,m) is represented in */
3637 /*                 MCCNP by CNP(N,M). */
3638
3639     i__1 = *ndimen;
3640     for (nd = 1; nd <= i__1; ++nd) {
3641         pntcrb[nd] = courbe[nd + *ncoeff * courbe_dim1] * mmcmcnp_.cnp[*
3642                 ncoeff - 1 + k * 61] * mfactk;
3643 /* L300: */
3644     }
3645
3646     i__1 = k + 1;
3647     for (j = *ncoeff - 1; j >= i__1; --j) {
3648         bid = mmcmcnp_.cnp[j - 1 + k * 61] * mfactk;
3649         i__2 = *ndimen;
3650         for (nd = 1; nd <= i__2; ++nd) {
3651             pntcrb[nd] = pntcrb[nd] * *tparam + courbe[nd + j * courbe_dim1] *
3652                      bid;
3653 /* L500: */
3654         }
3655 /* L400: */
3656     }
3657
3658 /* -------------------------------- The end -----------------------------
3659 */
3660
3661 L9999:
3662
3663  return 0   ;
3664
3665 } /* mmdrvck_ */
3666 //=======================================================================
3667 //function : AdvApp2Var_MathBase::mmeps1_
3668 //purpose  :
3669 //=======================================================================
3670 int AdvApp2Var_MathBase::mmeps1_(doublereal *epsilo)
3671
3672 {
3673 /* ***********************************************************************
3674  */
3675
3676 /*     FUNCTION : */
3677 /*     ---------- */
3678 /*        Extraction of EPS1 from COMMON MPRCSN. EPS1 is spatial zero  */
3679 /*     equal to 1.D-9 */
3680
3681 /*     KEYWORDS : */
3682 /*     ----------- */
3683 /*        MPRCSN,PRECISON,EPS1. */
3684
3685 /*     INPUT ARGUMENTS : */
3686 /*     ------------------ */
3687 /*        None */
3688
3689 /*     OUTPUT ARGUMENTS : */
3690 /*     ------------------- */
3691 /*        EPSILO : Value of EPS1 (spatial zero (10**-9)) */
3692
3693 /*     COMMONS USED   : */
3694 /*     ---------------- */
3695
3696 /*     REFERENCES CALLED   : */
3697 /*     ----------------------- */
3698
3699 /*     DESCRIPTION/NOTES/LIMITATIONS : */
3700 /*     ----------------------------------- */
3701 /*     EPS1 is ABSOLUTE spatial zero, so it is necessary */
3702 /*     to use it whenever it is necessary to test if a variable */
3703 /*     is null. For example, if the norm of a vector is lower than */
3704 /*     EPS1, this vector is NULL ! (when one works in */
3705 /*     REAL*8) It is absolutely not advised to test arguments  */
3706 /*     compared to EPS1**2. Taking into account the rounding errors inevitable */
3707 /*     during calculations, this causes testing compared to 0.D0. */
3708 /* > */
3709 /* ***********************************************************************
3710  */
3711
3712
3713
3714 /* ***********************************************************************
3715  */
3716
3717 /*     FUNCTION : */
3718 /*     ---------- */
3719 /*          Gives tolerances of invalidity in stream */
3720 /*          as well as limits of iterative processes */
3721
3722 /*          general context, modifiable by the user */
3723
3724 /*     KEYWORDS : */
3725 /*     ----------- */
3726 /*          PARAMETER , TOLERANCE */
3727
3728 /*     DEMSCRIPTION/NOTES/LIMITATIONS : */
3729 /*     ----------------------------------- */
3730 /*       INITIALISATION   :  profile , **VIA MPRFTX** at input in stream */
3731 /*       loading of default values of the profile in MPRFTX at input */
3732 /*       in stream. They are preserved in local variables of MPRFTX */
3733
3734 /*        Reset of default values                  : MDFINT */
3735 /*        Interactive modification by the user   : MDBINT */
3736
3737 /*        ACCESS FUNCTION  :  MMEPS1   ...  EPS1 */
3738 /*                            MEPSPB  ...  EPS3,EPS4 */
3739 /*                            MEPSLN  ...  EPS2, NITERM , NITERR */
3740 /*                            MEPSNR  ...  EPS2 , NITERM */
3741 /*                            MITERR  ...  NITERR */
3742 /* > */
3743 /* ***********************************************************************
3744  */
3745
3746 /*     NITERM : max nb of iterations */
3747 /*     NITERR : nb of rapid iterations */
3748 /*     EPS1   : tolerance of 3D null distance */
3749 /*     EPS2   : tolerance of parametric null distance */
3750 /*     EPS3   : tolerance to avoid division by 0.. */
3751 /*     EPS4   : angular tolerance */
3752
3753
3754
3755 /* ***********************************************************************
3756  */
3757     *epsilo = mmprcsn_.eps1;
3758
3759  return 0 ;
3760 } /* mmeps1_ */
3761
3762 //=======================================================================
3763 //function : mmexthi_
3764 //purpose  :
3765 //=======================================================================
3766 int mmexthi_(integer *ndegre,
3767              doublereal *hwgaus)
3768
3769 {
3770   /* System generated locals */
3771   integer i__1;
3772
3773   /* Local variables */
3774   integer iadd, ideb, ndeg2, nmod2, ii, ibb;
3775   integer kpt;
3776
3777 /* **********************************************************************
3778 */
3779
3780 /*     FONCTION : */
3781 /*     ---------- */
3782 /*  Extract of common LDGRTL the weight of formulas of  */
3783 /*  Gauss quadrature on all roots of Legendre polynoms of degree */
3784 /*  NDEGRE defined on [-1,1]. */
3785
3786 /*     KEYWORDS : */
3787 /*     ----------- */
3788 /*     ALL, AB_SPECIFI::COMMON&, EXTRACTION, &WEIGHT, &GAUSS. */
3789
3790 /*     INPUT ARGUMENTS : */
3791 /*     ------------------ */
3792 /*   NDEGRE : Mathematic degree of Legendre polynom. It should have */
3793 /*            2 <= NDEGRE <= 61. */
3794
3795 /*     OUTPUT ARGUMENTS : */
3796 /*     ------------------- */
3797 /*   HWGAUS : The table of weights of Gauss quadrature formulas */
3798 /*            relative to NDEGRE roots of a polynome de Legendre de */
3799 /*            degre NDEGRE. */
3800
3801 /*     COMMONS UTILISES   : */
3802 /*     ---------------- */
3803 /*     MLGDRTL */
3804
3805 /*     REFERENCES CALLED   : */
3806 /*     ----------------------- */
3807
3808 /*     DESCRIPTION/NOTES/LIMITATIONS : */
3809 /*     ----------------------------------- */
3810 /*     ATTENTION: The condition on NDEGRE ( 2 <= NDEGRE <= 61) is not  */
3811 /*     tested. The caller should make the test. */
3812
3813 /*   Name of the routine */
3814
3815
3816 /*   Common MLGDRTL: */
3817 /*   This common includes POSITIVE roots of Legendre polynims */
3818 /*   AND weights of Gauss quadrature formulas on all */
3819 /*   POSITIVE roots of Legendre polynoms. */
3820
3821
3822
3823 /* ***********************************************************************
3824  */
3825
3826 /*     FUNCTION : */
3827 /*     ---------- */
3828 /*   The common of Legendre roots. */
3829
3830 /*     KEYWORDS : */
3831 /*     ----------- */
3832 /*        BASE LEGENDRE */
3833
3834 /*     DESCRIPTION/NOTES/LIMITATIONS : */
3835 /*     ----------------------------------- */
3836 /* > */
3837 /* ***********************************************************************
3838  */
3839
3840
3841
3842
3843 /*   ROOTAB : Table of all roots of Legendre polynoms */
3844 /*   within the interval [0,1]. They are ranked for the degrees increasing from */
3845 /*   2 to 61. */
3846 /*   HILTAB : Table of Legendre interpolators concerning ROOTAB. */
3847 /*   The adressing is the same. */
3848 /*   HI0TAB : Table of Legendre interpolators for root x=0 */
3849 /*   of polynoms of UNEVEN degree. */
3850 /*   RTLTB0 : Table of Li(uk) where uk are the roots of */
3851 /*  Legendre polynom of EVEN degree. */
3852 /*   RTLTB1 : Table of Li(uk) where uk are the roots of */
3853 /*  Legendre polynom of UNEVEN degree. */
3854
3855
3856 /************************************************************************
3857 *****/
3858     /* Parameter adjustments */
3859     --hwgaus;
3860
3861     /* Function Body */
3862     ibb = AdvApp2Var_SysBase::mnfndeb_();
3863     if (ibb >= 3) {
3864         AdvApp2Var_SysBase::mgenmsg_("MMEXTHI", 7L);
3865     }
3866
3867     ndeg2 = *ndegre / 2;
3868     nmod2 = *ndegre % 2;
3869
3870 /*   Address of Gauss weight associated to the 1st strictly */
3871 /*   positive root of Legendre polynom of degree NDEGRE in MLGDRTL. */
3872
3873     iadd = ndeg2 * (ndeg2 - 1) / 2 + 1;
3874
3875 /*   Index of the 1st HWGAUS element associated to the 1st strictly  */
3876 /*   positive root of Legendre polynom of degree NDEGRE. */
3877
3878     ideb = (*ndegre + 1) / 2 + 1;
3879
3880 /*   Reading of weights associated to strictly positive roots. */
3881
3882     i__1 = *ndegre;
3883     for (ii = ideb; ii <= i__1; ++ii) {
3884         kpt = iadd + ii - ideb;
3885         hwgaus[ii] = mlgdrtl_.hiltab[kpt + nmod2 * 465 - 1];
3886 /* L100: */
3887     }
3888
3889 /*   For strictly negative roots, the weight is the same. */
3890 /*   i.e HW(1) = HW(NDEGRE), HW(2) = HW(NDEGRE-1), etc... */
3891
3892     i__1 = ndeg2;
3893     for (ii = 1; ii <= i__1; ++ii) {
3894         hwgaus[ii] = hwgaus[*ndegre + 1 - ii];
3895 /* L200: */
3896     }
3897
3898 /*   Case of uneven NDEGRE, 0 is root of Legendre polynom, */
3899 /*   associated Gauss weights are loaded. */
3900
3901     if (nmod2 == 1) {
3902         hwgaus[ndeg2 + 1] = mlgdrtl_.hi0tab[ndeg2];
3903     }
3904
3905 /* --------------------------- The end ----------------------------------
3906 */
3907
3908     if (ibb >= 3) {
3909         AdvApp2Var_SysBase::mgsomsg_("MMEXTHI", 7L);
3910     }
3911     return 0;
3912 } /* mmexthi_ */
3913
3914 //=======================================================================
3915 //function : mmextrl_
3916 //purpose  :
3917 //=======================================================================
3918 int mmextrl_(integer *ndegre,
3919              doublereal *rootlg)
3920 {
3921   /* System generated locals */
3922   integer i__1;
3923
3924   /* Local variables */
3925   integer iadd, ideb, ndeg2, nmod2, ii, ibb;
3926   integer kpt;
3927
3928
3929 /* **********************************************************************
3930 */
3931
3932 /*     FUNCTION : */
3933 /*     ---------- */
3934 /* Extract of the Common LDGRTL of Legendre polynom roots */
3935 /* of degree NDEGRE defined on [-1,1]. */
3936
3937 /*     KEYWORDS : */
3938 /*     ----------- */
3939 /*     ALL, AB_SPECIFI::COMMON&, EXTRACTION, &ROOT, &LEGENDRE. */
3940
3941 /*     INPUT ARGUMENTS : */
3942 /*     ------------------ */
3943 /*   NDEGRE : Mathematic degree of Legendre polynom.  */
3944 /*            It is required to have 2 <= NDEGRE <= 61. */
3945
3946 /*     OUTPUT ARGUMENTS : */
3947 /*     ------------------- */
3948 /*   ROOTLG : The table of roots of Legendre polynom of degree */
3949 /*            NDEGRE defined on [-1,1]. */
3950
3951 /*     COMMONS USED   : */
3952 /*     ---------------- */
3953 /*     MLGDRTL */
3954
3955 /*     REFERENCES CALLED   : */
3956 /*     ----------------------- */
3957
3958 /*     DESCRIPTION/NOTES/LIMITATIONS : */
3959 /*     ----------------------------------- */
3960 /*     ATTENTION: Condition of NDEGRE ( 2 <= NDEGRE <= 61) is not */
3961 /*     tested. The caller should make the test. */
3962 /* > */
3963 /* **********************************************************************
3964 */
3965
3966
3967 /*   Name of the routine */
3968
3969
3970 /*   Common MLGDRTL: */
3971 /*   This common includes POSITIVE roots of Legendre polynoms */
3972 /*   AND the weight of Gauss quadrature formulas on all */
3973 /*   POSITIVE roots of Legendre polynoms. */
3974
3975 /* ***********************************************************************
3976  */
3977
3978 /*     FUNCTION : */
3979 /*     ---------- */
3980 /*   The common of Legendre roots. */
3981
3982 /*     KEYWORDS : */
3983 /*     ----------- */
3984 /*        BASE LEGENDRE */
3985
3986
3987 /* ***********************************************************************
3988  */
3989
3990 /*   ROOTAB : Table of all roots of Legendre polynoms */
3991 /*   within the interval [0,1]. They are ranked for the degrees increasing from */
3992 /*   2 to 61. */
3993 /*   HILTAB : Table of Legendre interpolators concerning ROOTAB. */
3994 /*   The adressing is the same. */
3995 /*   HI0TAB : Table of Legendre interpolators for root x=0 */
3996 /*   of polynoms of UNEVEN degree. */
3997 /*   RTLTB0 : Table of Li(uk) where uk are the roots of */
3998 /*  Legendre polynom of EVEN degree. */
3999 /*   RTLTB1 : Table of Li(uk) where uk are the roots of */
4000 /*  Legendre polynom of UNEVEN degree. */
4001
4002
4003 /************************************************************************
4004 *****/
4005     /* Parameter adjustments */
4006     --rootlg;
4007
4008     /* Function Body */
4009     ibb = AdvApp2Var_SysBase::mnfndeb_();
4010     if (ibb >= 3) {
4011         AdvApp2Var_SysBase::mgenmsg_("MMEXTRL", 7L);
4012     }
4013
4014     ndeg2 = *ndegre / 2;
4015     nmod2 = *ndegre % 2;
4016
4017 /*   Address of the 1st strictly positive root of Legendre polynom */
4018 /*   of degree NDEGRE in MLGDRTL. */
4019
4020     iadd = ndeg2 * (ndeg2 - 1) / 2 + 1;
4021
4022 /*   Indice, in ROOTLG, of the 1st strictly positive root */
4023 /*   of Legendre polynom of degree NDEGRE. */
4024
4025     ideb = (*ndegre + 1) / 2 + 1;
4026
4027 /*   Reading of strictly positive roots. */
4028
4029     i__1 = *ndegre;
4030     for (ii = ideb; ii <= i__1; ++ii) {
4031         kpt = iadd + ii - ideb;
4032         rootlg[ii] = mlgdrtl_.rootab[kpt + nmod2 * 465 - 1];
4033 /* L100: */
4034     }
4035
4036 /*   Strictly negative roots are equal to positive roots
4037 */
4038 /*   to the sign i.e RT(1) = -RT(NDEGRE), RT(2) = -RT(NDEGRE-1), etc...
4039 */
4040
4041     i__1 = ndeg2;
4042     for (ii = 1; ii <= i__1; ++ii) {
4043         rootlg[ii] = -rootlg[*ndegre + 1 - ii];
4044 /* L200: */
4045     }
4046
4047 /*   Case NDEGRE uneven, 0 is root of Legendre polynom. */
4048
4049     if (nmod2 == 1) {
4050         rootlg[ndeg2 + 1] = 0.;
4051     }
4052
4053 /* -------------------------------- THE END -----------------------------
4054 */
4055
4056     if (ibb >= 3) {
4057         AdvApp2Var_SysBase::mgenmsg_("MMEXTRL", 7L);
4058     }
4059     return 0;
4060 } /* mmextrl_ */
4061
4062 //=======================================================================
4063 //function : AdvApp2Var_MathBase::mmfmca8_
4064 //purpose  :
4065 //=======================================================================
4066 int AdvApp2Var_MathBase::mmfmca8_(const integer *ndimen,
4067                                   const integer *ncoefu,
4068                                   const integer *ncoefv,
4069                                   const integer *ndimax,
4070                                   const integer *ncfumx,
4071                                   const integer *,//ncfvmx,
4072                                   doublereal *tabini,
4073                                   doublereal *tabres)
4074
4075 {
4076   /* System generated locals */
4077   integer tabini_dim1, tabini_dim2, tabini_offset, tabres_dim1, tabres_dim2,
4078   tabres_offset;
4079
4080   /* Local variables */
4081   integer i__, j, k, ilong;
4082
4083
4084
4085 /* **********************************************************************
4086 */
4087
4088 /*     FUNCTION : */
4089 /*     ---------- */
4090 /*        Expansion of a table containing only most important things into a  */
4091 /*        greater data table. */
4092
4093 /*     KEYWORDS : */
4094 /*     ----------- */
4095 /*     ALL, MATH_ACCES:: CARREAU&, DECOMPRESSION, &CARREAU */
4096
4097 /*     INPUT ARGUMENTS : */
4098 /*     ------------------ */
4099 /*        NDIMEN: Dimension of the workspace. */
4100 /*        NCOEFU: Degree +1 of the table by u. */
4101 /*        NCOEFV: Degree +1 of the table by v. */
4102 /*        NDIMAX: Max dimension of the space. */
4103 /*        NCFUMX: Max Degree +1 of the table by u. */
4104 /*        NCFVMX: Max Degree +1 of the table by v. */
4105 /*        TABINI: The table to be decompressed. */
4106
4107 /*     OUTPUT ARGUMENTS : */
4108 /*     ------------------- */
4109 /*        TABRES: Decompressed table. */
4110
4111 /*     COMMONS USED   : */
4112 /*     ---------------- */
4113
4114 /*     REFERENCES CALLED   : */
4115 /*     ----------------------- */
4116
4117 /*     DESCRIPTION/NOTES/LIMITATIONS : */
4118 /*     ----------------------------------- */
4119 /*     The following call : */
4120
4121 /*  CALL MMFMCA8(NDIMEN,NCOEFU,NCOEFV,NDIMAX,NCFUMX,NCFVMX,TABINI,TABINI)
4122 */
4123
4124 /*     where TABINI is input/output argument, is possible provided */
4125 /*     that the caller has declared TABINI in (NDIMAX,NCFUMX,NCFVMX) */
4126
4127 /*     ATTENTION : it is not checked that NDIMAX >= NDIMEN, */
4128 /*                 NCOEFU >= NCFMXU and NCOEFV >= NCFMXV. */
4129 /* > */
4130 /* **********************************************************************
4131 */
4132
4133
4134     /* Parameter adjustments */
4135     tabini_dim1 = *ndimen;
4136     tabini_dim2 = *ncoefu;
4137     tabini_offset = tabini_dim1 * (tabini_dim2 + 1) + 1;
4138     tabini -= tabini_offset;
4139     tabres_dim1 = *ndimax;
4140     tabres_dim2 = *ncfumx;
4141     tabres_offset = tabres_dim1 * (tabres_dim2 + 1) + 1;
4142     tabres -= tabres_offset;
4143
4144     /* Function Body */
4145     if (*ndimax == *ndimen) {
4146         goto L1000;
4147     }
4148
4149 /* ----------------------- decompression NDIMAX<>NDIMEN -----------------
4150 */
4151
4152     for (k = *ncoefv; k >= 1; --k) {
4153         for (j = *ncoefu; j >= 1; --j) {
4154             for (i__ = *ndimen; i__ >= 1; --i__) {
4155                 tabres[i__ + (j + k * tabres_dim2) * tabres_dim1] = tabini[
4156                         i__ + (j + k * tabini_dim2) * tabini_dim1];
4157 /* L300: */
4158             }
4159 /* L200: */
4160         }
4161 /* L100: */
4162     }
4163     goto L9999;
4164
4165 /* ----------------------- decompression NDIMAX=NDIMEN ------------------
4166 */
4167
4168 L1000:
4169     if (*ncoefu == *ncfumx) {
4170         goto L2000;
4171     }
4172     ilong = (*ndimen << 3) * *ncoefu;
4173     for (k = *ncoefv; k >= 1; --k) {
4174         AdvApp2Var_SysBase::mcrfill_(&ilong,
4175                  &tabini[(k * tabini_dim2 + 1) * tabini_dim1 + 1],
4176                  &tabres[(k * tabres_dim2 + 1) * tabres_dim1 + 1]);
4177 /* L500: */
4178     }
4179     goto L9999;
4180
4181 /* ----------------- decompression NDIMAX=NDIMEN,NCOEFU=NCFUMX ----------
4182 */
4183
4184 L2000:
4185     ilong = (*ndimen << 3) * *ncoefu * *ncoefv;
4186     AdvApp2Var_SysBase::mcrfill_(&ilong,
4187              &tabini[tabini_offset],
4188              &tabres[tabres_offset]);
4189     goto L9999;
4190
4191 /* ---------------------------- The end ---------------------------------
4192 */
4193
4194 L9999:
4195     return 0;
4196 } /* mmfmca8_ */
4197
4198 //=======================================================================
4199 //function : AdvApp2Var_MathBase::mmfmca9_
4200 //purpose  :
4201 //=======================================================================
4202  int AdvApp2Var_MathBase::mmfmca9_(integer *ndimax,
4203                                    integer *ncfumx,
4204                                    integer *,//ncfvmx,
4205                                    integer *ndimen,
4206                                    integer *ncoefu,
4207                                    integer *ncoefv,
4208                                    doublereal *tabini,
4209                                    doublereal *tabres)
4210
4211 {
4212   /* System generated locals */
4213   integer tabini_dim1, tabini_dim2, tabini_offset, tabres_dim1, tabres_dim2,
4214   tabres_offset, i__1, i__2, i__3;
4215
4216     /* Local variables */
4217   integer i__, j, k, ilong;
4218
4219
4220
4221 /* **********************************************************************
4222 */
4223
4224 /*     FUNCTION : */
4225 /*     ---------- */
4226 /*        Compression of a data table in a table */
4227 /*        containing only the main data (the input table is not removed). */
4228
4229 /*     KEYWORDS: */
4230 /*     ----------- */
4231 /*     ALL, MATH_ACCES:: CARREAU&, COMPRESSION, &CARREAU */
4232
4233 /*     INPUT ARGUMENTS : */
4234 /*     ------------------ */
4235 /*        NDIMAX: Max dimension of the space. */
4236 /*        NCFUMX: Max degree +1 of the table by u. */
4237 /*        NCFVMX: Max degree +1 of the table by v. */
4238 /*        NDIMEN: Dimension of the workspace. */
4239 /*        NCOEFU: Degree +1 of the table by u. */
4240 /*        NCOEFV: Degree +1 of the table by v. */
4241 /*        TABINI: The table to compress. */
4242
4243 /*     OUTPUT ARGUMENTS : */
4244 /*     ------------------- */
4245 /*        TABRES: The compressed table. */
4246
4247 /*     COMMONS USED   : */
4248 /*     ---------------- */
4249
4250 /*     REFERENCES CALLED   : */
4251 /*     ----------------------- */
4252
4253 /*     DESCRIPTION/NOTES/LIMITATIONS : */
4254 /*     ----------------------------------- */
4255 /*     The following call : */
4256
4257 /* CALL MMFMCA9(NDIMAX,NCFUMX,NCFVMX,NDIMEN,NCOEFU,NCOEFV,TABINI,TABINI)
4258 */
4259
4260 /*     where TABINI is input/output argument, is possible provided */
4261 /*     that the caller has checked that : */
4262
4263 /*            NDIMAX > NDIMEN, */
4264 /*         or NDIMAX = NDIMEN and NCFUMX > NCOEFU */
4265 /*         or  NDIMAX = NDIMEN, NCFUMX = NCOEFU and NCFVMX > NCOEFV */
4266
4267 /*     These conditions are not tested in the program. */
4268
4269 /* > */
4270 /* **********************************************************************
4271 */
4272
4273
4274     /* Parameter adjustments */
4275     tabini_dim1 = *ndimax;
4276     tabini_dim2 = *ncfumx;
4277     tabini_offset = tabini_dim1 * (tabini_dim2 + 1) + 1;
4278     tabini -= tabini_offset;
4279     tabres_dim1 = *ndimen;
4280     tabres_dim2 = *ncoefu;
4281     tabres_offset = tabres_dim1 * (tabres_dim2 + 1) + 1;
4282     tabres -= tabres_offset;
4283
4284     /* Function Body */
4285     if (*ndimen == *ndimax) {
4286         goto L1000;
4287     }
4288
4289 /* ----------------------- Compression NDIMEN<>NDIMAX -------------------
4290 */
4291
4292     i__1 = *ncoefv;
4293     for (k = 1; k <= i__1; ++k) {
4294         i__2 = *ncoefu;
4295         for (j = 1; j <= i__2; ++j) {
4296             i__3 = *ndimen;
4297             for (i__ = 1; i__ <= i__3; ++i__) {
4298                 tabres[i__ + (j + k * tabres_dim2) * tabres_dim1] = tabini[
4299                         i__ + (j + k * tabini_dim2) * tabini_dim1];
4300 /* L300: */
4301             }
4302 /* L200: */
4303         }
4304 /* L100: */
4305     }
4306     goto L9999;
4307
4308 /* ----------------------- Compression NDIMEN=NDIMAX --------------------
4309 */
4310
4311 L1000:
4312     if (*ncoefu == *ncfumx) {
4313         goto L2000;
4314     }
4315     ilong = (*ndimen << 3) * *ncoefu;
4316     i__1 = *ncoefv;
4317     for (k = 1; k <= i__1; ++k) {
4318         AdvApp2Var_SysBase::mcrfill_(&ilong,
4319                  &tabini[(k * tabini_dim2 + 1) * tabini_dim1 + 1],
4320                  &tabres[(k * tabres_dim2 + 1) * tabres_dim1 + 1]);
4321 /* L500: */
4322     }
4323     goto L9999;
4324
4325 /* ----------------- Compression NDIMEN=NDIMAX,NCOEFU=NCFUMX ------------
4326 */
4327
4328 L2000:
4329     ilong = (*ndimen << 3) * *ncoefu * *ncoefv;
4330     AdvApp2Var_SysBase::mcrfill_(&ilong,
4331              &tabini[tabini_offset],
4332              &tabres[tabres_offset]);
4333     goto L9999;
4334
4335 /* ---------------------------- The end ---------------------------------
4336 */
4337
4338 L9999:
4339     return 0;
4340 } /* mmfmca9_ */
4341
4342 //=======================================================================
4343 //function : AdvApp2Var_MathBase::mmfmcar_
4344 //purpose  :
4345 //=======================================================================
4346 int AdvApp2Var_MathBase::mmfmcar_(integer *ndimen,
4347                                   integer *ncofmx,
4348                                   integer *ncoefu,
4349                                   integer *ncoefv,
4350                                   doublereal *patold,
4351                                   doublereal *upara1,
4352                                   doublereal *upara2,
4353                                   doublereal *vpara1,
4354                                   doublereal *vpara2,
4355                                   doublereal *patnew,
4356                                   integer *iercod)
4357
4358 {
4359   integer c__8 = 8;
4360   /* System generated locals */
4361     integer patold_dim1, patold_dim2, patnew_dim1, patnew_dim2,
4362             i__1, patold_offset,patnew_offset;
4363
4364     /* Local variables */
4365     doublereal* tbaux = 0;
4366     integer ksize, numax, kk;
4367     intptr_t iofst;
4368     integer ibb, ier;
4369
4370 /* ***********************************************************************
4371  */
4372
4373 /*     FUNCTION : */
4374 /*     ---------- */
4375 /*       LIMITATION OF A SQUARE DEFINED ON (0,1)*(0,1) BETWEEN ISOS */
4376 /*       UPARA1 AND UPARA2 (BY U) AND VPARA1 AND VPARA2 BY V. */
4377
4378 /*     KEYWORDS : */
4379 /*     ----------- */
4380 /*       LIMITATION , SQUARE , PARAMETER */
4381
4382 /*     INPUT ARGUMENTS : */
4383 /*     ------------------ */
4384 /*     NCOFMX: MAX NUMBER OF COEFF OF THE SQUARE BY U */
4385 /*     NCOEFU: NUMBER OF COEFF OF THE SQUARE BY U */
4386 /*     NCOEFV: NUMBER OF COEFF OF THE SQUARE BY V */
4387 /*     PATOLD : THE SQUARE IS LIMITED BY UPARA1,UPARA2 AND VPARA1,VPARA2
4388 .*/
4389 /*     UPARA1    : LOWER LIMIT OF U */
4390 /*     UPARA2    : UPPER LIMIT OF U */
4391 /*     VPARA1    : LOWER LIMIT OF V */
4392 /*     VPARA2    : UPPER LIMIT OF V */
4393
4394 /*     OUTPUT ARGUMENTS : */
4395 /*     ------------------- */
4396 /*     PATNEW : RELIMITED SQUARE, DEFINED ON (0,1)**2 */
4397 /*     IERCOD : =10 COEFF NB TOO GREAT OR NULL */
4398 /*              =13 PB IN THE DYNAMIC ALLOCATION */
4399 /*              = 0 OK. */
4400
4401 /*     COMMONS USED   : */
4402 /*     ---------------- */
4403
4404 /*     DESCRIPTION/NOTES/LIMITATIONS : */
4405 /*     ----------------------------------- */
4406 /* --->    The following call : */
4407 /*   CALL MMFMCAR(NCOFMX,NCOEFU,NCOEFV,PATOLD,UPARA1,UPARA2,VPARA1,VPARA2
4408 */
4409 /*              ,PATOLD), */
4410 /*        where PATOLD is input/output argument is absolutely legal. */
4411
4412 /* --->    The max number of coeff by u and v of PATOLD is 61 */
4413
4414 /* --->    If NCOEFU < NCOFMX, the data is compressed by MMFMCA9 before */
4415 /*        limitation by v to get time during the execution */
4416 /*        of MMARC41 that follows (the square is processed as a curve of
4417 */
4418 /*        dimension NDIMEN*NCOEFU possessing NCOEFV coefficients). */
4419 /* > */
4420 /* ***********************************************************************
4421  */
4422
4423 /*   Name of the routine */
4424
4425
4426     /* Parameter adjustments */
4427     patnew_dim1 = *ndimen;
4428     patnew_dim2 = *ncofmx;
4429     patnew_offset = patnew_dim1 * (patnew_dim2 + 1) + 1;
4430     patnew -= patnew_offset;
4431     patold_dim1 = *ndimen;
4432     patold_dim2 = *ncofmx;
4433     patold_offset = patold_dim1 * (patold_dim2 + 1) + 1;
4434     patold -= patold_offset;
4435
4436     /* Function Body */
4437     ibb = AdvApp2Var_SysBase::mnfndeb_();
4438     if (ibb >= 2) {
4439         AdvApp2Var_SysBase::mgenmsg_("MMFMCAR", 7L);
4440     }
4441     *iercod = 0;
4442     iofst = 0;
4443     AdvApp2Var_SysBase anAdvApp2Var_SysBase;
4444
4445 /* **********************************************************************
4446 */
4447 /*                  TEST OF COEFFICIENT NUMBERS */
4448 /* **********************************************************************
4449 */
4450
4451     if (*ncofmx < *ncoefu) {
4452         *iercod = 10;
4453         goto L9999;
4454     }
4455     if (*ncoefu < 1 || *ncoefu > 61 || *ncoefv < 1 || *ncoefv > 61) {
4456         *iercod = 10;
4457         goto L9999;
4458     }
4459
4460 /* **********************************************************************
4461 */
4462 /*                  CASE WHEN UPARA1=VPARA1=0 AND UPARA2=VPARA2=1 */
4463 /* **********************************************************************
4464 */
4465
4466     if (*upara1 == 0. && *upara2 == 1. && *vpara1 == 0. && *vpara2 == 1.) {
4467         ksize = (*ndimen << 3) * *ncofmx * *ncoefv;
4468         AdvApp2Var_SysBase::mcrfill_(&ksize,
4469                  &patold[patold_offset],
4470                  &patnew[patnew_offset]);
4471         goto L9999;
4472     }
4473
4474 /* **********************************************************************
4475 */
4476 /*                        LIMITATION BY U */
4477 /* **********************************************************************
4478 */
4479
4480     if (*upara1 == 0. && *upara2 == 1.) {
4481         goto L2000;
4482     }
4483     i__1 = *ncoefv;
4484     for (kk = 1; kk <= i__1; ++kk) {
4485         mmarc41_(ndimen, ndimen, ncoefu, &patold[(kk * patold_dim2 + 1) *
4486                 patold_dim1 + 1], upara1, upara2, &patnew[(kk * patnew_dim2 +
4487                 1) * patnew_dim1 + 1], iercod);
4488 /* L100: */
4489     }
4490
4491 /* **********************************************************************
4492 */
4493 /*                         LIMITATION BY V */
4494 /* **********************************************************************
4495 */
4496
4497 L2000:
4498     if (*vpara1 == 0. && *vpara2 == 1.) {
4499         goto L9999;
4500     }
4501
4502 /* ----------- LIMITATION BY V (WITH COMPRESSION I.E. NCOEFU<NCOFMX) ----
4503 */
4504
4505     numax = *ndimen * *ncoefu;
4506     if (*ncofmx != *ncoefu) {
4507 /* ------------------------- Dynamic allocation -------------------
4508 ---- */
4509         ksize = *ndimen * *ncoefu * *ncoefv;
4510         anAdvApp2Var_SysBase.mcrrqst_(&c__8, &ksize, tbaux, &iofst, &ier);
4511         if (ier > 0) {
4512             *iercod = 13;
4513             goto L9900;
4514         }
4515 /* --------------- Compression by (NDIMEN,NCOEFU,NCOEFV) ------------
4516 ---- */
4517         if (*upara1 == 0. && *upara2 == 1.) {
4518           AdvApp2Var_MathBase::mmfmca9_(ndimen,
4519                                         ncofmx,
4520                                         ncoefv,
4521                                         ndimen,
4522                                         ncoefu,
4523                                         ncoefv,
4524                                         &patold[patold_offset],
4525                                         &tbaux[iofst]);
4526         } else {
4527           AdvApp2Var_MathBase::mmfmca9_(ndimen,
4528                                         ncofmx,
4529                                         ncoefv,
4530                                         ndimen,
4531                                         ncoefu,
4532                                         ncoefv,
4533                                         &patnew[patnew_offset],
4534                                         &tbaux[iofst]);
4535         }
4536 /* ------------------------- Limitation by v ------------------------
4537 ---- */
4538         mmarc41_(&numax, &numax, ncoefv, &tbaux[iofst], vpara1, vpara2, &
4539                 tbaux[iofst], iercod);
4540 /* --------------------- Expansion of TBAUX into PATNEW -------------
4541 --- */
4542         AdvApp2Var_MathBase::mmfmca8_(ndimen, ncoefu, ncoefv, ndimen, ncofmx, ncoefv, &tbaux[iofst]
4543                 , &patnew[patnew_offset]);
4544         goto L9900;
4545
4546 /* -------- LIMITATION BY V (WITHOUT COMPRESSION I.E. NCOEFU=NCOFMX) ---
4547 ---- */
4548
4549     } else {
4550         if (*upara1 == 0. && *upara2 == 1.) {
4551             mmarc41_(&numax, &numax, ncoefv, &patold[patold_offset], vpara1,
4552                     vpara2, &patnew[patnew_offset], iercod);
4553         } else {
4554             mmarc41_(&numax, &numax, ncoefv, &patnew[patnew_offset], vpara1,
4555                     vpara2, &patnew[patnew_offset], iercod);
4556         }
4557         goto L9999;
4558     }
4559
4560 /* **********************************************************************
4561 */
4562 /*                             DESALLOCATION */
4563 /* **********************************************************************
4564 */
4565
4566 L9900:
4567     if (iofst != 0) {
4568         anAdvApp2Var_SysBase.mcrdelt_(&c__8, &ksize, tbaux, &iofst, &ier);
4569     }
4570     if (ier > 0) {
4571         *iercod = 13;
4572     }
4573
4574 /* ------------------------------ The end -------------------------------
4575 */
4576
4577 L9999:
4578     if (*iercod > 0) {
4579         AdvApp2Var_SysBase::maermsg_("MMFMCAR", iercod, 7L);
4580     }
4581     if (ibb >= 2) {
4582         AdvApp2Var_SysBase::mgsomsg_("MMFMCAR", 7L);
4583     }
4584     return 0;
4585 } /* mmfmcar_ */
4586
4587
4588 //=======================================================================
4589 //function : AdvApp2Var_MathBase::mmfmcb5_
4590 //purpose  :
4591 //=======================================================================
4592 int AdvApp2Var_MathBase::mmfmcb5_(integer *isenmsc,
4593                                   integer *ndimax,
4594                                   integer *ncf1mx,
4595                                   doublereal *courb1,
4596                                   integer *ncoeff,
4597                                   integer *ncf2mx,
4598                                   integer *ndimen,
4599                                   doublereal *courb2,
4600                                   integer *iercod)
4601
4602 {
4603   /* System generated locals */
4604   integer courb1_dim1, courb1_offset, courb2_dim1, courb2_offset, i__1,
4605   i__2;
4606
4607   /* Local variables */
4608   integer i__, nboct, nd;
4609
4610
4611 /* **********************************************************************
4612 */
4613
4614 /*     FUNCTION : */
4615 /*     ---------- */
4616 /*       Reformating (and  eventual compression/decompression) of curve */
4617 /*       (ndim,.) by (.,ndim) and vice versa. */
4618
4619 /*     KEYWORDS : */
4620 /*     ----------- */
4621 /*      ALL , MATH_ACCES :: */
4622 /*      COURBE&, REORGANISATION,COMPRESSION,INVERSION , &COURBE */
4623
4624 /*     INPUT ARGUMENTS : */
4625 /*     -------------------- */
4626 /*        ISENMSC : required direction of the transfer : */
4627 /*           1   :  passage of (NDIMEN,.) ---> (.,NDIMEN)  direction to AB
4628 */
4629 /*          -1   :  passage of (.,NDIMEN) ---> (NDIMEN,.)  direction to TS,T
4630 V*/
4631 /*        NDIMAX : format / dimension */
4632 /*        NCF1MX : format by t of COURB1 */
4633 /*   if ISENMSC= 1 : COURB1: The curve to be processed (NDIMAX,.) */
4634 /*        NCOEFF : number of coeff of the curve */
4635 /*        NCF2MX : format by t of COURB2 */
4636 /*        NDIMEN : dimension of the curve and format of COURB2 */
4637 /*   if ISENMSC=-1 : COURB2: The curve to be processed (.,NDIMEN) */
4638
4639 /*     OUTPUT ARGUMENTS : */
4640 /*     --------------------- */
4641 /*   if ISENMSC= 1 : COURB2: The resulting curve (.,NDIMEN) */
4642 /*   if ISENMSC=-1 : COURB1: The resulting curve (NDIMAX,.) */
4643
4644 /*     COMMONS USED : */
4645 /*     ------------------ */
4646
4647 /*     REFERENCES CALLED : */
4648 /*     --------------------- */
4649
4650 /*     DESCRIPTION/NOTES/LIMITATIONS : */
4651 /*     ----------------------------------- */
4652 /*     allow to process the usual transfers as follows : */
4653 /*     | ---- ISENMSC = 1 ---- |      | ---- ISENMSC =-1 ----- | */
4654 /*    TS  (3,21) --> (21,3)  AB  ;  AB  (21,3) --> (3,21)  TS */
4655 /*    TS  (3,21) --> (NU,3)  AB  ;  AB  (NU,3) --> (3,21)  TS */
4656 /*        (3,NU) --> (21,3)  AB  ;  AB  (21,3) --> (3,NU) */
4657 /*        (3,NU) --> (NU,3)  AB  ;  AB  (NU,3) --> (3,NU) */
4658 /* > */
4659 /* ***********************************************************************
4660  */
4661
4662
4663     /* Parameter adjustments */
4664     courb1_dim1 = *ndimax;
4665     courb1_offset = courb1_dim1 + 1;
4666     courb1 -= courb1_offset;
4667     courb2_dim1 = *ncf2mx;
4668     courb2_offset = courb2_dim1 + 1;
4669     courb2 -= courb2_offset;
4670
4671     /* Function Body */
4672     if (*ndimen > *ndimax || *ncoeff > *ncf1mx || *ncoeff > *ncf2mx) {
4673         goto L9119;
4674     }
4675
4676     if (*ndimen == 1 && *ncf1mx == *ncf2mx) {
4677         nboct = *ncf2mx << 3;
4678         if (*isenmsc == 1) {
4679             AdvApp2Var_SysBase::mcrfill_(&nboct,
4680                      &courb1[courb1_offset],
4681                      &courb2[courb2_offset]);
4682         }
4683         if (*isenmsc == -1) {
4684             AdvApp2Var_SysBase::mcrfill_(&nboct,
4685                      &courb2[courb2_offset],
4686                      &courb1[courb1_offset]);
4687         }
4688         *iercod = -3136;
4689         goto L9999;
4690     }
4691
4692     *iercod = 0;
4693     if (*isenmsc == 1) {
4694         i__1 = *ndimen;
4695         for (nd = 1; nd <= i__1; ++nd) {
4696             i__2 = *ncoeff;
4697             for (i__ = 1; i__ <= i__2; ++i__) {
4698                 courb2[i__ + nd * courb2_dim1] = courb1[nd + i__ *
4699                         courb1_dim1];
4700 /* L400: */
4701             }
4702 /* L500: */
4703         }
4704     } else if (*isenmsc == -1) {
4705         i__1 = *ndimen;
4706         for (nd = 1; nd <= i__1; ++nd) {
4707             i__2 = *ncoeff;
4708             for (i__ = 1; i__ <= i__2; ++i__) {
4709                 courb1[nd + i__ * courb1_dim1] = courb2[i__ + nd *
4710                         courb2_dim1];
4711 /* L1400: */
4712             }
4713 /* L1500: */
4714         }
4715     } else {
4716         *iercod = 3164;
4717     }
4718
4719     goto L9999;
4720
4721 /* ***********************************************************************
4722  */
4723
4724 L9119:
4725     *iercod = 3119;
4726
4727 L9999:
4728     if (*iercod != 0) {
4729         AdvApp2Var_SysBase::maermsg_("MMFMCB5", iercod, 7L);
4730     }
4731     return 0;
4732 } /* mmfmcb5_ */
4733
4734 //=======================================================================
4735 //function : AdvApp2Var_MathBase::mmfmtb1_
4736 //purpose  :
4737 //=======================================================================
4738 int AdvApp2Var_MathBase::mmfmtb1_(integer *maxsz1,
4739                                   doublereal *table1,
4740                                   integer *isize1,
4741                                   integer *jsize1,
4742                                   integer *maxsz2,
4743                                   doublereal *table2,
4744                                   integer *isize2,
4745                                   integer *jsize2,
4746                                   integer *iercod)
4747 {
4748   integer c__8 = 8;
4749
4750    /* System generated locals */
4751     integer table1_dim1, table1_offset, table2_dim1, table2_offset, i__1,
4752             i__2;
4753
4754     /* Local variables */
4755     doublereal* work = 0;
4756     integer ilong, isize, ii, jj, ier = 0;
4757     intptr_t iofst = 0,iipt, jjpt;
4758
4759
4760 /************************************************************************
4761 *******/
4762
4763 /*     FUNCTION : */
4764 /*     ---------- */
4765 /*     Inversion of elements of a rectangular table (T1(i,j) */
4766 /*     loaded in T2(j,i)) */
4767
4768 /*     KEYWORDS : */
4769 /*     ----------- */
4770 /*      ALL, MATH_ACCES :: TABLEAU&, INVERSION, &TABLEAU */
4771
4772 /*     INPUT ARGUMENTS : */
4773 /*     ------------------ */
4774 /*     MAXSZ1: Max Nb of elements by the 1st dimension of TABLE1. */
4775 /*     TABLE1: Table of reals by two dimensions. */
4776 /*     ISIZE1: Nb of useful elements of TABLE1 on the 1st dimension */
4777 /*     JSIZE1: Nb of useful elements of TABLE1 on the 2nd dimension */
4778 /*     MAXSZ2: Nb max of elements by the 1st dimension of TABLE2. */
4779
4780 /*     OUTPUT ARGUMENTS : */
4781 /*     ------------------- */
4782 /*     TABLE2: Table of reals by two dimensions, containing the transposition */
4783 /*             of the rectangular table TABLE1. */
4784 /*     ISIZE2: Nb of useful elements of TABLE2 on the 1st dimension */
4785 /*     JSIZE2: Nb of useful elements of TABLE2 on the 2nd dimension */
4786 /*     IERCOD: Erroe coder. */
4787 /*             = 0, ok. */
4788 /*             = 1, error in the dimension of tables */
4789 /*                  ether MAXSZ1 < ISIZE1 (table TABLE1 too small). */
4790 /*                  or MAXSZ2 < JSIZE1 (table TABLE2 too small). */
4791
4792 /*     COMMONS USED   : */
4793 /*     ---------------- */
4794
4795 /*     REFERENCES CALLED   : */
4796 /*     ---------------------- */
4797
4798 /*     DESCRIPTION/NOTES/LIMITATIONS : */
4799 /*     ----------------------------------- */
4800 /*    It is possible to use TABLE1 as input and output table i.e. */
4801 /*    call: */
4802 /*    CALL MMFMTB1(MAXSZ1,TABLE1,ISIZE1,JSIZE1,MAXSZ2,TABLE1 */
4803 /*               ,ISIZE2,JSIZE2,IERCOD) */
4804 /*    is valuable. */
4805 /* > */
4806 /* **********************************************************************
4807 */
4808
4809
4810     /* Parameter adjustments */
4811     table1_dim1 = *maxsz1;
4812     table1_offset = table1_dim1 + 1;
4813     table1 -= table1_offset;
4814     table2_dim1 = *maxsz2;
4815     table2_offset = table2_dim1 + 1;
4816     table2 -= table2_offset;
4817     AdvApp2Var_SysBase anAdvApp2Var_SysBase;
4818
4819     /* Function Body */
4820     *iercod = 0;
4821     if (*isize1 > *maxsz1 || *jsize1 > *maxsz2) {
4822         goto L9100;
4823     }
4824
4825     iofst = 0;
4826     isize = *maxsz2 * *isize1;
4827     anAdvApp2Var_SysBase.mcrrqst_(&c__8, &isize, work, &iofst, &ier);
4828     if (ier > 0) {
4829         goto L9200;
4830     }
4831
4832 /*             DO NOT BE AFRAID OF CRUSHING. */
4833
4834     i__1 = *isize1;
4835     for (ii = 1; ii <= i__1; ++ii) {
4836         iipt = (ii - 1) * *maxsz2 + iofst;
4837         i__2 = *jsize1;
4838         for (jj = 1; jj <= i__2; ++jj) {
4839             jjpt = iipt + (jj - 1);
4840             work[jjpt] = table1[ii + jj * table1_dim1];
4841 /* L200: */
4842         }
4843 /* L100: */
4844     }
4845     ilong = isize << 3;
4846     AdvApp2Var_SysBase::mcrfill_(&ilong,
4847              &work[iofst],
4848              &table2[table2_offset]);
4849
4850 /* -------------- The number of elements of TABLE2 is returned ------------
4851 */
4852
4853     ii = *isize1;
4854     *isize2 = *jsize1;
4855     *jsize2 = ii;
4856
4857     goto L9999;
4858
4859 /* ------------------------------- THE END ------------------------------
4860 */
4861 /* --> Invalid input. */
4862 L9100:
4863     *iercod = 1;
4864     goto L9999;
4865 /* --> Pb of allocation. */
4866 L9200:
4867     *iercod = 2;
4868     goto L9999;
4869
4870 L9999:
4871     if (iofst != 0) {
4872         anAdvApp2Var_SysBase.mcrdelt_(&c__8, &isize, work, &iofst, &ier);
4873     }
4874     if (ier > 0) {
4875         *iercod = 2;
4876     }
4877     return 0;
4878 } /* mmfmtb1_ */
4879
4880 //=======================================================================
4881 //function : AdvApp2Var_MathBase::mmgaus1_
4882 //purpose  :
4883 //=======================================================================
4884 int AdvApp2Var_MathBase::mmgaus1_(integer *ndimf,
4885                                   int (*bfunx) (
4886                                                 integer *ninteg,
4887                                                 doublereal *parame,
4888                                                 doublereal *vfunj1,
4889                                                 integer *iercod
4890                                                 ),
4891
4892                                   integer *k,
4893                                   doublereal *xd,
4894                                   doublereal *xf,
4895                                   doublereal *saux1,
4896                                   doublereal *saux2,
4897                                   doublereal *somme,
4898                                   integer *niter,
4899                                   integer *iercod)
4900 {
4901   /* System generated locals */
4902   integer i__1, i__2;
4903
4904   /* Local variables */
4905   integer ndeg;
4906   doublereal h__[20];
4907   integer j;
4908   doublereal t, u[20], x;
4909   integer idimf;
4910   doublereal c1x, c2x;
4911 /* **********************************************************************
4912 */
4913
4914 /*      FUNCTION : */
4915 /*      -------- */
4916
4917 /*      Calculate the integral of  function BFUNX passed in parameter */
4918 /*      between limits XD and XF . */
4919 /*      The function should be calculated for any value */
4920 /*      of the variable in the given interval.. */
4921 /*      The method GAUSS-LEGENDRE is used. */
4922 /*      For explications refer to the book : */
4923 /*          Complements de mathematiques a l'usage des Ingenieurs de */
4924 /*          l'electrotechnique et des telecommunications. */
4925 /*          Par Andre ANGOT - Collection technique et scientifique du CNET
4926  */
4927 /*          page 772 .... */
4928 /*      The degree of LEGENDRE polynoms used is passed in parameter.
4929  */
4930 /*      KEYWORDS : */
4931 /*      --------- */
4932 /*         INTEGRATION,LEGENDRE,GAUSS */
4933
4934 /*      INPUT ARGUMENTS : */
4935 /*      ------------------ */
4936
4937 /*      NDIMF : Dimension of the function */
4938 /*      BFUNX : Function to integrate passed as argument */
4939 /*              Should be declared as EXTERNAL in the call routine. */
4940 /*                   SUBROUTINE BFUNX(NDIMF,X,VAL,IER) */
4941 /*                   REAL *8 X,VAL */
4942 /*     K      : Parameter determining the degree of the LEGENDRE polynom that
4943 */
4944 /*               can take a value between 0 and 10. */
4945 /*               The degree of the polynom is equal to 4 k, that is 4, 8,
4946 */
4947 /*               12, 16, 20, 24, 28, 32, 36 and 40. */
4948 /*               If K is not correct, the degree is set to 40 directly.
4949 */
4950 /*      XD     : Lower limit of the interval of integration. */
4951 /*      XF     : Upper limit of the interval of integration. */
4952 /*      SAUX1  : Auxiliary table */
4953 /*      SAUX2  : Auxiliary table */
4954
4955 /*      OUTPUT ARGUMENTS : */
4956 /*      ------------------- */
4957
4958 /*      SOMME : Value of the integral */
4959 /*      NITER : Number of iterations to be carried out. */
4960 /*              It is equal to the degree of the polynom. */
4961
4962 /*      IER   : Error code : */
4963 /*              < 0 ==> Attention - Warning */
4964 /*              = 0 ==> Everything is OK */
4965 /*              > 0 ==> Critical error - Apply special processing */
4966 /*                  ==> Error in the calculation of BFUNX (return code */
4967 /*                      of this routine */
4968
4969 /*              If error => SUM = 0 */
4970
4971 /*      COMMONS USED : */
4972 /*      ----------------- */
4973
4974
4975
4976 /*     REFERENCES CALLED   : */
4977 /*     ---------------------- */
4978
4979 /*     Type  Name */
4980 /*    @      BFUNX               MVGAUS0 */
4981
4982 /*      DESCRIPTION/NOTES/LIMITATIONS : */
4983 /*      --------------------------------- */
4984
4985 /*      See the explanations detailed in the listing */
4986 /*      Use of the GAUSS method (orthogonal polynoms) */
4987 /*      The symmetry of roots of these polynomes is used */
4988 /*      Depending on K, the degree of the interpolated polynom grows.
4989 */
4990 /*      If you wish to calculate the integral with a given precision, */
4991 /*      loop on k varying from 1 to 10 and test the difference of 2
4992 */
4993 /*      consecutive iterations. Stop the loop if this difference is less that */
4994 /*      an epsilon value set to 10E-6 for example. */
4995 /*      If S1 and S2 are 2 successive iterations, test following this example :
4996  */
4997
4998 /*            AF=DABS(S1-S2) */
4999 /*            AS=DABS(S2) */
5000 /*            If AS < 1 test if FS < eps otherwise test if AF/AS < eps
5001 */
5002 /*            --        -----                    ----- */
5003 /* > */
5004 /************************************************************************
5005 ******/
5006 /*     DECLARATIONS */
5007 /************************************************************************
5008 ******/
5009
5010
5011
5012 /* ****** General Initialization */
5013
5014     /* Parameter adjustments */
5015     --somme;
5016     --saux2;
5017     --saux1;
5018
5019     /* Function Body */
5020     AdvApp2Var_SysBase::mvriraz_(ndimf,
5021              &somme[1]);
5022     *iercod = 0;
5023
5024 /* ****** Loading of coefficients U and H ** */
5025 /* -------------------------------------------- */
5026
5027     mvgaus0_(k, u, h__, &ndeg, iercod);
5028     if (*iercod > 0) {
5029         goto L9999;
5030     }
5031
5032 /* ****** C1X => Medium interval point  [XD,XF] */
5033 /* ****** C2X => 1/2 amplitude interval [XD,XF] */
5034
5035     c1x = (*xf + *xd) * .5;
5036     c2x = (*xf - *xd) * .5;
5037
5038 /* ---------------------------------------- */
5039 /* ****** Integration for degree NDEG ** */
5040 /* ---------------------------------------- */
5041
5042     i__1 = ndeg;
5043     for (j = 1; j <= i__1; ++j) {
5044         t = c2x * u[j - 1];
5045
5046         x = c1x + t;
5047         (*bfunx)(ndimf, &x, &saux1[1], iercod);
5048         if (*iercod != 0) {
5049             goto L9999;
5050         }
5051
5052         x = c1x - t;
5053         (*bfunx)(ndimf, &x, &saux2[1], iercod);
5054         if (*iercod != 0) {
5055             goto L9999;
5056         }
5057
5058         i__2 = *ndimf;
5059         for (idimf = 1; idimf <= i__2; ++idimf) {
5060             somme[idimf] += h__[j - 1] * (saux1[idimf] + saux2[idimf]);
5061         }
5062
5063     }
5064
5065     *niter = ndeg << 1;
5066     i__1 = *ndimf;
5067     for (idimf = 1; idimf <= i__1; ++idimf) {
5068         somme[idimf] *= c2x;
5069     }
5070
5071 /* ****** End of sub-program ** */
5072
5073 L9999:
5074
5075  return 0   ;
5076 } /* mmgaus1_ */
5077 //=======================================================================
5078 //function : mmherm0_
5079 //purpose  :
5080 //=======================================================================
5081 int mmherm0_(doublereal *debfin,
5082              integer *iercod)
5083 {
5084   integer c__576 = 576;
5085   integer c__6 = 6;
5086
5087
5088    /* System generated locals */
5089     integer i__1, i__2;
5090     doublereal d__1;
5091
5092     /* Local variables */
5093     doublereal amat[36] /* was [6][6] */;
5094     integer iord[2];
5095     doublereal prod;
5096     integer iord1, iord2;
5097     doublereal miden[36]        /* was [6][6] */;
5098     integer ncmat;
5099     doublereal epspi, d1, d2;
5100     integer ii, jj, pp, ncf;
5101     doublereal cof[6];
5102     integer iof[2], ier;
5103     doublereal mat[36]  /* was [6][6] */;
5104     integer cot;
5105     doublereal abid[72] /* was [12][6] */;
5106 /* ***********************************************************************
5107  */
5108
5109 /*     FUNCTION : */
5110 /*     ---------- */
5111 /*      INIT OF COEFFS. OF POLYNOMS OF HERMIT INTERPOLATION */
5112
5113 /*     KEYWORDS : */
5114 /*     ----------- */
5115 /*      MATH_ACCES :: HERMITE */
5116
5117 /*     INPUT ARGUMENTS */
5118 /*     -------------------- */
5119 /*       DEBFIN : PARAMETERS DEFINING THE CONSTRAINTS */
5120 /*                 DEBFIN(1) : FIRST PARAMETER */
5121 /*                 DEBFIN(2) : SECOND PARAMETER */
5122
5123 /*      ONE SHOULD HAVE: */
5124 /*                 ABS (DEBFIN(I)) < 100 */
5125 /*                 and */
5126 /*                 (ABS(DEBFIN(1)+ABS(DEBFIN(2))) > 1/100 */
5127 /*           (for overflows) */
5128
5129 /*      ABS(DEBFIN(2)-DEBFIN(1)) / (ABS(DEBFIN(1)+ABS(DEBFIN(2))) > 1/100
5130 */
5131 /*           (for the conditioning) */
5132
5133
5134 /*     OUTPUT ARGUMENTS : */
5135 /*     --------------------- */
5136
5137 /*       IERCOD : Error code : 0 : O.K. */
5138 /*                                1 : value of DEBFIN */
5139 /*                                are unreasonable */
5140 /*                                -1 : init was already done */
5141 /*                                   (OK but no processing) */
5142
5143 /*     COMMONS USED : */
5144 /*     ------------------ */
5145
5146 /*     REFERENCES CALLED : */
5147 /*     ---------------------- */
5148 /*     Type  Name */
5149
5150 /*     DESCRIPTION/NOTES/LIMITATIONS : */
5151 /*     ----------------------------------- */
5152
5153 /*        This program initializes the coefficients of Hermit polynoms */
5154 /*     that are read later by MMHERM1 */
5155 /* ***********************************************************************
5156  */
5157
5158
5159
5160 /* **********************************************************************
5161 */
5162
5163 /*     FUNCTION : */
5164 /*     ---------- */
5165 /*      Used to STORE  coefficients of Hermit interpolation polynoms */
5166
5167 /*     KEYWORDS : */
5168 /*     ----------- */
5169 /*      HERMITE */
5170
5171 /*     DEMSCRIPTION/NOTES/LIMITATIONS : */
5172 /*     ----------------------------------- */
5173
5174 /*     The coefficients of hermit polynoms are calculated by */
5175 /*     the routine MMHERM0 and read by the routine MMHERM1 */
5176 /* > */
5177 /* **********************************************************************
5178 */
5179
5180
5181
5182
5183
5184 /*     NBCOEF is the size of CMHERM (see below) */
5185 /* ***********************************************************************
5186  */
5187
5188
5189
5190
5191
5192
5193
5194 /* ***********************************************************************
5195  */
5196 /*     Data checking */
5197 /* ***********************************************************************
5198  */
5199
5200
5201     /* Parameter adjustments */
5202     --debfin;
5203
5204     /* Function Body */
5205     d1 = advapp_abs(debfin[1]);
5206     if (d1 > (float)100.) {
5207         goto L9101;
5208     }
5209
5210     d2 = advapp_abs(debfin[2]);
5211     if (d2 > (float)100.) {
5212         goto L9101;
5213     }
5214
5215     d2 = d1 + d2;
5216     if (d2 < (float).01) {
5217         goto L9101;
5218     }
5219
5220     d1 = (d__1 = debfin[2] - debfin[1], advapp_abs(d__1));
5221     if (d1 / d2 < (float).01) {
5222         goto L9101;
5223     }
5224
5225
5226 /* ***********************************************************************
5227  */
5228 /*     Initialization */
5229 /* ***********************************************************************
5230  */
5231
5232     *iercod = 0;
5233
5234     epspi = 1e-10;
5235
5236
5237 /* ***********************************************************************
5238  */
5239
5240 /*     IS IT ALREADY INITIALIZED ? */
5241
5242     d1 = advapp_abs(debfin[1]) + advapp_abs(debfin[2]);
5243     d1 *= 16111959;
5244
5245     if (debfin[1] != mmcmher_.tdebut) {
5246         goto L100;
5247     }
5248     if (debfin[2] != mmcmher_.tfinal) {
5249         goto L100;
5250     }
5251     if (d1 != mmcmher_.verifi) {
5252         goto L100;
5253     }
5254
5255
5256     goto L9001;
5257
5258
5259 /* ***********************************************************************
5260  */
5261 /*     CALCULATION */
5262 /* ***********************************************************************
5263  */
5264
5265
5266 L100:
5267
5268 /*     Init. matrix identity : */
5269
5270     ncmat = 36;
5271     AdvApp2Var_SysBase::mvriraz_(&ncmat,
5272              miden);
5273
5274     for (ii = 1; ii <= 6; ++ii) {
5275         miden[ii + ii * 6 - 7] = 1.;
5276 /* L110: */
5277     }
5278
5279
5280
5281 /*     Init to 0 of table CMHERM */
5282
5283     AdvApp2Var_SysBase::mvriraz_(&c__576, mmcmher_.cmherm);
5284
5285 /*     Calculation by solution of linear systems */
5286
5287     for (iord1 = -1; iord1 <= 2; ++iord1) {
5288         for (iord2 = -1; iord2 <= 2; ++iord2) {
5289
5290             iord[0] = iord1;
5291             iord[1] = iord2;
5292
5293
5294             iof[0] = 0;
5295             iof[1] = iord[0] + 1;
5296
5297
5298             ncf = iord[0] + iord[1] + 2;
5299
5300 /*        Calculate matrix MAT to invert: */
5301
5302             for (cot = 1; cot <= 2; ++cot) {
5303
5304
5305                 if (iord[cot - 1] > -1) {
5306                     prod = 1.;
5307                     i__1 = ncf;
5308                     for (jj = 1; jj <= i__1; ++jj) {
5309                         cof[jj - 1] = 1.;
5310 /* L200: */
5311                     }
5312                 }
5313
5314                 i__1 = iord[cot - 1] + 1;
5315                 for (pp = 1; pp <= i__1; ++pp) {
5316
5317                     ii = pp + iof[cot - 1];
5318
5319                     prod = 1.;
5320
5321                     i__2 = pp - 1;
5322                     for (jj = 1; jj <= i__2; ++jj) {
5323                         mat[ii + jj * 6 - 7] = (float)0.;
5324 /* L300: */
5325                     }
5326
5327                     i__2 = ncf;
5328                     for (jj = pp; jj <= i__2; ++jj) {
5329
5330 /*        everything is done in these 3 lines
5331  */
5332
5333                         mat[ii + jj * 6 - 7] = cof[jj - 1] * prod;
5334                         cof[jj - 1] *= jj - pp;
5335                         prod *= debfin[cot];
5336
5337 /* L400: */
5338                     }
5339 /* L500: */
5340                 }
5341
5342 /* L1000: */
5343             }
5344
5345 /*     Inversion */
5346
5347             if (ncf >= 1) {
5348                 AdvApp2Var_MathBase::mmmrslwd_(&c__6, &ncf, &ncf, mat, miden, &epspi, abid, amat, &
5349                         ier);
5350                 if (ier > 0) {
5351                     goto L9101;
5352                 }
5353             }
5354
5355             for (cot = 1; cot <= 2; ++cot) {
5356                 i__1 = iord[cot - 1] + 1;
5357                 for (pp = 1; pp <= i__1; ++pp) {
5358                     i__2 = ncf;
5359                     for (ii = 1; ii <= i__2; ++ii) {
5360                         mmcmher_.cmherm[ii + (pp + (cot + ((iord1 + (iord2 <<
5361                                 2)) << 1)) * 3) * 6 + 155] = amat[ii + (pp +
5362                                 iof[cot - 1]) * 6 - 7];
5363 /* L1300: */
5364                     }
5365 /* L1400: */
5366                 }
5367 /* L1500: */
5368             }
5369
5370 /* L2000: */
5371         }
5372 /* L2010: */
5373     }
5374
5375 /* ***********************************************************************
5376  */
5377
5378 /*     The initialized flag is located: */
5379
5380     mmcmher_.tdebut = debfin[1];
5381     mmcmher_.tfinal = debfin[2];
5382
5383     d1 = advapp_abs(debfin[1]) + advapp_abs(debfin[2]);
5384     mmcmher_.verifi = d1 * 16111959;
5385
5386
5387 /* ***********************************************************************
5388  */
5389
5390     goto L9999;
5391
5392 /* ***********************************************************************
5393  */
5394
5395 L9101:
5396     *iercod = 1;
5397     goto L9999;
5398
5399 L9001:
5400     *iercod = -1;
5401     goto L9999;
5402
5403 /* ***********************************************************************
5404  */
5405
5406 L9999:
5407
5408     AdvApp2Var_SysBase::maermsg_("MMHERM0", iercod, 7L);
5409
5410 /* ***********************************************************************
5411  */
5412  return 0 ;
5413 } /* mmherm0_ */
5414
5415 //=======================================================================
5416 //function : mmherm1_
5417 //purpose  :
5418 //=======================================================================
5419 int mmherm1_(doublereal *debfin,
5420              integer *ordrmx,
5421              integer *iordre,
5422              doublereal *hermit,
5423              integer *iercod)
5424 {
5425   /* System generated locals */
5426   integer hermit_dim1, hermit_dim2, hermit_offset;
5427
5428   /* Local variables */
5429   integer nbval;
5430   doublereal d1;
5431   integer cot;
5432
5433 /* ***********************************************************************
5434  */
5435
5436 /*     FUNCTION : */
5437 /*     ---------- */
5438 /*      reading of coeffs. of HERMIT interpolation polynoms */
5439
5440 /*     KEYWORDS : */
5441 /*     ----------- */
5442 /*      MATH_ACCES :: HERMIT */
5443
5444 /*     INPUT ARGUMENTS : */
5445 /*     -------------------- */
5446 /*       DEBFIN : PARAMETES DEFINING THE CONSTRAINTS */
5447 /*                 DEBFIN(1) : FIRST PARAMETER */
5448 /*                 DEBFIN(2) : SECOND PARAMETER */
5449
5450 /*           Should be equal to the corresponding arguments during the */
5451 /*           last call to MMHERM0 for the initialization of coeffs. */
5452
5453 /*       ORDRMX : indicates the dimensioning of HERMIT: */
5454 /*              there is no choice : ORDRMX should be equal to the value */
5455 /*              of PARAMETER IORDMX of INCLUDE MMCMHER, or 2 for the moment */
5456
5457 /*       IORDRE (2) : Orders of constraints in each corresponding parameter DEBFIN(I) */
5458 /*              should be between -1 (no constraints) and ORDRMX. */
5459
5460
5461 /*     OUTPUT ARGUMENTS : */
5462 /*     --------------------- */
5463
5464 /*       HERMIT : HERMIT(1:IORDRE(1)+IORDRE(2)+2, j, cote) are the  */
5465 /*       coefficients in the canonic base of Hermit polynom */
5466 /*       corresponding to orders IORDRE with parameters DEBFIN for */
5467 /*       the constraint of order j on DEBFIN(cote). j is between 0 and IORDRE(cote). */
5468
5469
5470 /*       IERCOD : Error code : */
5471 /*          -1: O.K but necessary to reinitialize the coefficients */
5472 /*                 (info for optimization) */
5473 /*          0 : O.K. */
5474 /*          1 : Error in MMHERM0 */
5475 /*          2 : arguments invalid */
5476
5477 /*     COMMONS USED : */
5478 /*     ------------------ */
5479
5480 /*     REFERENCES CALLED   : */
5481 /*     ---------------------- */
5482 /*     Type  Name */
5483
5484 /*     DESCRIPTION/NOTES/LIMITATIONS : */
5485 /*     ----------------------------------- */
5486
5487 /*     This program reads coefficients of Hermit polynoms */
5488 /*     that were earlier initialized by MMHERM0 */
5489
5490 /* PMN : initialisation is no more done by the caller. */
5491
5492
5493 /* ***********************************************************************
5494  */
5495
5496
5497
5498 /* **********************************************************************
5499 */
5500
5501 /*     FUNCTION : */
5502 /*     ---------- */
5503 /*      Serves to STORE the coefficients of Hermit interpolation polynoms */
5504
5505 /*     KEYWORDS : */
5506 /*     ----------- */
5507 /*      HERMITE */
5508
5509 /*     DEMSCRIPTION/NOTES/LIMITATIONS : */
5510 /*     ----------------------------------- */
5511
5512 /*     the coefficients of Hetmit polynoms are calculated by */
5513 /*     routine MMHERM0 and read by routine MMHERM1 */
5514
5515 /* > */
5516 /* **********************************************************************
5517 */
5518
5519
5520
5521
5522
5523 /*     NBCOEF is the size of CMHERM (see lower) */
5524
5525
5526
5527 /* ***********************************************************************
5528  */
5529
5530
5531
5532
5533
5534 /* ***********************************************************************
5535  */
5536 /*     Initializations */
5537 /* ***********************************************************************
5538  */
5539
5540     /* Parameter adjustments */
5541     --debfin;
5542     hermit_dim1 = (*ordrmx << 1) + 2;
5543     hermit_dim2 = *ordrmx + 1;
5544     hermit_offset = hermit_dim1 * hermit_dim2 + 1;
5545     hermit -= hermit_offset;
5546     --iordre;
5547
5548     /* Function Body */
5549     *iercod = 0;
5550
5551
5552 /* ***********************************************************************
5553  */
5554 /*     Data Checking */
5555 /* ***********************************************************************
5556  */
5557
5558
5559     if (*ordrmx != 2) {
5560         goto L9102;
5561     }
5562
5563     for (cot = 1; cot <= 2; ++cot) {
5564         if (iordre[cot] < -1) {
5565             goto L9102;
5566         }
5567         if (iordre[cot] > *ordrmx) {
5568             goto L9102;
5569         }
5570 /* L100: */
5571     }
5572
5573
5574 /*     IS-IT CORRECTLY INITIALIZED ? */
5575
5576     d1 = advapp_abs(debfin[1]) + advapp_abs(debfin[2]);
5577     d1 *= 16111959;
5578
5579 /*     OTHERWISE IT IS INITIALIZED */
5580
5581     if (debfin[1] != mmcmher_.tdebut || debfin[2] != mmcmher_.tfinal || d1
5582             != mmcmher_.verifi) {
5583         *iercod = -1;
5584         mmherm0_(&debfin[1], iercod);
5585         if (*iercod > 0) {
5586             goto L9101;
5587         }
5588     }
5589
5590
5591 /* ***********************************************************************
5592  */
5593 /*        READING */
5594 /* ***********************************************************************
5595  */
5596
5597     nbval = 36;
5598
5599     AdvApp2Var_SysBase::msrfill_(&nbval, &mmcmher_.cmherm[((((iordre[1] + (iordre[2] << 2)) << 1)
5600             + 1) * 3 + 1) * 6 + 156], &hermit[hermit_offset]);
5601
5602 /* ***********************************************************************
5603  */
5604
5605     goto L9999;
5606
5607 /* ***********************************************************************
5608  */
5609
5610 L9101:
5611     *iercod = 1;
5612     goto L9999;
5613
5614 L9102:
5615     *iercod = 2;
5616     goto L9999;
5617
5618 /* ***********************************************************************
5619  */
5620
5621 L9999:
5622
5623     AdvApp2Var_SysBase::maermsg_("MMHERM1", iercod, 7L);
5624
5625 /* ***********************************************************************
5626  */
5627  return 0 ;
5628 } /* mmherm1_ */
5629
5630 //=======================================================================
5631 //function : AdvApp2Var_MathBase::mmhjcan_
5632 //purpose  :
5633 //=======================================================================
5634 int AdvApp2Var_MathBase::mmhjcan_(integer *ndimen,
5635                             integer *ncourb,
5636                             integer *ncftab,
5637                             integer *orcont,
5638                             integer *ncflim,
5639                             doublereal *tcbold,
5640                             doublereal *tdecop,
5641                             doublereal *tcbnew,
5642                             integer *iercod)
5643
5644 {
5645   integer c__2 = 2;
5646   integer c__21 = 21;
5647   /* System generated locals */
5648     integer tcbold_dim1, tcbold_dim2, tcbold_offset, tcbnew_dim1, tcbnew_dim2,
5649              tcbnew_offset, i__1, i__2, i__3, i__4, i__5;
5650
5651
5652     /* Local variables */
5653     logical ldbg;
5654     integer ndeg;
5655     doublereal taux1[21];
5656     integer d__, e, i__, k;
5657     doublereal mfact;
5658     integer ncoeff;
5659     doublereal tjacap[21];
5660     integer iordre[2];
5661     doublereal hermit[36]/* was [6][3][2] */, ctenor, bornes[2];
5662     integer ier;
5663     integer aux1, aux2;
5664
5665 /* ***********************************************************************
5666  */
5667
5668 /*     FUNCTION : */
5669 /*     ---------- */
5670 /*       CONVERSION OF TABLE TCBOLD OF POLYNOMIAL CURVE COEFFICIENTS */
5671 /*       EXPRESSED IN HERMIT JACOBI BASE, INTO A */
5672 /*       TABLE OF COEFFICIENTS TCBNEW OF COURVES EXPRESSED IN THE CANONIC BASE */
5673
5674 /*     KEYWORDS : */
5675 /*     ----------- */
5676 /*      CANNONIC, HERMIT, JACCOBI */
5677
5678 /*     INPUT ARGUMENTS : */
5679 /*     -------------------- */
5680 /*       ORDHER : ORDER OF HERMIT POLYNOMS OR ORDER OF CONTINUITY */
5681 /*       NCOEFS : NUMBER OF COEFFICIENTS OF A POLYNOMIAL CURVE */
5682 /*                FOR ONE OF ITS NDIM COMPONENTS;(DEGREE+1 OF THE CURVE)
5683 */
5684 /*       NDIM   : DIMENSION OF THE CURVE */
5685 /*       CBHEJA : TABLE OF COEFFICIENTS OF THE CURVE IN THE BASE */
5686 /*                HERMIT JACOBI */
5687 /*                (H(0,-1),..,H(ORDHER,-1),H(0,1),..,H(ORDHER,1), */
5688 /*                 JA(ORDHER+1,2*ORDHER+2),....,JA(ORDHER+1,NCOEFS-1) */
5689
5690 /*     OUTPUT ARGUMENTS  : */
5691 /*     --------------------- */
5692 /*       CBRCAN : TABLE OF COEFFICIENTS OF THE CURVE IN THE CANONIC BASE */
5693 /*                (1, t, ...) */
5694
5695 /*     COMMONS USED : */
5696 /*     ------------------ */
5697
5698
5699 /*     REFERENCES CALLED : */
5700 /*     --------------------- */
5701
5702
5703 /* ***********************************************************************
5704  */
5705
5706
5707 /* ***********************************************************************
5708  */
5709
5710 /*     FUNCTION : */
5711 /*     ---------- */
5712 /*        Providesinteger constants from 0 to 1000 */
5713
5714 /*     KEYWORDS : */
5715 /*     ----------- */
5716 /*        ALL, INTEGER */
5717
5718 /*     DEMSCRIPTION/NOTES/LIMITATIONS : */
5719 /*     ----------------------------------- */
5720 /* > */
5721 /* ***********************************************************************
5722  */
5723
5724
5725 /* ***********************************************************************
5726  */
5727
5728
5729
5730
5731 /* ***********************************************************************
5732  */
5733 /*                      INITIALIZATION */
5734 /* ***********************************************************************
5735  */
5736
5737     /* Parameter adjustments */
5738     --ncftab;
5739     tcbnew_dim1 = *ndimen;
5740     tcbnew_dim2 = *ncflim;
5741     tcbnew_offset = tcbnew_dim1 * (tcbnew_dim2 + 1) + 1;
5742     tcbnew -= tcbnew_offset;
5743     tcbold_dim1 = *ndimen;
5744     tcbold_dim2 = *ncflim;
5745     tcbold_offset = tcbold_dim1 * (tcbold_dim2 + 1) + 1;
5746     tcbold -= tcbold_offset;
5747
5748     /* Function Body */
5749     ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 2;
5750     if (ldbg) {
5751         AdvApp2Var_SysBase::mgenmsg_("MMHJCAN", 7L);
5752     }
5753     *iercod = 0;
5754
5755     bornes[0] = -1.;
5756     bornes[1] = 1.;
5757
5758 /* ***********************************************************************
5759  */
5760 /*                     PROCESSING */
5761 /* ***********************************************************************
5762  */
5763
5764     if (*orcont > 2) {
5765         goto L9101;
5766     }
5767     if (*ncflim > 21) {
5768         goto L9101;
5769     }
5770
5771 /*     CALCULATION OF HERMIT POLYNOMS IN THE CANONIC BASE ON (-1,1) */
5772
5773
5774     iordre[0] = *orcont;
5775     iordre[1] = *orcont;
5776     mmherm1_(bornes, &c__2, iordre, hermit, &ier);
5777     if (ier > 0) {
5778         goto L9102;
5779     }
5780
5781
5782     aux1 = *orcont + 1;
5783     aux2 = aux1 << 1;
5784
5785     i__1 = *ncourb;
5786     for (e = 1; e <= i__1; ++e) {
5787
5788         ctenor = (tdecop[e] - tdecop[e - 1]) / 2;
5789         ncoeff = ncftab[e];
5790         ndeg = ncoeff - 1;
5791         if (ncoeff > 21) {
5792             goto L9101;
5793         }
5794
5795         i__2 = *ndimen;
5796         for (d__ = 1; d__ <= i__2; ++d__) {
5797
5798 /*     CONVERSION OF THE COEFFICIENTS OF THE PART OF THE CURVE EXPRESSED */
5799 /*     IN HERMIT BASE, INTO THE CANONIC BASE */
5800
5801             AdvApp2Var_SysBase::mvriraz_(&ncoeff, taux1);
5802
5803             i__3 = aux2;
5804             for (k = 1; k <= i__3; ++k) {
5805                 i__4 = aux1;
5806                 for (i__ = 1; i__ <= i__4; ++i__) {
5807                     i__5 = i__ - 1;
5808                     mfact = AdvApp2Var_MathBase::pow__di(&ctenor, &i__5);
5809                     taux1[k - 1] += (tcbold[d__ + (i__ + e * tcbold_dim2) *
5810                             tcbold_dim1] * hermit[k + (i__ + 2) * 6 - 19] +
5811                             tcbold[d__ + (i__ + aux1 + e * tcbold_dim2) *
5812                             tcbold_dim1] * hermit[k + (i__ + 5) * 6 - 19]) *
5813                             mfact;
5814                 }
5815             }
5816
5817
5818             i__3 = ncoeff;
5819             for (i__ = aux2 + 1; i__ <= i__3; ++i__) {
5820                 taux1[i__ - 1] = tcbold[d__ + (i__ + e * tcbold_dim2) *
5821                         tcbold_dim1];
5822             }
5823
5824 /*     CONVERSION OF THE COEFFICIENTS OF THE PART OF THE CURVE EXPRESSED */
5825 /*     IN CANONIC-JACOBI BASE, INTO THE CANONIC BASE */
5826
5827
5828
5829             AdvApp2Var_MathBase::mmapcmp_(&minombr_.nbr[1], &c__21, &ncoeff, taux1, tjacap);
5830             AdvApp2Var_MathBase::mmjacan_(orcont, &ndeg, tjacap, taux1);
5831
5832 /*        RECOPY THE COEFS RESULTING FROM THE CONVERSION IN THE TABLE */
5833 /*        OF RESULTS */
5834
5835             i__3 = ncoeff;
5836             for (i__ = 1; i__ <= i__3; ++i__) {
5837                 tcbnew[d__ + (i__ + e * tcbnew_dim2) * tcbnew_dim1] = taux1[
5838                         i__ - 1];
5839             }
5840
5841         }
5842     }
5843
5844     goto L9999;
5845
5846 /* ***********************************************************************
5847  */
5848 /*                   PROCESSING OF ERRORS */
5849 /* ***********************************************************************
5850  */
5851
5852 L9101:
5853     *iercod = 1;
5854     goto L9999;
5855 L9102:
5856     *iercod = 2;
5857     goto L9999;
5858
5859 /* ***********************************************************************
5860  */
5861 /*                   RETURN CALLING PROGRAM */
5862 /* ***********************************************************************
5863  */
5864
5865 L9999:
5866
5867     AdvApp2Var_SysBase::maermsg_("MMHJCAN", iercod, 7L);
5868     if (ldbg) {
5869         AdvApp2Var_SysBase::mgsomsg_("MMHJCAN", 7L);
5870     }
5871  return 0 ;
5872 } /* mmhjcan_ */
5873
5874 //=======================================================================
5875 //function : AdvApp2Var_MathBase::mminltt_
5876 //purpose  :
5877 //=======================================================================
5878  int AdvApp2Var_MathBase::mminltt_(integer *ncolmx,
5879                             integer *nlgnmx,
5880                             doublereal *tabtri,
5881                             integer *nbrcol,
5882                             integer *nbrlgn,
5883                             doublereal *ajoute,
5884                             doublereal *,//epseg,
5885                             integer *iercod)
5886 {
5887   /* System generated locals */
5888   integer tabtri_dim1, tabtri_offset, i__1, i__2;
5889
5890   /* Local variables */
5891   logical idbg;
5892   integer icol, ilgn, nlgn, noct, inser;
5893   doublereal epsega = 0.;
5894   integer ibb;
5895
5896 /* ***********************************************************************
5897  */
5898
5899 /*     FUNCTION : */
5900 /*     ---------- */
5901 /*        . Insert a line in a table parsed without redundance */
5902
5903 /*     KEYWORDS : */
5904 /*     ----------- */
5905 /*      TOUS,MATH_ACCES :: TABLEAU&,INSERTION,&TABLEAU */
5906
5907 /*     INPUT ARGUMENTS : */
5908 /*     -------------------- */
5909 /*        . NCOLMX : Number of columns in the table */
5910 /*        . NLGNMX : Number of lines in the table */
5911 /*        . TABTRI : Table parsed by lines without redundances */
5912 /*        . NBRCOL : Number of columns used */
5913 /*        . NBRLGN : Number of lines used */
5914 /*        . AJOUTE : Line to be added */
5915 /*        . EPSEGA : Epsilon to test the redundance */
5916
5917 /*     OUTPUT ARGUMENTS : */
5918 /*     --------------------- */
5919 /*        . TABTRI : Table parsed by lines without redundances */
5920 /*        . NBRLGN : Number of lines used */
5921 /*        . IERCOD : 0 -> No problem */
5922 /*                   1 -> The table is full */
5923
5924 /*     COMMONS USED : */
5925 /*     ------------------ */
5926
5927 /*     REFERENCES CALLED : */
5928 /*     --------------------- */
5929
5930 /*     DESCRIPTION/NOTES/LIMITATIONS : */
5931 /*     ----------------------------------- */
5932 /*        . The line is inserted only if there is no line with all
5933 */
5934 /*     elements equl to those which are planned to be insered, to epsilon. */
5935
5936 /*        . Level of de debug = 3 */
5937
5938
5939 /**/
5940 /*     DECLARATIONS , CONTROL OF INPUT ARGUMENTS , INITIALIZATION */
5941 /* ***********************************************************************
5942  */
5943
5944 /* --- Parameters */
5945
5946
5947 /* --- Functions */
5948
5949
5950 /* --- Local variables */
5951
5952
5953 /* --- Messages */
5954
5955     /* Parameter adjustments */
5956     tabtri_dim1 = *ncolmx;
5957     tabtri_offset = tabtri_dim1 + 1;
5958     tabtri -= tabtri_offset;
5959     --ajoute;
5960
5961     /* Function Body */
5962     ibb = AdvApp2Var_SysBase::mnfndeb_();
5963     idbg = ibb >= 3;
5964     if (idbg) {
5965         AdvApp2Var_SysBase::mgenmsg_("MMINLTT", 7L);
5966     }
5967
5968 /* --- Control arguments */
5969
5970     if (*nbrlgn >= *nlgnmx) {
5971         goto L9001;
5972     }
5973
5974 /* -------------------- */
5975 /* *** INITIALIZATION */
5976 /* -------------------- */
5977
5978     *iercod = 0;
5979
5980 /* ---------------------------- */
5981 /* *** SEARCH OF REDUNDANCE */
5982 /* ---------------------------- */
5983
5984     i__1 = *nbrlgn;
5985     for (ilgn = 1; ilgn <= i__1; ++ilgn) {
5986         if (tabtri[ilgn * tabtri_dim1 + 1] >= ajoute[1] - epsega) {
5987             if (tabtri[ilgn * tabtri_dim1 + 1] <= ajoute[1] + epsega) {
5988                 i__2 = *nbrcol;
5989                 for (icol = 1; icol <= i__2; ++icol) {
5990                     if (tabtri[icol + ilgn * tabtri_dim1] < ajoute[icol] -
5991                             epsega || tabtri[icol + ilgn * tabtri_dim1] >
5992                             ajoute[icol] + epsega) {
5993                         goto L20;
5994                     }
5995 /* L10: */
5996                 }
5997                 goto L9999;
5998             } else {
5999                 goto L30;
6000             }
6001         }
6002 L20:
6003         ;
6004     }
6005
6006 /* ----------------------------------- */
6007 /* *** SEARCH OF THE INSERTION POINT */
6008 /* ----------------------------------- */
6009
6010 L30:
6011
6012     i__1 = *nbrlgn;
6013     for (ilgn = 1; ilgn <= i__1; ++ilgn) {
6014         i__2 = *nbrcol;
6015         for (icol = 1; icol <= i__2; ++icol) {
6016             if (tabtri[icol + ilgn * tabtri_dim1] < ajoute[icol]) {
6017                 goto L50;
6018             }
6019             if (tabtri[icol + ilgn * tabtri_dim1] > ajoute[icol]) {
6020                 goto L70;
6021             }
6022 /* L60: */
6023         }
6024 L50:
6025         ;
6026     }
6027
6028     ilgn = *nbrlgn + 1;
6029
6030 /* -------------- */
6031 /* *** INSERTION */
6032 /* -------------- */
6033
6034 L70:
6035
6036     inser = ilgn;
6037     ++(*nbrlgn);
6038
6039 /* --- Shift lower */
6040
6041     nlgn = *nbrlgn - inser;
6042     if (nlgn > 0) {
6043         noct = (*ncolmx << 3) * nlgn;
6044         AdvApp2Var_SysBase::mcrfill_(&noct,
6045                  &tabtri[inser * tabtri_dim1 + 1],
6046                  &tabtri[(inser + 1)* tabtri_dim1 + 1]);
6047     }
6048
6049 /* --- Copy line */
6050
6051     noct = *nbrcol << 3;
6052     AdvApp2Var_SysBase::mcrfill_(&noct,
6053              &ajoute[1],
6054              &tabtri[inser * tabtri_dim1 + 1]);
6055
6056     goto L9999;
6057
6058 /* ******************************************************************** */
6059 /*       OUTPUT ERROR , RETURN CALLING PROGRAM , MESSAGES */
6060 /* ******************************************************************** */
6061
6062 /* --- The table is already full */
6063
6064 L9001:
6065     *iercod = 1;
6066
6067 /* --- End */
6068
6069 L9999:
6070     if (*iercod != 0) {
6071         AdvApp2Var_SysBase::maermsg_("MMINLTT", iercod, 7L);
6072     }
6073     if (idbg) {
6074         AdvApp2Var_SysBase::mgsomsg_("MMINLTT", 7L);
6075     }
6076  return 0 ;
6077 } /* mminltt_ */
6078
6079 //=======================================================================
6080 //function : AdvApp2Var_MathBase::mmjacan_
6081 //purpose  :
6082 //=======================================================================
6083  int AdvApp2Var_MathBase::mmjacan_(const integer *ideriv,
6084                             integer *ndeg,
6085                             doublereal *poljac,
6086                             doublereal *polcan)
6087 {
6088     /* System generated locals */
6089   integer poljac_dim1, i__1, i__2;
6090
6091   /* Local variables */
6092   integer iptt, i__, j, ibb;
6093   doublereal bid;
6094
6095 /* ***********************************************************************
6096  */
6097
6098 /*     FUNCTION : */
6099 /*     ---------- */
6100 /*     Routine of transfer of Jacobi normalized to canonic [-1,1], */
6101 /*     the tables are ranked by even, then by uneven degree. */
6102
6103 /*     KEYWORDS : */
6104 /*     ----------- */
6105 /*        LEGENDRE,JACOBI,PASSAGE. */
6106
6107 /*     INPUT ARGUMENTS  : */
6108 /*     ------------------ */
6109 /*        IDERIV : Order of Jacobi between -1 and 2. */
6110 /*        NDEG :   The true degree of the polynom. */
6111 /*        POLJAC : The polynom in the Jacobi base. */
6112
6113 /*     OUTPUT ARGUMENTS : */
6114 /*     ------------------- */
6115 /*        POLCAN : The curve expressed in the canonic base [-1,1]. */
6116
6117 /*     COMMONS USED   : */
6118 /*     ---------------- */
6119
6120 /*     REFERENCES CALLED   : */
6121 /*     ----------------------- */
6122
6123 /*     DESCRIPTION/NOTES/LIMITATIONS : */
6124 /*     ----------------------------------- */
6125
6126 /* > */
6127 /* ***********************************************************************
6128  */
6129
6130 /*   Name of the routine */
6131
6132 /*   Matrices of conversion */
6133
6134
6135 /* ***********************************************************************
6136  */
6137
6138 /*     FUNCTION : */
6139 /*     ---------- */
6140 /*        MATRIX OF TRANSFORMATION OF LEGENDRE BASE */
6141
6142 /*     KEYWORDS : */
6143 /*     ----------- */
6144 /*        MATH */
6145
6146 /*     DEMSCRIPTION/NOTES/LIMITATIONS : */
6147 /*     ----------------------------------- */
6148
6149 /* > */
6150 /* ***********************************************************************
6151  */
6152
6153
6154
6155 /*  Legendre common / Restricted Casteljau. */
6156
6157 /*   0:1      0 Concerns the even terms, 1 the uneven terms. */
6158 /*   CANPLG : Matrix of passage to canonic from Jacobi with calculated parities */
6159 /*   PLGCAN : Matrix of passage from Jacobi to canonic with calculated parities */
6160
6161
6162 /* ***********************************************************************
6163  */
6164
6165     /* Parameter adjustments */
6166     poljac_dim1 = *ndeg / 2 + 1;
6167
6168     /* Function Body */
6169     ibb = AdvApp2Var_SysBase::mnfndeb_();
6170     if (ibb >= 5) {
6171         AdvApp2Var_SysBase::mgenmsg_("MMJACAN", 7L);
6172     }
6173
6174 /* ----------------- Expression of terms of even degree ----------------
6175 */
6176
6177     i__1 = *ndeg / 2;
6178     for (i__ = 0; i__ <= i__1; ++i__) {
6179         bid = 0.;
6180         iptt = i__ * 31 - (i__ + 1) * i__ / 2 + 1;
6181         i__2 = *ndeg / 2;
6182         for (j = i__; j <= i__2; ++j) {
6183             bid += mmjcobi_.plgcan[iptt + j + *ideriv * 992 + 991] * poljac[
6184                     j];
6185 /* L310: */
6186         }
6187         polcan[i__ * 2] = bid;
6188 /* L300: */
6189     }
6190
6191 /* --------------- Expression of terms of uneven degree ----------------
6192 */
6193
6194     if (*ndeg == 0) {
6195         goto L9999;
6196     }
6197
6198     i__1 = (*ndeg - 1) / 2;
6199     for (i__ = 0; i__ <= i__1; ++i__) {
6200         bid = 0.;
6201         iptt = i__ * 31 - (i__ + 1) * i__ / 2 + 1;
6202         i__2 = (*ndeg - 1) / 2;
6203         for (j = i__; j <= i__2; ++j) {
6204             bid += mmjcobi_.plgcan[iptt + j + ((*ideriv << 1) + 1) * 496 +
6205                     991] * poljac[j + poljac_dim1];
6206 /* L410: */
6207         }
6208         polcan[(i__ << 1) + 1] = bid;
6209 /* L400: */
6210     }
6211
6212 /* -------------------------------- The end -----------------------------
6213 */
6214
6215 L9999:
6216     if (ibb >= 5) {
6217         AdvApp2Var_SysBase::mgsomsg_("MMJACAN", 7L);
6218     }
6219     return 0;
6220 } /* mmjacan_ */
6221
6222 //=======================================================================
6223 //function : AdvApp2Var_MathBase::mmjaccv_
6224 //purpose  :
6225 //=======================================================================
6226  int AdvApp2Var_MathBase::mmjaccv_(const integer *ncoef,
6227                             const integer *ndim,
6228                             const integer *ider,
6229                             const doublereal *crvlgd,
6230                             doublereal *polaux,
6231                             doublereal *crvcan)
6232
6233 {
6234   /* Initialized data */
6235
6236   static char nomprg[8+1] = "MMJACCV ";
6237
6238   /* System generated locals */
6239   integer crvlgd_dim1, crvlgd_offset, crvcan_dim1, crvcan_offset,
6240   polaux_dim1, i__1, i__2;
6241
6242   /* Local variables */
6243   integer ndeg, i__, nd, ii, ibb;
6244
6245 /* ***********************************************************************
6246  */
6247
6248 /*     FUNCTION : */
6249 /*     ---------- */
6250 /*        Passage from the normalized Jacobi base to the canonic base. */
6251
6252 /*     KEYWORDS : */
6253 /*     ----------- */
6254 /*        SMOOTHING, BASE, LEGENDRE */
6255
6256
6257 /*     INPUT ARGUMENTS : */
6258 /*     ------------------ */
6259 /*        NDIM: Space Dimension. */
6260 /*        NCOEF: Degree +1 of the polynom. */
6261 /*        IDER: Order of Jacobi polynoms. */
6262 /*        CRVLGD : Curve in the base of Jacobi. */
6263
6264 /*     OUTPUT ARGUMENTS : */
6265 /*     ------------------- */
6266 /*        POLAUX : Auxilliary space. */
6267 /*        CRVCAN : The curve in the canonic base [-1,1] */
6268
6269 /*     COMMONS USED   : */
6270 /*     ---------------- */
6271
6272 /*     REFERENCES CALLED   : */
6273 /*     ----------------------- */
6274
6275 /*     DESCRIPTION/NOTES/LIMITATIONS : */
6276 /*     ----------------------------------- */
6277
6278 /* > */
6279 /* *********************************************************************
6280 */
6281
6282 /*   Name of the routine */
6283     /* Parameter adjustments */
6284     polaux_dim1 = (*ncoef - 1) / 2 + 1;
6285     crvcan_dim1 = *ncoef - 1 + 1;
6286     crvcan_offset = crvcan_dim1;
6287     crvcan -= crvcan_offset;
6288     crvlgd_dim1 = *ncoef - 1 + 1;
6289     crvlgd_offset = crvlgd_dim1;
6290     crvlgd -= crvlgd_offset;
6291
6292     /* Function Body */
6293
6294     ibb = AdvApp2Var_SysBase::mnfndeb_();
6295     if (ibb >= 3) {
6296         AdvApp2Var_SysBase::mgenmsg_(nomprg, 6L);
6297     }
6298
6299     ndeg = *ncoef - 1;
6300
6301     i__1 = *ndim;
6302     for (nd = 1; nd <= i__1; ++nd) {
6303 /*  Loading of the auxilliary table. */
6304         ii = 0;
6305         i__2 = ndeg / 2;
6306         for (i__ = 0; i__ <= i__2; ++i__) {
6307             polaux[i__] = crvlgd[ii + nd * crvlgd_dim1];
6308             ii += 2;
6309 /* L310: */
6310         }
6311
6312         ii = 1;
6313         if (ndeg >= 1) {
6314             i__2 = (ndeg - 1) / 2;
6315             for (i__ = 0; i__ <= i__2; ++i__) {
6316                 polaux[i__ + polaux_dim1] = crvlgd[ii + nd * crvlgd_dim1];
6317                 ii += 2;
6318 /* L320: */
6319             }
6320         }
6321 /*   Call the routine of base change. */
6322         AdvApp2Var_MathBase::mmjacan_(ider, &ndeg, polaux, &crvcan[nd * crvcan_dim1]);
6323 /* L300: */
6324     }
6325
6326
6327 /* L9999: */
6328     return 0;
6329 } /* mmjaccv_ */
6330
6331 //=======================================================================
6332 //function : mmloncv_
6333 //purpose  :
6334 //=======================================================================
6335 int mmloncv_(integer *ndimax,
6336              integer *ndimen,
6337              integer *ncoeff,
6338              doublereal *courbe,
6339              doublereal *tdebut,
6340              doublereal *tfinal,
6341              doublereal *xlongc,
6342              integer *iercod)
6343
6344 {
6345   /* Initialized data */
6346
6347   integer kgar = 0;
6348
6349   /* System generated locals */
6350   integer courbe_dim1, courbe_offset, i__1, i__2;
6351
6352   /* Local variables */
6353   doublereal tran;
6354   integer ngaus = 0;
6355   doublereal c1, c2, d1, d2,
6356     wgaus[20] = {0.}, uroot[20] = {0.}, x1, x2, dd;
6357   integer ii, jj, kk;
6358   doublereal som;
6359   doublereal der1, der2;
6360
6361
6362
6363
6364 /* **********************************************************************
6365 */
6366
6367 /*     FUNCTION : Length of an arc of curve on a given interval */
6368 /*     ---------- for a function the mathematic representation  */
6369 /*                which of is a multidimensional polynom. */
6370 /*      The polynom is a set of polynoms the coefficients which of are ranked */
6371 /*  in a table with 2 indices, each line relative to 1 polynom. */
6372 /*      The polynom is defined by its coefficients ordered by increasing
6373 *       power of the variable. */
6374 /*      All polynoms have the same number of coefficients (and the same degree). */
6375
6376 /*     KEYWORDS : LENGTH, CURVE */
6377 /*     ----------- */
6378
6379 /*     INPUT ARGUMENTS : */
6380 /*     -------------------- */
6381
6382 /*      NDIMAX : Max number of lines of tables (max number of polynoms). */
6383 /*      NDIMEN : Dimension of the polynom (Nomber of polynoms). */
6384 /*      NCOEFF : Number of coefficients of the polynom (no limitation) */
6385 /*               This is degree + 1 */
6386 /*      COURBE : Coefficients of the polynom ordered by increasing power */
6387 /*               Dimension to (NDIMAX,NCOEFF). */
6388 /*      TDEBUT : Lower limit of integration for length calculation. */
6389 /*      TFINAL : Upper limit of integration for length calculation.  */
6390
6391 /*     OUTPUT ARGUMENTS : */
6392 /*     --------------------- */
6393 /*      XLONGC : Length of arc of curve */
6394
6395 /*      IERCOD : Error code : */
6396 /*             = 0 ==> All is OK */
6397 /*             = 1 ==> NDIMEN or NCOEFF negative or null */
6398 /*             = 2 ==> Pb loading Legendre roots and Gauss weight */
6399 /*                     by MVGAUS0. */
6400
6401 /*     If error => XLONGC = 0 */
6402
6403 /*     COMMONS USED : */
6404 /*     ------------------ */
6405
6406 /*      .Neant. */
6407
6408 /*     REFERENCES CALLED   : */
6409 /*     ---------------------- */
6410 /*     Type  Name */
6411 /*           MAERMSG         R*8  DSQRT          I*4  MIN */
6412 /*           MVGAUS0 */
6413
6414 /*     DESCRIPTION/NOTES/LIMITATIONS : */
6415 /*     ----------------------------------- */
6416
6417 /*      See VGAUSS to understand well the technique. */
6418 /*      Actually SQRT (dpi^2) is integrated for i=1,nbdime */
6419 /*      Calculation of the derivative is included in the code to avoid an additional */
6420 /*      call of the routine. */
6421
6422 /*      The integrated function is strictly increasing, it */
6423 /*      is not necessary to use a high degree for the GAUSS method GAUSS. */
6424
6425 /*      The degree of LEGENDRE polynom results from the degree of the */
6426 /*      polynom to be integrated. It can vary from 4 to 40 (with step of 4). */
6427
6428 /*      The precision (relative) of integration is of order 1.D-8. */
6429
6430 /*      ATTENTION : if TDEBUT > TFINAL, the length is NEGATIVE. */
6431
6432 /*      Attention : the precision of the result is not controlled. */
6433 /*      If you wish to control it, use  MMCGLC1, taking into account that  */
6434 /*      the performance (in time) will be worse. */
6435
6436 /* >=====================================================================
6437 */
6438
6439 /*      ATTENTION : SAVE KGAR WGAUS and UROOT EVENTUALLY */
6440 /*     ,IERXV */
6441 /*      INTEGER I1,I20 */
6442 /*      PARAMETER (I1=1,I20=20) */
6443
6444     /* Parameter adjustments */
6445     courbe_dim1 = *ndimax;
6446     courbe_offset = courbe_dim1 + 1;
6447     courbe -= courbe_offset;
6448
6449     /* Function Body */
6450
6451 /* ****** General initialization ** */
6452
6453     *iercod = 999999;
6454     *xlongc = 0.;
6455
6456 /* ****** Initialization of UROOT, WGAUS, NGAUS and KGAR ** */
6457
6458 /*      CALL MXVINIT(IERXV,'INTEGER',I1,KGAR,'INTEGER',I1,NGAUS */
6459 /*     1    ,'DOUBLE PRECISION',I20,UROOT,'DOUBLE PRECISION',I20,WGAUS) */
6460 /*      IF (IERXV.GT.0) KGAR=0 */
6461
6462 /* ****** Test the equity of limits ** */
6463
6464     if (*tdebut == *tfinal) {
6465         *iercod = 0;
6466         goto L9900;
6467     }
6468
6469 /* ****** Test the dimension and the number of coefficients ** */
6470
6471     if (*ndimen <= 0 || *ncoeff <= 0) {
6472         *iercod = 1;
6473         goto L9900;
6474     }
6475
6476 /* ****** Calculate the optimal degree ** */
6477
6478     kk = *ncoeff / 4 + 1;
6479     kk = advapp_min(kk,10);
6480
6481 /* ****** Return the coefficients for the integral (DEGRE=4*KK) */
6482 /*       if KK <> KGAR. */
6483
6484     if (kk != kgar) {
6485         mvgaus0_(&kk, uroot, wgaus, &ngaus, iercod);
6486         if (*iercod > 0) {
6487             kgar = 0;
6488             *iercod = 2;
6489             goto L9900;
6490         }
6491         kgar = kk;
6492     }
6493
6494 /*      C1 => Point medium interval */
6495 /*      C2 => 1/2 amplitude interval */
6496
6497     c1 = (*tfinal + *tdebut) * .5;
6498     c2 = (*tfinal - *tdebut) * .5;
6499
6500 /* ----------------------------------------------------------- */
6501 /* ****** Integration - Loop on GAUSS intervals ** */
6502 /* ----------------------------------------------------------- */
6503
6504     som = 0.;
6505
6506     i__1 = ngaus;
6507     for (jj = 1; jj <= i__1; ++jj) {
6508
6509 /* ****** Integration taking the symmetry into account ** */
6510
6511         tran = c2 * uroot[jj - 1];
6512         x1 = c1 + tran;
6513         x2 = c1 - tran;
6514
6515 /* ****** Derivation on the dimension of the space ** */
6516
6517         der1 = 0.;
6518         der2 = 0.;
6519         i__2 = *ndimen;
6520         for (kk = 1; kk <= i__2; ++kk) {
6521             d1 = (*ncoeff - 1) * courbe[kk + *ncoeff * courbe_dim1];
6522             d2 = d1;
6523             for (ii = *ncoeff - 1; ii >= 2; --ii) {
6524                 dd = (ii - 1) * courbe[kk + ii * courbe_dim1];
6525                 d1 = d1 * x1 + dd;
6526                 d2 = d2 * x2 + dd;
6527 /* L100: */
6528             }
6529             der1 += d1 * d1;
6530             der2 += d2 * d2;
6531 /* L200: */
6532         }
6533
6534 /* ****** Integration ** */
6535
6536         som += wgaus[jj - 1] * c2 * (sqrt(der1) + sqrt(der2));
6537
6538 /* ****** End of loop on GAUSS intervals ** */
6539
6540 /* L300: */
6541     }
6542
6543 /* ****** Work ended ** */
6544
6545     *xlongc = som;
6546
6547 /* ****** It is forced IERCOD  =  0 ** */
6548
6549     *iercod = 0;
6550
6551 /* ****** Final processing ** */
6552
6553 L9900:
6554
6555 /* ****** Save UROOT, WGAUS, NGAUS and KGAR ** */
6556
6557 /*      CALL MXVSAVE(IERXV,'INTEGER',I1,KGAR,'INTEGER',I1,NGAUS */
6558 /*     1    ,'DOUBLE PRECISION',I20,UROOT,'DOUBLE PRECISION',I20,WGAUS) */
6559 /*      IF (IERXV.GT.0) KGAR=0 */
6560
6561 /* ****** End of sub-program ** */
6562
6563     if (*iercod != 0) {
6564         AdvApp2Var_SysBase::maermsg_("MMLONCV", iercod, 7L);
6565     }
6566  return 0 ;
6567 } /* mmloncv_ */
6568
6569 //=======================================================================
6570 //function : AdvApp2Var_MathBase::mmpobas_
6571 //purpose  :
6572 //=======================================================================
6573  int AdvApp2Var_MathBase::mmpobas_(doublereal *tparam,
6574                             integer *iordre,
6575                             integer *ncoeff,
6576                             integer *nderiv,
6577                             doublereal *valbas,
6578                             integer *iercod)
6579
6580 {
6581   integer c__2 = 2;
6582   integer c__1 = 1;
6583
6584
6585    /* Initialized data */
6586
6587     doublereal moin11[2] = { -1.,1. };
6588
6589     /* System generated locals */
6590     integer valbas_dim1, i__1;
6591
6592     /* Local variables */
6593     doublereal vjac[80], herm[24];
6594     integer iord[2];
6595     doublereal wval[4];
6596     integer nwcof, iunit;
6597     doublereal wpoly[7];
6598     integer ii, jj, iorjac;
6599     doublereal hermit[36]       /* was [6][3][2] */;
6600     integer kk1, kk2, kk3;
6601     integer khe, ier;
6602
6603
6604 /* ***********************************************************************
6605  */
6606
6607 /*     FUNCTION : */
6608 /*     ---------- */
6609 /*       Position on the polynoms of base hermit-Jacobi */
6610 /*       and their succesive derivatives */
6611
6612 /*     KEYWORDS : */
6613 /*     ----------- */
6614 /*      PUBLIC, POSITION, HERMIT, JACOBI */
6615
6616 /*     INPUT ARGUMENTS : */
6617 /*     -------------------- */
6618 /*       TPARAM : Parameter for which the position is found. */
6619 /*       IORDRE : Orderof hermit-Jacobi (-1,0,1, ou 2) */
6620 /*       NCOEFF : Number of coefficients of polynoms (Nb of value to calculate) */
6621 /*       NDERIV : Number of derivative to calculate (0<= N <=3) */
6622 /*              0 -> Position simple on base functions */
6623 /*              N -> Position on base functions and derivative */
6624 /*              of order 1 to N */
6625
6626 /*     OUTPUT ARGUMENTS : */
6627 /*     --------------------- */
6628 /*     VALBAS (NCOEFF, 0:NDERIV) : calculated value */
6629 /*           i */
6630 /*          d    vj(t)  = VALBAS(J, I) */
6631 /*          -- i */
6632 /*          dt */
6633
6634 /*    IERCOD : Error code */
6635 /*      0 : Ok */
6636 /*      1 : Incoherence of input arguments */
6637
6638 /*     COMMONS USED : */
6639 /*     -------------- */
6640
6641
6642 /*     REFERENCES CALLED : */
6643 /*     ------------------- */
6644
6645
6646 /*     DESCRIPTION/NOTES/LIMITATIONS : */
6647 /*     ----------------------------------- */
6648
6649 /* > */
6650 /* ***********************************************************************
6651  */
6652 /*                            DECLARATIONS */
6653 /* ***********************************************************************
6654  */
6655
6656
6657
6658     /* Parameter adjustments */
6659     valbas_dim1 = *ncoeff;
6660     --valbas;
6661
6662     /* Function Body */
6663
6664 /* ***********************************************************************
6665  */
6666 /*                      INITIALIZATIONS */
6667 /* ***********************************************************************
6668  */
6669
6670     *iercod = 0;
6671
6672 /* ***********************************************************************
6673  */
6674 /*                     PROCESSING */
6675 /* ***********************************************************************
6676  */
6677
6678     if (*nderiv > 3) {
6679         goto L9101;
6680     }
6681     if (*ncoeff > 20) {
6682         goto L9101;
6683     }
6684     if (*iordre > 2) {
6685         goto L9101;
6686     }
6687
6688     iord[0] = *iordre;
6689     iord[1] = *iordre;
6690     iorjac = (*iordre + 1) << 1;
6691
6692 /*  (1) Generic Calculations .... */
6693
6694 /*  (1.a) Calculation of hermit polynoms */
6695
6696     if (*iordre >= 0) {
6697         mmherm1_(moin11, &c__2, iord, hermit, &ier);
6698         if (ier > 0) {
6699             goto L9102;
6700         }
6701     }
6702
6703 /*  (1.b) Evaluation of hermit polynoms */
6704
6705     jj = 1;
6706     iunit = *nderiv + 1;
6707     khe = (*iordre + 1) * iunit;
6708
6709     if (*nderiv > 0) {
6710
6711         i__1 = *iordre;
6712         for (ii = 0; ii <= i__1; ++ii) {
6713             mmdrvcb_(nderiv, &c__1, &iorjac, &hermit[(ii + 3) * 6 - 18],
6714                     tparam, &herm[jj - 1], &ier);
6715             if (ier > 0) {
6716                 goto L9102;
6717             }
6718
6719             mmdrvcb_(nderiv, &c__1, &iorjac, &hermit[(ii + 6) * 6 - 18],
6720                     tparam, &herm[jj + khe - 1], &ier);
6721             if (ier > 0) {
6722                 goto L9102;
6723             }
6724             jj += iunit;
6725         }
6726
6727     } else {
6728
6729         i__1 = *iordre;
6730         for (ii = 0; ii <= i__1; ++ii) {
6731             AdvApp2Var_MathBase::mmpocrb_(&c__1, &iorjac, &hermit[(ii + 3) * 6 - 18], &c__1,
6732                     tparam, &herm[jj - 1]);
6733
6734             AdvApp2Var_MathBase::mmpocrb_(&c__1, &iorjac, &hermit[(ii + 6) * 6 - 18], &c__1,
6735                     tparam, &herm[jj + khe - 1]);
6736             jj += iunit;
6737         }
6738     }
6739
6740 /*  (1.c) Evaluation of Jacobi polynoms */
6741
6742     ii = *ncoeff - iorjac;
6743
6744     mmpojac_(tparam, &iorjac, &ii, nderiv, vjac, &ier);
6745     if (ier > 0) {
6746         goto L9102;
6747     }
6748
6749 /*  (1.d) Evaluation of W(t) */
6750
6751 /* Computing MAX */
6752     i__1 = iorjac + 1;
6753     nwcof = advapp_max(i__1,1);
6754     AdvApp2Var_SysBase::mvriraz_(&nwcof,
6755              wpoly);
6756     wpoly[0] = 1.;
6757     if (*iordre == 2) {
6758         wpoly[2] = -3.;
6759         wpoly[4] = 3.;
6760         wpoly[6] = -1.;
6761     } else if (*iordre == 1) {
6762         wpoly[2] = -2.;
6763         wpoly[4] = 1.;
6764     } else if (*iordre == 0) {
6765         wpoly[2] = -1.;
6766     }
6767
6768     mmdrvcb_(nderiv, &c__1, &nwcof, wpoly, tparam, wval, &ier);
6769     if (ier > 0) {
6770         goto L9102;
6771     }
6772
6773     kk1 = *ncoeff - iorjac;
6774     kk2 = kk1 << 1;
6775     kk3 = kk1 * 3;
6776
6777 /*  (2) Evaluation of order 0 */
6778
6779     jj = 1;
6780     i__1 = iorjac;
6781     for (ii = 1; ii <= i__1; ++ii) {
6782         valbas[ii] = herm[jj - 1];
6783         jj += iunit;
6784     }
6785
6786     i__1 = kk1;
6787     for (ii = 1; ii <= i__1; ++ii) {
6788         valbas[ii + iorjac] = wval[0] * vjac[ii - 1];
6789     }
6790
6791 /*  (3) Evaluation of order 1 */
6792
6793     if (*nderiv >= 1) {
6794         jj = 2;
6795         i__1 = iorjac;
6796         for (ii = 1; ii <= i__1; ++ii) {
6797             valbas[ii + valbas_dim1] = herm[jj - 1];
6798             jj += iunit;
6799         }
6800
6801
6802         i__1 = kk1;
6803         for (ii = 1; ii <= i__1; ++ii) {
6804             valbas[ii + iorjac + valbas_dim1] = wval[0] * vjac[ii + kk1 - 1]
6805                     + wval[1] * vjac[ii - 1];
6806         }
6807     }
6808
6809 /*  (4)  Evaluation of order 2 */
6810
6811     if (*nderiv >= 2) {
6812         jj = 3;
6813         i__1 = iorjac;
6814         for (ii = 1; ii <= i__1; ++ii) {
6815             valbas[ii + (valbas_dim1 << 1)] = herm[jj - 1];
6816             jj += iunit;
6817         }
6818
6819         i__1 = kk1;
6820         for (ii = 1; ii <= i__1; ++ii) {
6821             valbas[ii + iorjac + (valbas_dim1 << 1)] = wval[0] * vjac[ii +
6822                     kk2 - 1] + wval[1] * 2 * vjac[ii + kk1 - 1] + wval[2] *
6823                     vjac[ii - 1];
6824         }
6825     }
6826
6827 /*  (5) Evaluation of order 3 */
6828
6829     if (*nderiv >= 3) {
6830         jj = 4;
6831         i__1 = iorjac;
6832         for (ii = 1; ii <= i__1; ++ii) {
6833             valbas[ii + valbas_dim1 * 3] = herm[jj - 1];
6834             jj += iunit;
6835         }
6836
6837         i__1 = kk1;
6838         for (ii = 1; ii <= i__1; ++ii) {
6839             valbas[ii + iorjac + valbas_dim1 * 3] = wval[0] * vjac[ii + kk3 -
6840                     1] + wval[1] * 3 * vjac[ii + kk2 - 1] + wval[2] * 3 *
6841                     vjac[ii + kk1 - 1] + wval[3] * vjac[ii - 1];
6842         }
6843     }
6844
6845     goto L9999;
6846
6847 /* ***********************************************************************
6848  */
6849 /*                   ERROR PROCESSING */
6850 /* ***********************************************************************
6851  */
6852
6853 L9101:
6854     *iercod = 1;
6855     goto L9999;
6856
6857 L9102:
6858     *iercod = 2;
6859
6860 /* ***********************************************************************
6861  */
6862 /*                   RETURN CALLING PROGRAM */
6863 /* ***********************************************************************
6864  */
6865
6866 L9999:
6867
6868     if (*iercod > 0) {
6869         AdvApp2Var_SysBase::maermsg_("MMPOBAS", iercod, 7L);
6870     }
6871  return 0 ;
6872 } /* mmpobas_ */
6873
6874 //=======================================================================
6875 //function : AdvApp2Var_MathBase::mmpocrb_
6876 //purpose  :
6877 //=======================================================================
6878  int AdvApp2Var_MathBase::mmpocrb_(integer *ndimax,
6879                             integer *ncoeff,
6880                             doublereal *courbe,
6881                             integer *ndim,
6882                             doublereal *tparam,
6883                             doublereal *pntcrb)
6884
6885 {
6886   /* System generated locals */
6887   integer courbe_dim1, courbe_offset, i__1, i__2;
6888
6889   /* Local variables */
6890   integer ncof2;
6891   integer isize, nd, kcf, ncf;
6892
6893
6894 /* ***********************************************************************
6895  */
6896
6897 /*     FUNCTION : */
6898 /*     ---------- */
6899 /*        CALCULATE THE COORDINATES OF A POINT OF A CURVE OF GIVEN PARAMETER */
6900 /*        TPARAM ( IN 2D, 3D OR MORE) */
6901
6902 /*     KEYWORDS : */
6903 /*     ----------- */
6904 /*       TOUS , MATH_ACCES :: COURBE&,PARAMETRE& , POSITIONNEMENT , &POINT
6905  */
6906
6907 /*     INPUT ARGUMENTS  : */
6908 /*     ------------------ */
6909 /*        NDIMAX : format / dimension of the curve */
6910 /*        NCOEFF : Nb of coefficients of the curve */
6911 /*        COURBE : Matrix of coefficients of the curve */
6912 /*        NDIM   : Dimension useful of the workspace  */
6913 /*        TPARAM : Value of the parameter where the point is calculated */
6914
6915 /*     OUTPUT ARGUMENTS : */
6916 /*     ------------------- */
6917 /*        PNTCRB : Coordinates of the calculated point */
6918
6919 /*     COMMONS USED   : */
6920 /*     ---------------- */
6921
6922 /*      .Neant. */
6923
6924 /*     REFERENCES CALLED   : */
6925 /*     ---------------------- */
6926 /*     Type  Name */
6927 /*           MIRAZ                MVPSCR2              MVPSCR3 */
6928
6929 /*     DESCRIPTION/NOTES/LIMITATIONS : */
6930 /*     ----------------------------------- */
6931
6932 /* > */
6933 /* ***********************************************************************
6934  */
6935
6936
6937 /* ***********************************************************************
6938  */
6939
6940     /* Parameter adjustments */
6941     courbe_dim1 = *ndimax;
6942     courbe_offset = courbe_dim1 + 1;
6943     courbe -= courbe_offset;
6944     --pntcrb;
6945
6946     /* Function Body */
6947     isize = *ndim << 3;
6948     AdvApp2Var_SysBase::miraz_(&isize,
6949            &pntcrb[1]);
6950
6951     if (*ncoeff <= 0) {
6952         goto L9999;
6953     }
6954
6955 /*   optimal processing 3d */
6956
6957     if (*ndim == 3 && *ndimax == 3) {
6958         mvpscr3_(ncoeff, &courbe[courbe_offset], tparam, &pntcrb[1]);
6959
6960 /*   optimal processing 2d */
6961
6962     } else if (*ndim == 2 && *ndimax == 2) {
6963         mvpscr2_(ncoeff, &courbe[courbe_offset], tparam, &pntcrb[1]);
6964
6965 /*   Any dimension - scheme of HORNER */
6966
6967     } else if (*tparam == 0.) {
6968         i__1 = *ndim;
6969         for (nd = 1; nd <= i__1; ++nd) {
6970             pntcrb[nd] = courbe[nd + courbe_dim1];
6971 /* L100: */
6972         }
6973     } else if (*tparam == 1.) {
6974         i__1 = *ncoeff;
6975         for (ncf = 1; ncf <= i__1; ++ncf) {
6976             i__2 = *ndim;
6977             for (nd = 1; nd <= i__2; ++nd) {
6978                 pntcrb[nd] += courbe[nd + ncf * courbe_dim1];
6979 /* L300: */
6980             }
6981 /* L200: */
6982         }
6983     } else {
6984         ncof2 = *ncoeff + 2;
6985         i__1 = *ndim;
6986         for (nd = 1; nd <= i__1; ++nd) {
6987             i__2 = *ncoeff;
6988             for (ncf = 2; ncf <= i__2; ++ncf) {
6989                 kcf = ncof2 - ncf;
6990                 pntcrb[nd] = (pntcrb[nd] + courbe[nd + kcf * courbe_dim1]) * *
6991                         tparam;
6992 /* L500: */
6993             }
6994             pntcrb[nd] += courbe[nd + courbe_dim1];
6995 /* L400: */
6996         }
6997     }
6998
6999 L9999:
7000  return 0   ;
7001 } /* mmpocrb_ */
7002
7003 //=======================================================================
7004 //function : AdvApp2Var_MathBase::mmmpocur_
7005 //purpose  :
7006 //=======================================================================
7007  int AdvApp2Var_MathBase::mmmpocur_(integer *ncofmx,
7008                              integer *ndim,
7009                              integer *ndeg,
7010                              doublereal *courbe,
7011                              doublereal *tparam,
7012                              doublereal *tabval)
7013
7014 {
7015   /* System generated locals */
7016   integer courbe_dim1, courbe_offset, i__1;
7017
7018   /* Local variables */
7019   integer i__, nd;
7020   doublereal fu;
7021
7022
7023 /* ***********************************************************************
7024  */
7025
7026 /*     FUNCTION : */
7027 /*     ---------- */
7028 /*        Position of a point on curve (ncofmx,ndim). */
7029
7030 /*     KEYWORDS : */
7031 /*     ----------- */
7032 /*        TOUS , AB_SPECIFI :: COURBE&,POLYNOME&,POSITIONNEMENT,&POINT */
7033
7034 /*     INPUT ARGUMENTS  : */
7035 /*     ------------------ */
7036 /*        NCOFMX: Format / degree of the CURVE. */
7037 /*        NDIM  : Dimension of the space. */
7038 /*        NDEG  : Degree of the polynom. */
7039 /*        COURBE: Coefficients of the curve. */
7040 /*        TPARAM: Parameter on the curve */
7041
7042 /*     OUTPUT ARGUMENTS  : */
7043 /*     ------------------- */
7044 /*        TABVAL(NDIM): The resulting point (or table of values) */
7045
7046 /*     COMMONS USED   : */
7047 /*     ---------------- */
7048
7049 /*     REFERENCES CALLED : */
7050 /*     ----------------------- */
7051
7052 /*     DESCRIPTION/NOTES/LIMITATIONS : */
7053 /*     ----------------------------------- */
7054
7055 /* > */
7056 /* ***********************************************************************
7057  */
7058
7059     /* Parameter adjustments */
7060     --tabval;
7061     courbe_dim1 = *ncofmx;
7062     courbe_offset = courbe_dim1 + 1;
7063     courbe -= courbe_offset;
7064
7065     /* Function Body */
7066     if (*ndeg < 1) {
7067         i__1 = *ndim;
7068         for (nd = 1; nd <= i__1; ++nd) {
7069             tabval[nd] = 0.;
7070 /* L290: */
7071         }
7072     } else {
7073         i__1 = *ndim;
7074         for (nd = 1; nd <= i__1; ++nd) {
7075             fu = courbe[*ndeg + nd * courbe_dim1];
7076             for (i__ = *ndeg - 1; i__ >= 1; --i__) {
7077                 fu = fu * *tparam + courbe[i__ + nd * courbe_dim1];
7078 /* L120: */
7079             }
7080             tabval[nd] = fu;
7081 /* L300: */
7082         }
7083     }
7084  return 0 ;
7085 } /* mmmpocur_ */
7086
7087 //=======================================================================
7088 //function : mmpojac_
7089 //purpose  :
7090 //=======================================================================
7091 int mmpojac_(doublereal *tparam,
7092              integer *iordre,
7093              integer *ncoeff,
7094              integer *nderiv,
7095              doublereal *valjac,
7096              integer *iercod)
7097
7098 {
7099   integer c__2 = 2;
7100
7101     /* Initialized data */
7102
7103     integer nbcof = -1;
7104
7105     /* System generated locals */
7106     integer valjac_dim1, i__1, i__2;
7107
7108     /* Local variables */
7109     doublereal cofa, cofb, denom, tnorm[100];
7110     integer ii, jj, kk1, kk2;
7111     doublereal aux1, aux2;
7112
7113
7114 /* ***********************************************************************
7115  */
7116
7117 /*     FUNCTION : */
7118 /*     ---------- */
7119 /*       Positioning on Jacobi polynoms and their derivatives */
7120 /*       successive by a recurrent algorithm */
7121
7122 /*     KEYWORDS : */
7123 /*     ----------- */
7124 /*      RESERVE, POSITIONING, JACOBI */
7125
7126 /*     INPUT ARGUMENTS : */
7127 /*     -------------------- */
7128 /*       TPARAM : Parameter for which positioning is done. */
7129 /*       IORDRE : Order of hermit-?? (-1,0,1, or 2) */
7130 /*       NCOEFF : Number of coeeficients of polynoms (Nb of value to */
7131 /*                calculate) */
7132 /*       NDERIV : Number of derivative to calculate (0<= N <=3) */
7133 /*              0 -> Position simple on jacobi functions */
7134 /*              N -> Position on jacobi functions and their */
7135 /*              derivatives of order 1 to N. */
7136
7137 /*     OUTPUT ARGUMENTS : */
7138 /*     --------------------- */
7139 /*     VALJAC (NCOEFF, 0:NDERIV) : the calculated values */
7140 /*           i */
7141 /*          d    vj(t)  = VALJAC(J, I) */
7142 /*          -- i */
7143 /*          dt */
7144
7145 /*    IERCOD : Error Code */
7146 /*      0 : Ok */
7147 /*      1 : Incoherence of input arguments */
7148
7149 /*     COMMONS USED : */
7150 /*     ------------------ */
7151
7152
7153 /*     REFERENCES CALLED : */
7154 /*     --------------------- */
7155
7156
7157 /*     DESCRIPTION/NOTES/LIMITATIONS : */
7158 /*     ----------------------------------- */
7159
7160 /* > */
7161 /* ***********************************************************************
7162  */
7163 /*                            DECLARATIONS */
7164 /* ***********************************************************************
7165  */
7166
7167
7168 /*     static varaibles */
7169
7170
7171
7172     /* Parameter adjustments */
7173     valjac_dim1 = *ncoeff;
7174     --valjac;
7175
7176     /* Function Body */
7177
7178 /* ***********************************************************************
7179  */
7180 /*                      INITIALISATIONS */
7181 /* ***********************************************************************
7182  */
7183
7184     *iercod = 0;
7185
7186 /* ***********************************************************************
7187  */
7188 /*                     Processing */
7189 /* ***********************************************************************
7190  */
7191
7192     if (*nderiv > 3) {
7193         goto L9101;
7194     }
7195     if (*ncoeff > 100) {
7196         goto L9101;
7197     }
7198
7199 /*  --- Calculation of norms */
7200
7201 /*      IF (NCOEFF.GT.NBCOF) THEN */
7202     i__1 = *ncoeff;
7203     for (ii = 1; ii <= i__1; ++ii) {
7204         kk1 = ii - 1;
7205         aux2 = 1.;
7206         i__2 = *iordre;
7207         for (jj = 1; jj <= i__2; ++jj) {
7208             aux2 = aux2 * (doublereal) (kk1 + *iordre + jj) / (doublereal) (
7209                     kk1 + jj);
7210         }
7211         i__2 = (*iordre << 1) + 1;
7212         tnorm[ii - 1] = sqrt(aux2 * (kk1 * 2. + (*iordre << 1) + 1) / pow__ii(&
7213                 c__2, &i__2));
7214     }
7215
7216     nbcof = *ncoeff;
7217
7218 /*      END IF */
7219
7220 /*  --- Trivial Positions ----- */
7221
7222     valjac[1] = 1.;
7223     aux1 = (doublereal) (*iordre + 1);
7224     valjac[2] = aux1 * *tparam;
7225
7226     if (*nderiv >= 1) {
7227         valjac[valjac_dim1 + 1] = 0.;
7228         valjac[valjac_dim1 + 2] = aux1;
7229
7230         if (*nderiv >= 2) {
7231             valjac[(valjac_dim1 << 1) + 1] = 0.;
7232             valjac[(valjac_dim1 << 1) + 2] = 0.;
7233
7234             if (*nderiv >= 3) {
7235                 valjac[valjac_dim1 * 3 + 1] = 0.;
7236                 valjac[valjac_dim1 * 3 + 2] = 0.;
7237             }
7238         }
7239     }
7240
7241 /*  --- Positioning by recurrence */
7242
7243     i__1 = *ncoeff;
7244     for (ii = 3; ii <= i__1; ++ii) {
7245
7246         kk1 = ii - 1;
7247         kk2 = ii - 2;
7248         aux1 = (doublereal) (*iordre + kk2);
7249         aux2 = aux1 * 2;
7250         cofa = aux2 * (aux2 + 1) * (aux2 + 2);
7251         cofb = (aux2 + 2) * -2. * aux1 * aux1;
7252         denom = kk1 * 2. * (kk2 + (*iordre << 1) + 1) * aux2;
7253         denom = 1. / denom;
7254
7255 /*        --> Pi(t) */
7256         valjac[ii] = (cofa * *tparam * valjac[kk1] + cofb * valjac[kk2]) *
7257                 denom;
7258 /*        --> P'i(t) */
7259         if (*nderiv >= 1) {
7260             valjac[ii + valjac_dim1] = (cofa * *tparam * valjac[kk1 +
7261                     valjac_dim1] + cofa * valjac[kk1] + cofb * valjac[kk2 +
7262                     valjac_dim1]) * denom;
7263 /*        --> P''i(t) */
7264             if (*nderiv >= 2) {
7265                 valjac[ii + (valjac_dim1 << 1)] = (cofa * *tparam * valjac[
7266                         kk1 + (valjac_dim1 << 1)] + cofa * 2 * valjac[kk1 +
7267                         valjac_dim1] + cofb * valjac[kk2 + (valjac_dim1 << 1)]
7268                         ) * denom;
7269             }
7270 /*        --> P'i(t) */
7271             if (*nderiv >= 3) {
7272                 valjac[ii + valjac_dim1 * 3] = (cofa * *tparam * valjac[kk1 +
7273                         valjac_dim1 * 3] + cofa * 3 * valjac[kk1 + (
7274                         valjac_dim1 << 1)] + cofb * valjac[kk2 + valjac_dim1 *
7275                          3]) * denom;
7276             }
7277         }
7278     }
7279
7280 /*    ---> Normalization */
7281
7282     i__1 = *ncoeff;
7283     for (ii = 1; ii <= i__1; ++ii) {
7284         i__2 = *nderiv;
7285         for (jj = 0; jj <= i__2; ++jj) {
7286             valjac[ii + jj * valjac_dim1] = tnorm[ii - 1] * valjac[ii + jj *
7287                     valjac_dim1];
7288         }
7289     }
7290
7291     goto L9999;
7292
7293 /* ***********************************************************************
7294  */
7295 /*                   PROCESSING OF ERRORS */
7296 /* ***********************************************************************
7297  */
7298
7299 L9101:
7300     *iercod = 1;
7301     goto L9999;
7302
7303
7304 /* ***********************************************************************
7305  */
7306 /*                   RETURN CALLING PROGRAM */
7307 /* ***********************************************************************
7308  */
7309
7310 L9999:
7311
7312     if (*iercod > 0) {
7313         AdvApp2Var_SysBase::maermsg_("MMPOJAC", iercod, 7L);
7314     }
7315  return 0 ;
7316 } /* mmpojac_ */
7317
7318 //=======================================================================
7319 //function : AdvApp2Var_MathBase::mmposui_
7320 //purpose  :
7321 //=======================================================================
7322  int AdvApp2Var_MathBase::mmposui_(integer *dimmat,
7323                             integer *,//nistoc,
7324                             integer *aposit,
7325                             integer *posuiv,
7326                             integer *iercod)
7327
7328 {
7329   /* System generated locals */
7330   integer i__1, i__2;
7331
7332   /* Local variables */
7333   logical ldbg;
7334   integer imin, jmin, i__, j, k;
7335   logical trouve;
7336
7337 /* ***********************************************************************
7338  */
7339
7340 /*     FUNCTION : */
7341 /*     ---------- */
7342 /*       FILL THE TABLE OF POSITIONING POSUIV WHICH ALLOWS TO */
7343 /*       PARSE BY COLUMN THE INFERIOR TRIANGULAR PART OF THE */
7344 /*       MATRIX  IN FORM OF PROFILE */
7345
7346
7347 /*     KEYWORDS : */
7348 /*     ----------- */
7349 /*      RESERVE, MATRIX, PROFILE */
7350
7351 /*     INPUT ARGUMENTS : */
7352 /*     -------------------- */
7353
7354 /*       NISTOC: NUMBER OF COEFFICIENTS IN THE PROFILE */
7355 /*       DIMMAT: NUMBER OF LINE OF THE SYMMETRIC SQUARE MATRIX */
7356 /*       APOSIT: TABLE OF POSITIONING OF STORAGE TERMS */
7357 /*               APOSIT(1,I) CONTAINS THE NUMBER OF TERMES-1 ON LINE */
7358 /*               I IN THE PROFILE OF THE MATRIX */
7359 /*               APOSIT(2,I) CONTAINS THE INDEX OF STORAGE OF DIAGONAL TERM */
7360 /*               OF LINE I */
7361
7362
7363 /*     OUTPUT ARGUMENTS : */
7364 /*     --------------------- */
7365 /*       POSUIV: POSUIV(K) (WHERE K IS THE INDEX OF STORAGE OF MAT(I,J)) */
7366 /*               CONTAINS THE SMALLEST NUMBER IMIN>I OF THE  LINE THAT */
7367 /*               POSSESSES A TERM MAT(IMIN,J) THAT IS IN THE PROFILE. */
7368 /*               IF THERE IS NO TERM MAT(IMIN,J) IN THE PROFILE THEN POSUIV(K)=-1 */
7369
7370
7371 /*     COMMONS USED : */
7372 /*     ------------------ */
7373
7374
7375 /*     REFERENCES CALLED : */
7376 /*     --------------------- */
7377
7378
7379 /*     DESCRIPTION/NOTES/LIMITATIONS : */
7380 /*     ----------------------------------- */
7381
7382
7383 /* ***********************************************************************
7384  */
7385 /*                            DECLARATIONS */
7386 /* ***********************************************************************
7387  */
7388
7389
7390
7391 /* ***********************************************************************
7392  */
7393 /*                      INITIALIZATIONS */
7394 /* ***********************************************************************
7395  */
7396
7397     /* Parameter adjustments */
7398     aposit -= 3;
7399     --posuiv;
7400
7401     /* Function Body */
7402     ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 2;
7403     if (ldbg) {
7404         AdvApp2Var_SysBase::mgenmsg_("MMPOSUI", 7L);
7405     }
7406     *iercod = 0;
7407
7408
7409 /* ***********************************************************************
7410  */
7411 /*                     PROCESSING */
7412 /* ***********************************************************************
7413  */
7414
7415
7416
7417     i__1 = *dimmat;
7418     for (i__ = 1; i__ <= i__1; ++i__) {
7419         jmin = i__ - aposit[(i__ << 1) + 1];
7420         i__2 = i__;
7421         for (j = jmin; j <= i__2; ++j) {
7422             imin = i__ + 1;
7423             trouve = FALSE_;
7424             while(! trouve && imin <= *dimmat) {
7425                 if (imin - aposit[(imin << 1) + 1] <= j) {
7426                     trouve = TRUE_;
7427                 } else {
7428                     ++imin;
7429                 }
7430             }
7431             k = aposit[(i__ << 1) + 2] - i__ + j;
7432             if (trouve) {
7433                 posuiv[k] = imin;
7434             } else {
7435                 posuiv[k] = -1;
7436             }
7437         }
7438     }
7439
7440
7441
7442
7443
7444     goto L9999;
7445
7446 /* ***********************************************************************
7447  */
7448 /*                   ERROR PROCESSING */
7449 /* ***********************************************************************
7450  */
7451
7452
7453
7454
7455 /* ***********************************************************************
7456  */
7457 /*                   RETURN CALLING PROGRAM */
7458 /* ***********************************************************************
7459  */
7460
7461 L9999:
7462
7463 /* ___ DESALLOCATION, ... */
7464
7465     AdvApp2Var_SysBase::maermsg_("MMPOSUI", iercod, 7L);
7466     if (ldbg) {
7467         AdvApp2Var_SysBase::mgsomsg_("MMPOSUI", 7L);
7468     }
7469  return 0 ;
7470 } /* mmposui_ */
7471
7472 //=======================================================================
7473 //function : AdvApp2Var_MathBase::mmresol_
7474 //purpose  :
7475 //=======================================================================
7476  int AdvApp2Var_MathBase::mmresol_(integer *hdimen,
7477                             integer *gdimen,
7478                             integer *hnstoc,
7479                             integer *gnstoc,
7480                             integer *mnstoc,
7481                             doublereal *matsyh,
7482                             doublereal *matsyg,
7483                             doublereal *vecsyh,
7484                             doublereal *vecsyg,
7485                             integer *hposit,
7486                             integer *hposui,
7487                             integer *gposit,
7488                             integer *mmposui,
7489                             integer *mposit,
7490                             doublereal *vecsol,
7491                             integer *iercod)
7492
7493 {
7494   integer c__100 = 100;
7495
7496    /* System generated locals */
7497     integer i__1, i__2;
7498
7499     /* Local variables */
7500     logical ldbg;
7501     doublereal* mcho = 0;
7502     integer jmin, jmax, i__, j, k, l;
7503     intptr_t iofv1, iofv2, iofv3, iofv4;
7504     doublereal *v1 = 0, *v2 = 0, *v3 = 0, *v4 = 0;
7505     integer deblig, dimhch;
7506     doublereal* hchole = 0;
7507     intptr_t iofmch, iofmam, iofhch;
7508     doublereal* matsym = 0;
7509     integer ier;
7510     integer aux;
7511
7512
7513
7514 /* ***********************************************************************
7515  */
7516
7517 /*     FUNCTION : */
7518 /*     ---------- */
7519 /*       SOLUTION OF THE SYSTEM */
7520 /*       H  t(G)   V     B */
7521 /*                    = */
7522 /*       G    0    L     C */
7523
7524 /*     KEYWORDS : */
7525 /*     ----------- */
7526 /*      RESERVE, SOLUTION, SYSTEM, LAGRANGIAN */
7527
7528 /*     INPUT ARGUMENTS : */
7529 /*     -------------------- */
7530 /*      HDIMEN: NOMBER OF LINE (OR COLUMN) OF THE HESSIAN MATRIX */
7531 /*      GDIMEN: NOMBER OF LINE OF THE MATRIX OF CONSTRAINTS */
7532 /*      HNSTOC: NOMBErS OF TERMS IN THE PROFILE OF HESSIAN MATRIX
7533 */
7534 /*      GNSTOC: NOMBERS OF TERMS IN THE PROFILE OF THE MATRIX OF CONSTRAINTS */
7535 /*      MNSTOC: NOMBERS OF TERMS IN THE PROFILE OF THE MATRIX M= G H t(G) */
7536 /*              where H IS THE HESSIAN MATRIX AND G IS THE MATRIX OF CONSTRAINTS */
7537 /*      MATSYH: TRIANGULAR INFERIOR PART OF THE HESSIAN MATRIX */
7538 /*              IN FORM OF PROFILE */
7539 /*      MATSYG: MATRIX OF CONSTRAINTS IN FORM OF PROFILE */
7540 /*      VECSYH: VECTOR OF THE SECOND MEMBER ASSOCIATED TO MATSYH */
7541 /*      VECSYG: VECTOR OF THE SECOND MEMBER ASSOCIATED TO MATSYG */
7542 /*      HPOSIT: TABLE OF POSITIONING OF THE HESSIAN MATRIX */
7543 /*              HPOSIT(1,I) CONTAINS THE NUMBER OF TERMS -1 */
7544 /*              WHICH ARE IN THE PROFILE AT LINE I */
7545 /*              HPOSIT(2,I) CONTAINS THE INDEX OF STORAGE OF TERM */
7546 /*              DIAGONAL OF THE MATRIX AT LINE I */
7547 /*      HPOSUI: TABLE ALLOWING TO PARSE THE HESSIAN MATRIX BY COLUMN */
7548 /*              IN FORM OF PROFILE */
7549 /*             HPOSUI(K) CONTAINS THE NUMBER OF LINE IMIN FOLLOWING THE CURRENT LINE*/
7550 /*              I WHERE H(I,J)=MATSYH(K) AS IT EXISTS IN THE */
7551 /*              SAME COLUMN J A TERM IN THE PROFILE OF LINE IMIN */
7552 /*              IF SUCH TERM DOES NOT EXIST IMIN=-1 */
7553 /*      GPOSIT: TABLE OF POSITIONING OF THE MATRIX OF CONSTRAINTS */
7554 /*              GPOSIT(1,I) CONTAINS THE NUMBER OF TERMS OF LINE I */
7555 /*                          WHICH ARE IN THE PROFILE */
7556 /*              GPOSIT(2,I) CONTAINS THE INDEX OF STORAGE OF THE LAST TERM */
7557 /*                          OF LINE I WHICH IS IN THE PROFILE */
7558 /*              GPOSIT(3,I) CONTAINS THE NUMBER OF COLUMN CORRESPONDING */
7559 /*                          TO THE FIRST TERM OF LINE I WHICH IS IN THE PROFILE */
7560 /*      MMPOSUI, MPOSIT: SAME STRUCTURE AS HPOSUI, BUT FOR MATRIX */
7561 /*              M=G H t(G) */
7562
7563
7564 /*     OUTPUT ARGUMENTS : */
7565 /*     --------------------- */
7566 /*       VECSOL: VECTOR SOLUTION V OF THE SYSTEM */
7567 /*       IERCOD: ERROR CODE */
7568
7569 /*     COMMONS USED : */
7570 /*     ------------------ */
7571
7572
7573 /*     REFERENCES CALLED : */
7574 /*     --------------------- */
7575
7576
7577 /*     DESCRIPTION/NOTES/LIMITATIONS : */
7578 /*     ----------------------------------- */
7579 /* > */
7580 /* ***********************************************************************
7581  */
7582 /*                            DECLARATIONS */
7583 /* ***********************************************************************
7584  */
7585
7586 /* ***********************************************************************
7587  */
7588 /*                      INITIALISATIONS */
7589 /* ***********************************************************************
7590  */
7591
7592     /* Parameter adjustments */
7593     --vecsol;
7594     hposit -= 3;
7595     --vecsyh;
7596     --hposui;
7597     --matsyh;
7598     --matsyg;
7599     --vecsyg;
7600     gposit -= 4;
7601     --mmposui;
7602     mposit -= 3;
7603
7604     /* Function Body */
7605     ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 2;
7606     if (ldbg) {
7607         AdvApp2Var_SysBase::mgenmsg_("MMRESOL", 7L);
7608     }
7609     *iercod = 0;
7610     iofhch = 0;
7611     iofv1 = 0;
7612     iofv2 = 0;
7613     iofv3 = 0;
7614     iofv4 = 0;
7615     iofmam = 0;
7616     iofmch = 0;
7617
7618 /* ***********************************************************************
7619  */
7620 /*                     PROCESSING */
7621 /* ***********************************************************************
7622  */
7623
7624 /*    Dynamic allocation */
7625     AdvApp2Var_SysBase anAdvApp2Var_SysBase;
7626     anAdvApp2Var_SysBase.macrar8_(hdimen, &c__100, v1, &iofv1, &ier);
7627     if (ier > 0) {
7628         goto L9102;
7629     }
7630     dimhch = hposit[(*hdimen << 1) + 2];
7631     anAdvApp2Var_SysBase.macrar8_(&dimhch, &c__100, hchole, &iofhch, &ier);
7632     if (ier > 0) {
7633         goto L9102;
7634     }
7635
7636 /*   solution of system 1     H V1 = b */
7637 /*   where H=MATSYH  and b=VECSYH */
7638
7639     mmchole_(hnstoc, hdimen, &matsyh[1], &hposit[3], &hposui[1], &hchole[
7640             iofhch], &ier);
7641     if (ier > 0) {
7642         goto L9101;
7643     }
7644     mmrslss_(hnstoc, hdimen, &hchole[iofhch], &hposit[3], &hposui[1], &vecsyh[
7645             1], &v1[iofv1], &ier);
7646     if (ier > 0) {
7647         goto L9102;
7648     }
7649
7650 /*    Case when there are constraints */
7651
7652     if (*gdimen > 0) {
7653
7654 /*    Calculate the vector of the second member V2=G H(-1) b -c = G v1-c */
7655 /*    of system of unknown Lagrangian vector MULTIP */
7656 /*    where G=MATSYG */
7657 /*          c=VECSYG */
7658
7659         anAdvApp2Var_SysBase.macrar8_(gdimen, &c__100, v2, &iofv2, &ier);
7660         if (ier > 0) {
7661             goto L9102;
7662         }
7663         anAdvApp2Var_SysBase.macrar8_(hdimen, &c__100, v3, &iofv3, &ier);
7664         if (ier > 0) {
7665             goto L9102;
7666         }
7667         anAdvApp2Var_SysBase.macrar8_(gdimen, &c__100, v4, &iofv4, &ier);
7668         if (ier > 0) {
7669             goto L9102;
7670         }
7671         anAdvApp2Var_SysBase.macrar8_(mnstoc, &c__100, matsym, &iofmam, &ier);
7672         if (ier > 0) {
7673             goto L9102;
7674         }
7675
7676         deblig = 1;
7677         mmatvec_(gdimen, hdimen, &gposit[4], gnstoc, &matsyg[1], &v1[iofv1], &
7678                 deblig, &v2[iofv2], &ier);
7679         if (ier > 0) {
7680             goto L9101;
7681         }
7682         i__1 = *gdimen;
7683         for (i__ = 1; i__ <= i__1; ++i__) {
7684             v2[i__ + iofv2 - 1] -= vecsyg[i__];
7685         }
7686
7687 /*     Calculate the matrix M= G H(-1) t(G) */
7688 /*     RESOL DU SYST 2 : H qi = gi */
7689 /*            where is a vector column of t(G) */
7690 /*                qi=v3 */
7691 /*            then calculate G qi */
7692 /*            then construct M in form of profile */
7693
7694
7695
7696         i__1 = *gdimen;
7697         for (i__ = 1; i__ <= i__1; ++i__) {
7698             AdvApp2Var_SysBase::mvriraz_(hdimen, &v1[iofv1]);
7699             AdvApp2Var_SysBase::mvriraz_(hdimen, &v3[iofv3]);
7700             AdvApp2Var_SysBase::mvriraz_(gdimen, &v4[iofv4]);
7701             jmin = gposit[i__ * 3 + 3];
7702             jmax = gposit[i__ * 3 + 1] + gposit[i__ * 3 + 3] - 1;
7703             aux = gposit[i__ * 3 + 2] - gposit[i__ * 3 + 1] - jmin + 1;
7704             i__2 = jmax;
7705             for (j = jmin; j <= i__2; ++j) {
7706                 k = j + aux;
7707                 v1[j + iofv1 - 1] = matsyg[k];
7708             }
7709             mmrslss_(hnstoc, hdimen, &hchole[iofhch], &hposit[3], &hposui[1],
7710                     &v1[iofv1], &v3[iofv3], &ier);
7711             if (ier > 0) {
7712                 goto L9101;
7713             }
7714
7715             deblig = i__;
7716             mmatvec_(gdimen, hdimen, &gposit[4], gnstoc, &matsyg[1], &v3[
7717                     iofv3], &deblig, &v4[iofv4], &ier);
7718             if (ier > 0) {
7719                 goto L9101;
7720             }
7721
7722             k = mposit[(i__ << 1) + 2];
7723             matsym[k + iofmam - 1] = v4[i__ + iofv4 - 1];
7724             while(mmposui[k] > 0) {
7725                 l = mmposui[k];
7726                 k = mposit[(l << 1) + 2] - l + i__;
7727                 matsym[k + iofmam - 1] = v4[l + iofv4 - 1];
7728             }
7729         }
7730
7731
7732 /*    SOLVE SYST 3  M L = V2 */
7733 /*     WITH L=V4 */
7734
7735
7736         AdvApp2Var_SysBase::mvriraz_(gdimen, &v4[iofv4]);
7737         anAdvApp2Var_SysBase.macrar8_(mnstoc, &c__100, mcho, &iofmch, &ier);
7738         if (ier > 0) {
7739             goto L9102;
7740         }
7741         mmchole_(mnstoc, gdimen, &matsym[iofmam], &mposit[3], &mmposui[1], &
7742                 mcho[iofmch], &ier);
7743         if (ier > 0) {
7744             goto L9101;
7745         }
7746         mmrslss_(mnstoc, gdimen, &mcho[iofmch], &mposit[3], &mmposui[1], &v2[
7747                 iofv2], &v4[iofv4], &ier);
7748         if (ier > 0) {
7749             goto L9102;
7750         }
7751
7752
7753 /*    CALCULATE THE VECTOR OF THE SECOND MEMBER OF THE SYSTEM  Hx = b - t(G) L
7754 */
7755 /*                                                      = V1 */
7756
7757         AdvApp2Var_SysBase::mvriraz_(hdimen, &v1[iofv1]);
7758         mmtmave_(gdimen, hdimen, &gposit[4], gnstoc, &matsyg[1], &v4[iofv4], &
7759                 v1[iofv1], &ier);
7760         if (ier > 0) {
7761             goto L9101;
7762         }
7763         i__1 = *hdimen;
7764         for (i__ = 1; i__ <= i__1; ++i__) {
7765             v1[i__ + iofv1 - 1] = vecsyh[i__] - v1[i__ + iofv1 - 1];
7766         }
7767
7768 /*    RESOL SYST 4   Hx = b - t(G) L */
7769
7770
7771         mmrslss_(hnstoc, hdimen, &hchole[iofhch], &hposit[3], &hposui[1], &v1[
7772                 iofv1], &vecsol[1], &ier);
7773         if (ier > 0) {
7774             goto L9102;
7775         }
7776     } else {
7777         i__1 = *hdimen;
7778         for (i__ = 1; i__ <= i__1; ++i__) {
7779             vecsol[i__] = v1[i__ + iofv1 - 1];
7780         }
7781     }
7782
7783     goto L9999;
7784
7785 /* ***********************************************************************
7786  */
7787 /*                   PROCESSING OF ERRORS */
7788 /* ***********************************************************************
7789  */
7790
7791
7792 L9101:
7793     *iercod = 1;
7794     goto L9999;
7795
7796 L9102:
7797     AdvApp2Var_SysBase::mswrdbg_("MMRESOL : PROBLEM WITH DIMMAT", 30L);
7798     *iercod = 2;
7799
7800 /* ***********************************************************************
7801  */
7802 /*                   RETURN CALLING PROGRAM */
7803 /* ***********************************************************************
7804  */
7805
7806 L9999:
7807
7808 /* ___ DESALLOCATION, ... */
7809     anAdvApp2Var_SysBase.macrdr8_(hdimen, &c__100, v1, &iofv1, &ier);
7810     if (*iercod == 0 && ier > 0) {
7811         *iercod = 3;
7812     }
7813     anAdvApp2Var_SysBase.macrdr8_(&dimhch, &c__100, hchole, &iofhch, &ier);
7814     if (*iercod == 0 && ier > 0) {
7815         *iercod = 3;
7816     }
7817     anAdvApp2Var_SysBase.macrdr8_(gdimen, &c__100, v2, &iofv2, &ier);
7818     if (*iercod == 0 && ier > 0) {
7819         *iercod = 3;
7820     }
7821     anAdvApp2Var_SysBase.macrdr8_(hdimen, &c__100, v3, &iofv3, &ier);
7822     if (*iercod == 0 && ier > 0) {
7823         *iercod = 3;
7824     }
7825     anAdvApp2Var_SysBase.macrdr8_(gdimen, &c__100, v4, &iofv4, &ier);
7826     if (*iercod == 0 && ier > 0) {
7827         *iercod = 3;
7828     }
7829     anAdvApp2Var_SysBase.macrdr8_(mnstoc, &c__100, matsym, &iofmam, &ier);
7830     if (*iercod == 0 && ier > 0) {
7831         *iercod = 3;
7832     }
7833     anAdvApp2Var_SysBase.macrdr8_(mnstoc, &c__100, mcho, &iofmch, &ier);
7834     if (*iercod == 0 && ier > 0) {
7835         *iercod = 3;
7836     }
7837
7838     AdvApp2Var_SysBase::maermsg_("MMRESOL", iercod, 7L);
7839     if (ldbg) {
7840         AdvApp2Var_SysBase::mgsomsg_("MMRESOL", 7L);
7841     }
7842  return 0 ;
7843 } /* mmresol_ */
7844
7845 //=======================================================================
7846 //function : mmrslss_
7847 //purpose  :
7848 //=======================================================================
7849 int mmrslss_(integer *,//mxcoef,
7850              integer *dimens,
7851              doublereal *smatri,
7852              integer *sposit,
7853              integer *posuiv,
7854              doublereal *mscnmbr,
7855              doublereal *soluti,
7856              integer *iercod)
7857 {
7858   /* System generated locals */
7859   integer i__1, i__2;
7860
7861   /* Local variables */
7862   logical ldbg;
7863   integer i__, j;
7864   doublereal somme;
7865   integer pointe, ptcour;
7866
7867 /* ***********************************************************************
7868  */
7869
7870 /*     FuNCTION : */
7871 /*     ----------                     T */
7872 /*       Solves linear system SS x = b where S is a  */
7873 /*       triangular lower matrix given in form of profile */
7874
7875 /*     KEYWORDS : */
7876 /*     ----------- */
7877 /*     RESERVE, MATRICE_PROFILE, RESOLUTION, CHOLESKI */
7878
7879 /*     INPUT ARGUMENTS : */
7880 /*     -------------------- */
7881 /*     MXCOEF  : Maximum number of non-null coefficient in the matrix */
7882 /*     DIMENS  : Dimension of the matrix */
7883 /*     SMATRI(MXCOEF) : Values of coefficients of the matrix */
7884 /*     SPOSIT(2,DIMENS): */
7885 /*       SPOSIT(1,*) : Distance diagonal-extremity of the line */
7886 /*       SPOSIT(2,*) : Position of diagonal terms in AMATRI */
7887 /*     POSUIV(MXCOEF): first line inferior not out of profile */
7888 /*     MSCNMBR(DIMENS): Vector second member of the equation */
7889
7890 /*     OUTPUT ARGUMENTS : */
7891 /*     --------------------- */
7892 /*     SOLUTI(NDIMEN) : Result vector */
7893 /*     IERCOD   : Error code 0  : ok */
7894
7895 /*     COMMONS USED : */
7896 /*     ------------------ */
7897
7898
7899 /*     REFERENCES CALLED : */
7900 /*     --------------------- */
7901
7902
7903 /*     DESCRIPTION/NOTES/LIMITATIONS : */
7904 /*     ----------------------------------- */
7905 /*       T */
7906 /*     SS  is the decomposition of choleski of a symmetric matrix */
7907 /*     defined postive, that can result from routine MMCHOLE. */
7908
7909 /*     For a full matrix it is possible to use MRSLMSC */
7910
7911 /*     LEVEL OF DEBUG = 4 */
7912 /* > */
7913 /* ***********************************************************************
7914  */
7915 /*                            DECLARATIONS */
7916 /* ***********************************************************************
7917  */
7918
7919
7920
7921 /* ***********************************************************************
7922  */
7923 /*                      INITIALISATIONS */
7924 /* ***********************************************************************
7925  */
7926
7927     /* Parameter adjustments */
7928     --posuiv;
7929     --smatri;
7930     --soluti;
7931     --mscnmbr;
7932     sposit -= 3;
7933
7934     /* Function Body */
7935     ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 4;
7936     if (ldbg) {
7937         AdvApp2Var_SysBase::mgenmsg_("MMRSLSS", 7L);
7938     }
7939     *iercod = 0;
7940
7941 /* ***********************************************************************
7942  */
7943 /*                     PROCESSING */
7944 /* ***********************************************************************
7945  */
7946
7947 /* ----- Solution of Sw = b */
7948
7949     i__1 = *dimens;
7950     for (i__ = 1; i__ <= i__1; ++i__) {
7951
7952         pointe = sposit[(i__ << 1) + 2];
7953         somme = 0.;
7954         i__2 = i__ - 1;
7955         for (j = i__ - sposit[(i__ << 1) + 1]; j <= i__2; ++j) {
7956             somme += smatri[pointe - (i__ - j)] * soluti[j];
7957         }
7958
7959         soluti[i__] = (mscnmbr[i__] - somme) / smatri[pointe];
7960     }
7961 /*                     T */
7962 /* ----- Solution of S u = w */
7963
7964     for (i__ = *dimens; i__ >= 1; --i__) {
7965
7966         pointe = sposit[(i__ << 1) + 2];
7967         j = posuiv[pointe];
7968         somme = 0.;
7969         while(j > 0) {
7970             ptcour = sposit[(j << 1) + 2] - (j - i__);
7971             somme += smatri[ptcour] * soluti[j];
7972             j = posuiv[ptcour];
7973         }
7974
7975         soluti[i__] = (soluti[i__] - somme) / smatri[pointe];
7976     }
7977
7978     goto L9999;
7979
7980 /* ***********************************************************************
7981  */
7982 /*                   ERROR PROCESSING */
7983 /* ***********************************************************************
7984  */
7985
7986
7987 /* ***********************************************************************
7988  */
7989 /*                   RETURN PROGRAM CALLING */
7990 /* ***********************************************************************
7991  */
7992
7993 L9999:
7994
7995     AdvApp2Var_SysBase::maermsg_("MMRSLSS", iercod, 7L);
7996     if (ldbg) {
7997         AdvApp2Var_SysBase::mgsomsg_("MMRSLSS", 7L);
7998     }
7999  return 0 ;
8000 } /* mmrslss_ */
8001
8002 //=======================================================================
8003 //function : mmrslw_
8004 //purpose  :
8005 //=======================================================================
8006 int mmrslw_(integer *normax,
8007             integer *nordre,
8008             integer *ndimen,
8009             doublereal *epspiv,
8010             doublereal *abmatr,
8011             doublereal *xmatri,
8012             integer *iercod)
8013 {
8014   /* System generated locals */
8015     integer abmatr_dim1, abmatr_offset, xmatri_dim1, xmatri_offset, i__1,
8016             i__2, i__3;
8017     doublereal d__1;
8018
8019     /* Local variables */
8020     integer kpiv;
8021     doublereal pivot;
8022     integer ii, jj, kk;
8023     doublereal akj;
8024
8025
8026 /* **********************************************************************
8027 */
8028
8029 /*     FUNCTION : */
8030 /*     ---------- */
8031 /*  Solution of a linear system A.x = B of N equations to N */
8032 /*  unknown by Gauss method (partial pivot) or : */
8033 /*          A is matrix NORDRE * NORDRE, */
8034 /*          B is matrix NORDRE (lines) * NDIMEN (columns), */
8035 /*          x is matrix NORDRE (lines) * NDIMEN (columns). */
8036 /*  In this program, A and B are stored in matrix ABMATR  */
8037 /*  the lines and columns which of were inverted. ABMATR(k,j) is */
8038 /*  term A(j,k) if k <= NORDRE, B(j,k-NORDRE) otherwise (see example). */
8039
8040 /*     KEYWORDS : */
8041 /*     ----------- */
8042 /* TOUS, MATH_ACCES::EQUATION&, MATRICE&, RESOLUTION, GAUSS, &SOLUTION */
8043
8044 /*     INPUT ARGUMENTS : */
8045 /*     ------------------ */
8046 /*   NORMAX : Max size of the first index of XMATRI. This argument */
8047 /*            serves only for the declaration of dimension of XMATRI and should be */
8048 /*            above or equal to NORDRE. */
8049 /*   NORDRE : Order of the matrix i.e. number of equations and  */
8050 /*            unknown quantities of the linear system to be solved. */
8051 /*   NDIMEN : Number of the second member. */
8052 /*   EPSPIV : Minimal value of a pivot. If during the calculation  */
8053 /*            the absolute value of the pivot is below EPSPIV, the */
8054 /*            system of equations is declared singular. EPSPIV should */
8055 /*            be a "small" real. */
8056
8057 /*   ABMATR(NORDRE+NDIMEN,NORDRE) : Auxiliary matrix containing  */
8058 /*                                  matrix A and matrix B. */
8059
8060 /*     OUTPUT ARGUMENTS : */
8061 /*     ------------------- */
8062 /*   XMATRI : Matrix containing  NORDRE*NDIMEN solutions. */
8063 /*   IERCOD=0 shows that all solutions are calculated. */
8064 /*   IERCOD=1 shows that the matrix is of lower rank than NORDRE */
8065 /*            (the system is singular). */
8066
8067 /*     COMMONS USED   : */
8068 /*     ---------------- */
8069
8070 /*     REFERENCES CALLED   : */
8071 /*     ----------------------- */
8072
8073 /*     DESCRIPTION/NOTES/LIMITATIONS : */
8074 /*     ----------------------------------- */
8075 /*     ATTENTION : the indices of line and column are inverted */
8076 /*                 compared to usual indices. */
8077 /*                 System : */
8078 /*                        a1*x + b1*y = c1 */
8079 /*                        a2*x + b2*y = c2 */
8080 /*                 should be represented by matrix ABMATR : */
8081
8082 /*                 ABMATR(1,1) = a1  ABMATR(1,2) = a2 */
8083 /*                 ABMATR(2,1) = b1  ABMATR(2,2) = b2 */
8084 /*                 ABMATR(3,1) = c1  ABMATR(3,2) = c2 */
8085
8086 /*     To solve this system, it is necessary to set : */
8087
8088 /*                 NORDRE = 2 (there are 2 equations with 2 unknown values), */
8089 /*                 NDIMEN = 1 (there is only one second member), */
8090 /*                 any NORMAX can be taken >= NORDRE. */
8091
8092 /*     To use this routine, it is recommended to use one of */
8093 /*     interfaces : MMRSLWI or MMMRSLWD. */
8094 /* > */
8095 /* **********************************************************************
8096 */
8097
8098 /*   Name of the routine */
8099
8100 /*      INTEGER IBB,MNFNDEB */
8101
8102 /*      IBB=MNFNDEB() */
8103 /*      IF (IBB.GE.2) CALL MGENMSG(NOMPR) */
8104     /* Parameter adjustments */
8105     xmatri_dim1 = *normax;
8106     xmatri_offset = xmatri_dim1 + 1;
8107     xmatri -= xmatri_offset;
8108     abmatr_dim1 = *nordre + *ndimen;
8109     abmatr_offset = abmatr_dim1 + 1;
8110     abmatr -= abmatr_offset;
8111
8112     /* Function Body */
8113     *iercod = 0;
8114
8115 /* *********************************************************************
8116 */
8117 /*                  Triangulation of matrix ABMATR. */
8118 /* *********************************************************************
8119 */
8120
8121     i__1 = *nordre;
8122     for (kk = 1; kk <= i__1; ++kk) {
8123
8124 /* ---------- Find max pivot in column KK. ------------
8125 --- */
8126
8127         pivot = *epspiv;
8128         kpiv = 0;
8129         i__2 = *nordre;
8130         for (jj = kk; jj <= i__2; ++jj) {
8131             akj = (d__1 = abmatr[kk + jj * abmatr_dim1], advapp_abs(d__1));
8132             if (akj > pivot) {
8133                 pivot = akj;
8134                 kpiv = jj;
8135             }
8136 /* L100: */
8137         }
8138         if (kpiv == 0) {
8139             goto L9900;
8140         }
8141
8142 /* --------- Swapping of line KPIV with line KK. ------
8143 --- */
8144
8145         if (kpiv != kk) {
8146             i__2 = *nordre + *ndimen;
8147             for (jj = kk; jj <= i__2; ++jj) {
8148                 akj = abmatr[jj + kk * abmatr_dim1];
8149                 abmatr[jj + kk * abmatr_dim1] = abmatr[jj + kpiv *
8150                         abmatr_dim1];
8151                 abmatr[jj + kpiv * abmatr_dim1] = akj;
8152 /* L200: */
8153             }
8154         }
8155
8156 /* ---------- Removal and triangularization. -----------
8157 --- */
8158
8159         pivot = -abmatr[kk + kk * abmatr_dim1];
8160         i__2 = *nordre;
8161         for (ii = kk + 1; ii <= i__2; ++ii) {
8162             akj = abmatr[kk + ii * abmatr_dim1] / pivot;
8163             i__3 = *nordre + *ndimen;
8164             for (jj = kk + 1; jj <= i__3; ++jj) {
8165                 abmatr[jj + ii * abmatr_dim1] += akj * abmatr[jj + kk *
8166                         abmatr_dim1];
8167 /* L400: */
8168             }
8169 /* L300: */
8170         }
8171
8172
8173 /* L1000: */
8174     }
8175
8176 /* *********************************************************************
8177 */
8178 /*          Solution of the system of triangular equations. */
8179 /*   Matrix ABMATR(NORDRE+JJ,II), contains second members  */
8180 /*             of the system for 1<=j<=NDIMEN and 1<=i<=NORDRE. */
8181 /* *********************************************************************
8182 */
8183
8184
8185 /* ---------------- Calculation of solutions by ascending. -----------------
8186 */
8187
8188     for (kk = *nordre; kk >= 1; --kk) {
8189         pivot = abmatr[kk + kk * abmatr_dim1];
8190         i__1 = *ndimen;
8191         for (ii = 1; ii <= i__1; ++ii) {
8192             akj = abmatr[ii + *nordre + kk * abmatr_dim1];
8193             i__2 = *nordre;
8194             for (jj = kk + 1; jj <= i__2; ++jj) {
8195                 akj -= abmatr[jj + kk * abmatr_dim1] * xmatri[jj + ii *
8196                         xmatri_dim1];
8197 /* L800: */
8198             }
8199             xmatri[kk + ii * xmatri_dim1] = akj / pivot;
8200 /* L700: */
8201         }
8202 /* L600: */
8203     }
8204     goto L9999;
8205
8206 /* ------If the absolute value of a pivot is smaller than -------- */
8207 /* ---------- EPSPIV: return the code of error. ------------
8208 */
8209
8210 L9900:
8211     *iercod = 1;
8212
8213
8214
8215 L9999:
8216     if (*iercod > 0) {
8217         AdvApp2Var_SysBase::maermsg_("MMRSLW ", iercod, 7L);
8218     }
8219 /*      IF (IBB.GE.2) CALL MGSOMSG(NOMPR) */
8220  return 0 ;
8221 } /* mmrslw_ */
8222
8223 //=======================================================================
8224 //function : AdvApp2Var_MathBase::mmmrslwd_
8225 //purpose  :
8226 //=======================================================================
8227  int AdvApp2Var_MathBase::mmmrslwd_(integer *normax,
8228                              integer *nordre,
8229                              integer *ndim,
8230                              doublereal *amat,
8231                              doublereal *bmat,
8232                              doublereal *epspiv,
8233                              doublereal *aaux,
8234                              doublereal *xmat,
8235                              integer *iercod)
8236
8237 {
8238   /* System generated locals */
8239   integer amat_dim1, amat_offset, bmat_dim1, bmat_offset, xmat_dim1,
8240   xmat_offset, aaux_dim1, aaux_offset, i__1, i__2;
8241
8242   /* Local variables */
8243   integer i__, j;
8244   integer ibb;
8245
8246 /*      IMPLICIT DOUBLE PRECISION (A-H,O-Z) */
8247 /*      IMPLICIT INTEGER (I-N) */
8248
8249
8250 /* **********************************************************************
8251 */
8252
8253 /*     FUNCTION : */
8254 /*     ---------- */
8255 /*        Solution of a linear system by Gauss method where */
8256 /*        the second member is a table of vectors. Method of partial pivot. */
8257
8258 /*     KEYWORDS : */
8259 /*     ----------- */
8260 /*        ALL, MATH_ACCES :: */
8261 /*        SYSTEME&,EQUATION&, RESOLUTION,GAUSS ,&VECTEUR */
8262
8263 /*     INPUT ARGUMENTS : */
8264 /*     ------------------ */
8265 /*        NORMAX : Max. Dimension of AMAT. */
8266 /*        NORDRE :  Order of the matrix. */
8267 /*        NDIM : Number of columns of BMAT and XMAT. */
8268 /*        AMAT(NORMAX,NORDRE) : The processed matrix. */
8269 /*        BMAT(NORMAX,NDIM)   : The matrix of second member. */
8270 /*        XMAT(NORMAX,NDIM)   : The matrix of solutions. */
8271 /*        EPSPIV : Min value of a pivot. */
8272
8273 /*     OUTPUT ARGUMENTS : */
8274 /*     ------------------- */
8275 /*        AAUX(NORDRE+NDIM,NORDRE) : Auxiliary matrix. */
8276 /*        XMAT(NORMAX,NDIM) : Matrix of solutions. */
8277 /*        IERCOD=0 shows that solutions in XMAT are valid. */
8278 /*        IERCOD=1 shows that matrix AMAT is of lower rank than NORDRE. */
8279
8280 /*     COMMONS USED   : */
8281 /*     ---------------- */
8282
8283 /*      .Neant. */
8284
8285 /*     REFERENCES CALLED : */
8286 /*     ---------------------- */
8287 /*     Type  Name */
8288 /*           MAERMSG              MGENMSG              MGSOMSG */
8289 /*           MMRSLW          I*4  MNFNDEB */
8290
8291 /*     DESCRIPTION/NOTES/LIMITATIONS : */
8292 /*     ----------------------------------- */
8293 /*    ATTENTION : lines and columns are located in usual order : */
8294 /*               1st index  = index line */
8295 /*               2nd index = index column */
8296 /*    Example, the system : */
8297 /*                 a1*x + b1*y = c1 */
8298 /*                 a2*x + b2*y = c2 */
8299 /*    is represented by matrix AMAT : */
8300
8301 /*                 AMAT(1,1) = a1  AMAT(2,1) = a2 */
8302 /*                 AMAT(1,2) = b1  AMAT(2,2) = b2 */
8303
8304 /*     The first index is the index of line, the second index */
8305 /*     is the index of columns (Compare with MMRSLWI which is faster). */
8306
8307 /* > */
8308 /* **********************************************************************
8309 */
8310
8311 /*   Name of the routine */
8312
8313     /* Parameter adjustments */
8314     amat_dim1 = *normax;
8315     amat_offset = amat_dim1 + 1;
8316     amat -= amat_offset;
8317     xmat_dim1 = *normax;
8318     xmat_offset = xmat_dim1 + 1;
8319     xmat -= xmat_offset;
8320     aaux_dim1 = *nordre + *ndim;
8321     aaux_offset = aaux_dim1 + 1;
8322     aaux -= aaux_offset;
8323     bmat_dim1 = *normax;
8324     bmat_offset = bmat_dim1 + 1;
8325     bmat -= bmat_offset;
8326
8327     /* Function Body */
8328     ibb = AdvApp2Var_SysBase::mnfndeb_();
8329     if (ibb >= 3) {
8330         AdvApp2Var_SysBase::mgenmsg_("MMMRSLW", 7L);
8331     }
8332
8333 /*   Initialization of the auxiliary matrix. */
8334
8335     i__1 = *nordre;
8336     for (i__ = 1; i__ <= i__1; ++i__) {
8337         i__2 = *nordre;
8338         for (j = 1; j <= i__2; ++j) {
8339             aaux[j + i__ * aaux_dim1] = amat[i__ + j * amat_dim1];
8340 /* L200: */
8341         }
8342 /* L100: */
8343     }
8344
8345 /*    Second member. */
8346
8347     i__1 = *nordre;
8348     for (i__ = 1; i__ <= i__1; ++i__) {
8349         i__2 = *ndim;
8350         for (j = 1; j <= i__2; ++j) {
8351             aaux[j + *nordre + i__ * aaux_dim1] = bmat[i__ + j * bmat_dim1];
8352 /* L400: */
8353         }
8354 /* L300: */
8355     }
8356
8357 /*    Solution of the system of equations. */
8358
8359     mmrslw_(normax, nordre, ndim, epspiv, &aaux[aaux_offset], &xmat[
8360             xmat_offset], iercod);
8361
8362
8363     if (*iercod != 0) {
8364         AdvApp2Var_SysBase::maermsg_("MMMRSLW", iercod, 7L);
8365     }
8366     if (ibb >= 3) {
8367         AdvApp2Var_SysBase::mgsomsg_("MMMRSLW", 7L);
8368     }
8369  return 0 ;
8370 } /* mmmrslwd_ */
8371
8372 //=======================================================================
8373 //function : AdvApp2Var_MathBase::mmrtptt_
8374 //purpose  :
8375 //=======================================================================
8376  int AdvApp2Var_MathBase::mmrtptt_(integer *ndglgd,
8377                             doublereal *rtlegd)
8378
8379 {
8380   integer ideb, nmod2, nsur2, ilong, ibb;
8381
8382
8383 /* **********************************************************************
8384 */
8385
8386 /*     FUNCTION : */
8387 /*     ---------- */
8388 /*     Extracts from Common LDGRTL the STRICTLY positive roots of the */
8389 /*     Legendre polynom of degree NDGLGD, for 2 <= NDGLGD <= 61. */
8390
8391 /*     KEYWORDS : */
8392 /*     ----------- */
8393 /*     TOUS, AB_SPECIFI::COMMON&, EXTRACTION, &RACINE, &LEGENDRE. */
8394
8395 /*     INPUT ARGUMENTS : */
8396 /*     ------------------ */
8397 /*        NDGLGD : Mathematic degree of Legendre polynom. */
8398 /*                 This degree should be above or equal to 2 and */
8399 /*                 below or equal to 61. */
8400
8401 /*     OUTPUT ARGUMENTS : */
8402 /*     ------------------- */
8403 /*        RTLEGD : The table of strictly positive roots of */
8404 /*                 Legendre polynom of degree NDGLGD. */
8405
8406 /*     COMMONS USED   : */
8407 /*     ---------------- */
8408
8409 /*     REFERENCES CALLED   : */
8410 /*     ----------------------- */
8411
8412 /*     DESCRIPTION/NOTES/LIMITATIONS : */
8413 /*     ----------------------------------- */
8414 /*     ATTENTION: the condition on NDEGRE ( 2 <= NDEGRE <= 61) is not */
8415 /*     tested. The caller should make the test. */
8416
8417 /* > */
8418 /* **********************************************************************
8419 */
8420 /*   Nome of the routine */
8421
8422
8423 /*   Common MLGDRTL: */
8424 /*   This common includes POSITIVE roots of Legendre polynoms */
8425 /*   AND the weight of Gauss quadrature formulas on all */
8426 /*   POSITIVE roots of Legendre polynoms. */
8427
8428
8429 /* ***********************************************************************
8430  */
8431
8432 /*     FUNCTION : */
8433 /*     ---------- */
8434 /*   The common of Legendre roots. */
8435
8436 /*     KEYWORDS : */
8437 /*     ----------- */
8438 /*        BASE LEGENDRE */
8439
8440 /*     DEMSCRIPTION/NOTES/LIMITATIONS : */
8441 /*     ----------------------------------- */
8442
8443 /* > */
8444 /* ***********************************************************************
8445  */
8446
8447
8448
8449
8450 /*   ROOTAB : Table of all rotts of Legendre polynoms */
8451 /*   between [0,1]. They are ranked for degrees increasing from 2 to 61. */
8452 /*   HILTAB : Table of Legendre interpolators concerning ROOTAB. */
8453 /*   The address is the same. */
8454 /*   HI0TAB : Table of Legendre interpolators for root x=0 */
8455 /*   the polynoms of UNEVEN degree. */
8456 /*   RTLTB0 : Table of Li(uk) where uk are roots of a */
8457 /*   Legendre polynom of EVEN degree. */
8458 /*   RTLTB1 : Table of Li(uk) where uk are roots of a */
8459 /*   Legendre polynom of UNEVEN degree. */
8460
8461
8462 /************************************************************************
8463 *****/
8464     /* Parameter adjustments */
8465     --rtlegd;
8466
8467     /* Function Body */
8468     ibb = AdvApp2Var_SysBase::mnfndeb_();
8469     if (ibb >= 3) {
8470         AdvApp2Var_SysBase::mgenmsg_("MMRTPTT", 7L);
8471     }
8472     if (*ndglgd < 2) {
8473         goto L9999;
8474     }
8475
8476     nsur2 = *ndglgd / 2;
8477     nmod2 = *ndglgd % 2;
8478
8479     ilong = nsur2 << 3;
8480     ideb = nsur2 * (nsur2 - 1) / 2 + 1;
8481     AdvApp2Var_SysBase::mcrfill_(&ilong,
8482              &mlgdrtl_.rootab[ideb + nmod2 * 465 - 1],
8483              &rtlegd[1]);
8484
8485 /* ----------------------------- The end --------------------------------
8486 */
8487
8488 L9999:
8489     if (ibb >= 3) {
8490         AdvApp2Var_SysBase::mgsomsg_("MMRTPTT", 7L);
8491     }
8492     return 0;
8493 } /* mmrtptt_ */
8494
8495 //=======================================================================
8496 //function : AdvApp2Var_MathBase::mmsrre2_
8497 //purpose  :
8498 //=======================================================================
8499  int AdvApp2Var_MathBase::mmsrre2_(doublereal *tparam,
8500                             integer *nbrval,
8501                             doublereal *tablev,
8502                             doublereal *epsil,
8503                             integer *numint,
8504                             integer *itypen,
8505                             integer *iercod)
8506 {
8507   /* System generated locals */
8508   doublereal d__1;
8509
8510   /* Local variables */
8511   integer ideb, ifin, imil, ibb;
8512
8513 /* ***********************************************************************
8514  */
8515
8516 /*     FUNCTION : */
8517 /*     -------- */
8518
8519 /*     Find the interval corresponding to a valueb given in  */
8520 /*     increasing order of real numbers with double precision. */
8521
8522 /*     KEYWORDS : */
8523 /*     --------- */
8524 /*     TOUS,MATH_ACCES::TABLEAU&,POINT&,CORRESPONDANCE,&RANG */
8525
8526 /*     INPUT ARGUMENTS : */
8527 /*     ------------------ */
8528
8529 /*     TPARAM  : Value to be tested. */
8530 /*     NBRVAL  : Size of TABLEV */
8531 /*     TABLEV  : Table of reals. */
8532 /*     EPSIL   : Epsilon of precision */
8533
8534 /*     OUTPUT ARGUMENTS : */
8535 /*     ------------------- */
8536
8537 /*     NUMINT  : Number of the interval (between 1 and NBRVAL-1). */
8538 /*     ITYPEN  : = 0 TPARAM is inside the interval NUMINT */
8539 /*               = 1 : TPARAM corresponds to the lower limit of */
8540 /*               the provided interval. */
8541 /*               = 2 : TPARAM corresponds to the upper limit of */
8542 /*               the provided interval. */
8543
8544 /*     IERCOD : Error code. */
8545 /*                     = 0 : OK */
8546 /*                     = 1 : TABLEV does not contain enough elements. */
8547 /*                     = 2 : TPARAM out of limits of TABLEV. */
8548
8549 /*     COMMONS USED : */
8550 /*     ---------------- */
8551
8552 /*     REFERENCES CALLED : */
8553 /*     ------------------- */
8554
8555 /*     DESCRIPTION/NOTES/LIMITATIONS : */
8556 /*     --------------------------------- */
8557 /*     There are NBRVAL values in TABLEV which stands for NBRVAL-1 intervals. */
8558 /*     One searches the interval containing TPARAM by */
8559 /*     dichotomy. Complexity of the algorithm : Log(n)/Log(2).(RBD). */
8560 /* > */
8561 /* ***********************************************************************
8562  */
8563
8564
8565 /* Initialisations */
8566
8567     /* Parameter adjustments */
8568     --tablev;
8569
8570     /* Function Body */
8571     ibb = AdvApp2Var_SysBase::mnfndeb_();
8572     if (ibb >= 6) {
8573         AdvApp2Var_SysBase::mgenmsg_("MMSRRE2", 7L);
8574     }
8575
8576     *iercod = 0;
8577     *numint = 0;
8578     *itypen = 0;
8579     ideb = 1;
8580     ifin = *nbrval;
8581
8582 /* TABLEV should contain at least two values */
8583
8584     if (*nbrval < 2) {
8585         *iercod = 1;
8586         goto L9999;
8587     }
8588
8589 /* TPARAM should be between extreme limits of TABLEV. */
8590
8591     if (*tparam < tablev[1] || *tparam > tablev[*nbrval]) {
8592         *iercod = 2;
8593         goto L9999;
8594     }
8595
8596 /* ----------------------- SEARCH OF THE INTERVAL --------------------
8597 */
8598
8599 L1000:
8600
8601 /* Test end of loop (found). */
8602
8603     if (ideb + 1 == ifin) {
8604         *numint = ideb;
8605         goto L2000;
8606     }
8607
8608 /* Find by dichotomy on increasing values of TABLEV. */
8609
8610     imil = (ideb + ifin) / 2;
8611     if (*tparam >= tablev[ideb] && *tparam <= tablev[imil]) {
8612         ifin = imil;
8613     } else {
8614         ideb = imil;
8615     }
8616
8617     goto L1000;
8618
8619 /* -------------- TEST IF TPARAM IS NOT A VALUE --------- */
8620 /* ------------------------OF TABLEV UP TO EPSIL ----------------------
8621 */
8622
8623 L2000:
8624     if ((d__1 = *tparam - tablev[ideb], advapp_abs(d__1)) < *epsil) {
8625         *itypen = 1;
8626         goto L9999;
8627     }
8628     if ((d__1 = *tparam - tablev[ifin], advapp_abs(d__1)) < *epsil) {
8629         *itypen = 2;
8630         goto L9999;
8631     }
8632
8633 /* --------------------------- THE END ----------------------------------
8634 */
8635
8636 L9999:
8637     if (*iercod > 0) {
8638         AdvApp2Var_SysBase::maermsg_("MMSRRE2", iercod, 7L);
8639     }
8640     if (ibb >= 6) {
8641         AdvApp2Var_SysBase::mgsomsg_("MMSRRE2", 7L);
8642     }
8643  return 0 ;
8644 } /* mmsrre2_ */
8645
8646 //=======================================================================
8647 //function : mmtmave_
8648 //purpose  :
8649 //=======================================================================
8650 int mmtmave_(integer *nligne,
8651              integer *ncolon,
8652              integer *gposit,
8653              integer *,//gnstoc,
8654              doublereal *gmatri,
8655              doublereal *vecin,
8656              doublereal *vecout,
8657              integer *iercod)
8658
8659 {
8660   /* System generated locals */
8661   integer i__1, i__2;
8662
8663   /* Local variables */
8664   logical ldbg;
8665   integer imin, imax, i__, j, k;
8666   doublereal somme;
8667   integer aux;
8668
8669
8670 /* ***********************************************************************
8671  */
8672
8673 /*     FUNCTION : */
8674 /*     ---------- */
8675 /*                          t */
8676 /*      CREATES PRODUCT   G V */
8677 /*      WHERE THE MATRIX IS IN FORM OF PROFILE */
8678
8679 /*     KEYWORDS : */
8680 /*     ----------- */
8681 /*      RESERVE, PRODUCT, MATRIX, PROFILE, VECTOR */
8682
8683 /*     INPUT ARGUMENTS : */
8684 /*     -------------------- */
8685 /*       NLIGNE : NUMBER OF LINE OF THE MATRIX */
8686 /*       NCOLON : NOMBER OF COLUMN OF THE MATRIX */
8687 /*       GPOSIT: TABLE OF POSITIONING OF TERMS OF STORAGE */
8688 /*               GPOSIT(1,I) CONTAINS THE NUMBER of TERMS-1 ON LINE */
8689 /*               I IN THE PROFILE OF THE MATRIX */
8690 /*              GPOSIT(2,I) CONTAINS THE INDEX OF STORAGE OF THE DIAGONAL TERM*/
8691 /*               OF LINE I */
8692 /*               GPOSIT(3,I) CONTAINS THE INDEX COLUMN OF THE FIRST TERM OF */
8693 /*                           PROFILE OF LINE I */
8694 /*       GNSTOC : NOMBER OF TERM IN THE PROFILE OF GMATRI */
8695 /*       GMATRI : MATRIX OF CONSTRAINTS IN FORM OF PROFILE */
8696 /*       VECIN :  INPUT VECTOR */
8697
8698 /*     OUTPUT ARGUMENTS : */
8699 /*     --------------------- */
8700 /*       VECOUT : VECTOR PRODUCT */
8701 /*       IERCOD : ERROR CODE */
8702
8703
8704 /*     COMMONS USED : */
8705 /*     ------------------ */
8706
8707
8708 /*     REFERENCES CALLED : */
8709 /*     --------------------- */
8710
8711
8712 /*     DESCRIPTION/NOTES/LIMITATIONS : */
8713 /*     ----------------------------------- */
8714 /* > */
8715 /* ***********************************************************************
8716  */
8717 /*                            DECLARATIONS */
8718 /* ***********************************************************************
8719  */
8720
8721
8722
8723 /* ***********************************************************************
8724  */
8725 /*                      INITIALISATIONS */
8726 /* ***********************************************************************
8727  */
8728
8729     /* Parameter adjustments */
8730     --vecin;
8731     gposit -= 4;
8732     --vecout;
8733     --gmatri;
8734
8735     /* Function Body */
8736     ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 2;
8737     if (ldbg) {
8738         AdvApp2Var_SysBase::mgenmsg_("MMTMAVE", 7L);
8739     }
8740     *iercod = 0;
8741
8742 /* ***********************************************************************
8743  */
8744 /*                     PROCESSING */
8745 /* ***********************************************************************
8746  */
8747
8748
8749
8750     i__1 = *ncolon;
8751     for (i__ = 1; i__ <= i__1; ++i__) {
8752         somme = 0.;
8753         i__2 = *nligne;
8754         for (j = 1; j <= i__2; ++j) {
8755             imin = gposit[j * 3 + 3];
8756             imax = gposit[j * 3 + 1] + gposit[j * 3 + 3] - 1;
8757             aux = gposit[j * 3 + 2] - gposit[j * 3 + 1] - imin + 1;
8758             if (imin <= i__ && i__ <= imax) {
8759                 k = i__ + aux;
8760                 somme += gmatri[k] * vecin[j];
8761             }
8762         }
8763         vecout[i__] = somme;
8764     }
8765
8766
8767
8768
8769
8770     goto L9999;
8771
8772 /* ***********************************************************************
8773  */
8774 /*                   ERROR PROCESSING */
8775 /* ***********************************************************************
8776  */
8777
8778
8779 /* ***********************************************************************
8780  */
8781 /*                   RETURN CALLING PROGRAM */
8782 /* ***********************************************************************
8783  */
8784
8785 L9999:
8786
8787 /* ___ DESALLOCATION, ... */
8788
8789     AdvApp2Var_SysBase::maermsg_("MMTMAVE", iercod, 7L);
8790     if (ldbg) {
8791         AdvApp2Var_SysBase::mgsomsg_("MMTMAVE", 7L);
8792     }
8793  return 0 ;
8794 } /* mmtmave_ */
8795
8796 //=======================================================================
8797 //function : mmtrpj0_
8798 //purpose  :
8799 //=======================================================================
8800 int mmtrpj0_(integer *ncofmx,
8801              integer *ndimen,
8802              integer *ncoeff,
8803              doublereal *epsi3d,
8804              doublereal *crvlgd,
8805              doublereal *ycvmax,
8806              doublereal *epstrc,
8807              integer *ncfnew)
8808
8809 {
8810   /* System generated locals */
8811   integer crvlgd_dim1, crvlgd_offset, i__1, i__2;
8812   doublereal d__1;
8813
8814   /* Local variables */
8815   integer ncut, i__;
8816   doublereal bidon, error;
8817   integer nd;
8818
8819
8820 /* ***********************************************************************
8821  */
8822
8823 /*     FUNCTION : */
8824 /*     ---------- */
8825 /*        Lowers the degree of a curve defined on (-1,1) in the direction of */
8826 /*        Legendre with a given precision. */
8827
8828 /*     KEYWORDS : */
8829 /*     ----------- */
8830 /*        LEGENDRE, POLYGON, TRUNCATION, CURVE, SMOOTHING. */
8831
8832 /*     INPUT ARGUMENTS : */
8833 /*     ------------------ */
8834 /*        NCOFMX : Max Nb of coeff. of the curve (dimensioning). */
8835 /*        NDIMEN : Dimension of the space. */
8836 /*        NCOEFF : Degree +1 of the polynom. */
8837 /*        EPSI3D : Precision required for the approximation. */
8838 /*        CRVLGD : The curve the degree which of it is required to lower. */
8839
8840 /*     OUTPUT ARGUMENTS : */
8841 /*     ------------------- */
8842 /*        EPSTRC : Precision of the approximation. */
8843 /*        NCFNEW : Degree +1 of the resulting polynom. */
8844
8845 /*     COMMONS USED   : */
8846 /*     ---------------- */
8847
8848 /*     REFERENCES CALLED   : */
8849 /*     ----------------------- */
8850
8851 /*     DESCRIPTION/NOTES/LIMITATIONS : */
8852 /*     ----------------------------------- */
8853 /* > */
8854 /* ***********************************************************************
8855  */
8856
8857
8858 /* ------- Minimum degree that can be attained : Stop at 1 (RBD) ---------
8859 */
8860
8861     /* Parameter adjustments */
8862     --ycvmax;
8863     crvlgd_dim1 = *ncofmx;
8864     crvlgd_offset = crvlgd_dim1 + 1;
8865     crvlgd -= crvlgd_offset;
8866
8867     /* Function Body */
8868     *ncfnew = 1;
8869 /* ------------------- Init for error calculation -----------------------
8870 */
8871     i__1 = *ndimen;
8872     for (i__ = 1; i__ <= i__1; ++i__) {
8873         ycvmax[i__] = 0.;
8874 /* L100: */
8875     }
8876     *epstrc = 0.;
8877     error = 0.;
8878
8879 /*   Cutting of coefficients. */
8880
8881     ncut = 2;
8882 /* ------ Loop on the series of Legendre :NCOEFF --> 2 (RBD) -----------
8883 */
8884     i__1 = ncut;
8885     for (i__ = *ncoeff; i__ >= i__1; --i__) {
8886 /*   Factor of renormalization. */
8887         bidon = ((i__ - 1) * 2. + 1.) / 2.;
8888         bidon = sqrt(bidon);
8889         i__2 = *ndimen;
8890         for (nd = 1; nd <= i__2; ++nd) {
8891             ycvmax[nd] += (d__1 = crvlgd[i__ + nd * crvlgd_dim1], advapp_abs(d__1)) *
8892                      bidon;
8893 /* L310: */
8894         }
8895 /*   Cutting is stopped if the norm becomes too great. */
8896         error = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
8897         if (error > *epsi3d) {
8898             *ncfnew = i__;
8899             goto L9999;
8900         }
8901
8902 /* ---  Max error cumulee when the I-th coeff is removed. */
8903
8904         *epstrc = error;
8905
8906 /* L300: */
8907     }
8908
8909 /* --------------------------------- End --------------------------------
8910 */
8911
8912 L9999:
8913     return 0;
8914 } /* mmtrpj0_ */
8915
8916 //=======================================================================
8917 //function : mmtrpj2_
8918 //purpose  :
8919 //=======================================================================
8920 int mmtrpj2_(integer *ncofmx,
8921              integer *ndimen,
8922              integer *ncoeff,
8923              doublereal *epsi3d,
8924              doublereal *crvlgd,
8925              doublereal *ycvmax,
8926              doublereal *epstrc,
8927              integer *ncfnew)
8928
8929 {
8930     /* Initialized data */
8931
8932     static doublereal xmaxj[57] = { .9682458365518542212948163499456,
8933             .986013297183269340427888048593603,
8934             1.07810420343739860362585159028115,
8935             1.17325804490920057010925920756025,
8936             1.26476561266905634732910520370741,
8937             1.35169950227289626684434056681946,
8938             1.43424378958284137759129885012494,
8939             1.51281316274895465689402798226634,
8940             1.5878364329591908800533936587012,
8941             1.65970112228228167018443636171226,
8942             1.72874345388622461848433443013543,
8943             1.7952515611463877544077632304216,
8944             1.85947199025328260370244491818047,
8945             1.92161634324190018916351663207101,
8946             1.98186713586472025397859895825157,
8947             2.04038269834980146276967984252188,
8948             2.09730119173852573441223706382076,
8949             2.15274387655763462685970799663412,
8950             2.20681777186342079455059961912859,
8951             2.25961782459354604684402726624239,
8952             2.31122868752403808176824020121524,
8953             2.36172618435386566570998793688131,
8954             2.41117852396114589446497298177554,
8955             2.45964731268663657873849811095449,
8956             2.50718840313973523778244737914028,
8957             2.55385260994795361951813645784034,
8958             2.59968631659221867834697883938297,
8959             2.64473199258285846332860663371298,
8960             2.68902863641518586789566216064557,
8961             2.73261215675199397407027673053895,
8962             2.77551570192374483822124304745691,
8963             2.8177699459714315371037628127545,
8964             2.85940333797200948896046563785957,
8965             2.90044232019793636101516293333324,
8966             2.94091151970640874812265419871976,
8967             2.98083391718088702956696303389061,
8968             3.02023099621926980436221568258656,
8969             3.05912287574998661724731962377847,
8970             3.09752842783622025614245706196447,
8971             3.13546538278134559341444834866301,
8972             3.17295042316122606504398054547289,
8973             3.2099992681699613513775259670214,
8974             3.24662674946606137764916854570219,
8975             3.28284687953866689817670991319787,
8976             3.31867291347259485044591136879087,
8977             3.35411740487202127264475726990106,
8978             3.38919225660177218727305224515862,
8979             3.42390876691942143189170489271753,
8980             3.45827767149820230182596660024454,
8981             3.49230918177808483937957161007792,
8982             3.5260130200285724149540352829756,
8983             3.55939845146044235497103883695448,
8984             3.59247431368364585025958062194665,
8985             3.62524904377393592090180712976368,
8986             3.65773070318071087226169680450936,
8987             3.68992700068237648299565823810245,
8988             3.72184531357268220291630708234186 };
8989
8990     /* System generated locals */
8991     integer crvlgd_dim1, crvlgd_offset, i__1, i__2;
8992     doublereal d__1;
8993
8994     /* Local variables */
8995     integer ncut, i__;
8996     doublereal bidon, error;
8997     integer ia, nd;
8998     doublereal bid, eps1;
8999
9000
9001 /* ***********************************************************************
9002  */
9003
9004 /*     FUNCTION : */
9005 /*     ---------- */
9006 /*        Lower the degree of a curve defined on (-1,1) in the direction of */
9007 /*        Legendre with a given precision. */
9008
9009 /*     KEYWORDS : */
9010 /*     ----------- */
9011 /*        LEGENDRE, POLYGON, TRUNCATION, CURVE, SMOOTHING. */
9012
9013 /*     INPUT ARGUMENTS : */
9014 /*     ------------------ */
9015 /*        NCOFMX : Max nb of coeff. of the curve (dimensioning). */
9016 /*        NDIMEN : Dimension of the space. */
9017 /*        NCOEFF : Degree +1 of the polynom. */
9018 /*        EPSI3D : Precision required for the approximation. */
9019 /*        CRVLGD : The curve the degree which of will be lowered. */
9020
9021 /*     OUTPUT ARGUMENTS : */
9022 /*     ------------------- */
9023 /*        YCVMAX : Auxiliary table (error max on each dimension).
9024 */
9025 /*        EPSTRC : Precision of the approximation. */
9026 /*        NCFNEW : Degree +1 of the resulting polynom. */
9027
9028 /*     COMMONS USED   : */
9029 /*     ---------------- */
9030
9031 /*     REFERENCES CALLED   : */
9032 /*     ----------------------- */
9033
9034 /*     DESCRIPTION/NOTES/LIMITATIONS : */
9035 /*     ----------------------------------- */
9036 /* > */
9037 /* ***********************************************************************
9038  */
9039
9040
9041     /* Parameter adjustments */
9042     --ycvmax;
9043     crvlgd_dim1 = *ncofmx;
9044     crvlgd_offset = crvlgd_dim1 + 1;
9045     crvlgd -= crvlgd_offset;
9046
9047     /* Function Body */
9048
9049
9050
9051 /*   Minimum degree that can be reached : Stop at IA (RBD). -------------
9052 */
9053     ia = 2;
9054     *ncfnew = ia;
9055 /* Init for calculation of error. */
9056     i__1 = *ndimen;
9057     for (i__ = 1; i__ <= i__1; ++i__) {
9058         ycvmax[i__] = 0.;
9059 /* L100: */
9060     }
9061     *epstrc = 0.;
9062     error = 0.;
9063
9064 /*   Cutting of coefficients. */
9065
9066     ncut = ia + 1;
9067 /* ------ Loop on the series of Jacobi :NCOEFF --> IA+1 (RBD) ----------
9068 */
9069     i__1 = ncut;
9070     for (i__ = *ncoeff; i__ >= i__1; --i__) {
9071 /*   Factor of renormalization. */
9072         bidon = xmaxj[i__ - ncut];
9073         i__2 = *ndimen;
9074         for (nd = 1; nd <= i__2; ++nd) {
9075             ycvmax[nd] += (d__1 = crvlgd[i__ + nd * crvlgd_dim1], advapp_abs(d__1)) *
9076                      bidon;
9077 /* L310: */
9078         }
9079 /*   One stops to cut if the norm becomes too great. */
9080         error = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
9081         if (error > *epsi3d) {
9082             *ncfnew = i__;
9083             goto L400;
9084         }
9085
9086 /* --- Max error cumulated when the I-th coeff is removed. */
9087
9088         *epstrc = error;
9089
9090 /* L300: */
9091     }
9092
9093 /* ------- Cutting of zero coeffs of interpolation (RBD) -------
9094 */
9095
9096 L400:
9097     if (*ncfnew == ia) {
9098         AdvApp2Var_MathBase::mmeps1_(&eps1);
9099         for (i__ = ia; i__ >= 2; --i__) {
9100             bid = 0.;
9101             i__1 = *ndimen;
9102             for (nd = 1; nd <= i__1; ++nd) {
9103                 bid += (d__1 = crvlgd[i__ + nd * crvlgd_dim1], advapp_abs(d__1));
9104 /* L600: */
9105             }
9106             if (bid > eps1) {
9107                 *ncfnew = i__;
9108                 goto L9999;
9109             }
9110 /* L500: */
9111         }
9112 /* --- If all coeffs can be removed, this is a point. */
9113         *ncfnew = 1;
9114     }
9115
9116 /* --------------------------------- End --------------------------------
9117 */
9118
9119 L9999:
9120     return 0;
9121 } /* mmtrpj2_ */
9122
9123 //=======================================================================
9124 //function : mmtrpj4_
9125 //purpose  :
9126 //=======================================================================
9127 int mmtrpj4_(integer *ncofmx,
9128              integer *ndimen,
9129              integer *ncoeff,
9130              doublereal *epsi3d,
9131              doublereal *crvlgd,
9132              doublereal *ycvmax,
9133              doublereal *epstrc,
9134              integer *ncfnew)
9135 {
9136     /* Initialized data */
9137
9138     static doublereal xmaxj[55] = { 1.1092649593311780079813740546678,
9139             1.05299572648705464724876659688996,
9140             1.0949715351434178709281698645813,
9141             1.15078388379719068145021100764647,
9142             1.2094863084718701596278219811869,
9143             1.26806623151369531323304177532868,
9144             1.32549784426476978866302826176202,
9145             1.38142537365039019558329304432581,
9146             1.43575531950773585146867625840552,
9147             1.48850442653629641402403231015299,
9148             1.53973611681876234549146350844736,
9149             1.58953193485272191557448229046492,
9150             1.63797820416306624705258190017418,
9151             1.68515974143594899185621942934906,
9152             1.73115699602477936547107755854868,
9153             1.77604489805513552087086912113251,
9154             1.81989256661534438347398400420601,
9155             1.86276344480103110090865609776681,
9156             1.90471563564740808542244678597105,
9157             1.94580231994751044968731427898046,
9158             1.98607219357764450634552790950067,
9159             2.02556989246317857340333585562678,
9160             2.06433638992049685189059517340452,
9161             2.10240936014742726236706004607473,
9162             2.13982350649113222745523925190532,
9163             2.17661085564771614285379929798896,
9164             2.21280102016879766322589373557048,
9165             2.2484214321456956597803794333791,
9166             2.28349755104077956674135810027654,
9167             2.31805304852593774867640120860446,
9168             2.35210997297725685169643559615022,
9169             2.38568889602346315560143377261814,
9170             2.41880904328694215730192284109322,
9171             2.45148841120796359750021227795539,
9172             2.48374387161372199992570528025315,
9173             2.5155912654873773953959098501893,
9174             2.54704548720896557684101746505398,
9175             2.57812056037881628390134077704127,
9176             2.60882970619319538196517982945269,
9177             2.63918540521920497868347679257107,
9178             2.66919945330942891495458446613851,
9179             2.69888301230439621709803756505788,
9180             2.72824665609081486737132853370048,
9181             2.75730041251405791603760003778285,
9182             2.78605380158311346185098508516203,
9183             2.81451587035387403267676338931454,
9184             2.84269522483114290814009184272637,
9185             2.87060005919012917988363332454033,
9186             2.89823818258367657739520912946934,
9187             2.92561704377132528239806135133273,
9188             2.95274375377994262301217318010209,
9189             2.97962510678256471794289060402033,
9190             3.00626759936182712291041810228171,
9191             3.03267744830655121818899164295959,
9192             3.05886060707437081434964933864149 };
9193
9194     /* System generated locals */
9195     integer crvlgd_dim1, crvlgd_offset, i__1, i__2;
9196     doublereal d__1;
9197
9198     /* Local variables */
9199     integer ncut, i__;
9200     doublereal bidon, error;
9201     integer ia, nd;
9202     doublereal bid, eps1;
9203
9204
9205
9206 /* ***********************************************************************
9207  */
9208
9209 /*     FUNCTION : */
9210 /*     ---------- */
9211 /*        Lowers the degree of a curve defined on (-1,1) in the direction of */
9212 /*        Legendre with a given precision. */
9213
9214 /*     KEYWORDS : */
9215 /*     ----------- */
9216 /*        LEGENDRE, POLYGON, TRONCATION, CURVE, SMOOTHING. */
9217
9218 /*     INPUT ARGUMENTS : */
9219 /*     ------------------ */
9220 /*        NCOFMX : Max nb of coeff. of the curve (dimensioning). */
9221 /*        NDIMEN : Dimension of the space. */
9222 /*        NCOEFF : Degree +1 of the polynom. */
9223 /*        EPSI3D : Precision required for the approximation. */
9224 /*        CRVLGD : The curve which wishes to lower the degree. */
9225
9226 /*     OUTPUT ARGUMENTS : */
9227 /*     ------------------- */
9228 /*        YCVMAX : Auxiliary table (max error on each dimension).
9229 */
9230 /*        EPSTRC : Precision of the approximation. */
9231 /*        NCFNEW : Degree +1 of the resulting polynom. */
9232
9233 /*     COMMONS USED   : */
9234 /*     ---------------- */
9235
9236 /*     REFERENCES CALLED   : */
9237 /*     ----------------------- */
9238
9239 /*     DESCRIPTION/NOTES/LIMITATIONS : */
9240 /*     ----------------------------------- */
9241 /* > */
9242 /* ***********************************************************************
9243  */
9244
9245
9246     /* Parameter adjustments */
9247     --ycvmax;
9248     crvlgd_dim1 = *ncofmx;
9249     crvlgd_offset = crvlgd_dim1 + 1;
9250     crvlgd -= crvlgd_offset;
9251
9252     /* Function Body */
9253
9254
9255
9256 /*   Minimum degree that can be reached : Stop at IA (RBD). -------------
9257 */
9258     ia = 4;
9259     *ncfnew = ia;
9260 /* Init for error calculation. */
9261     i__1 = *ndimen;
9262     for (i__ = 1; i__ <= i__1; ++i__) {
9263         ycvmax[i__] = 0.;
9264 /* L100: */
9265     }
9266     *epstrc = 0.;
9267     error = 0.;
9268
9269 /*   Cutting of coefficients. */
9270
9271     ncut = ia + 1;
9272 /* ------ Loop on the series of Jacobi :NCOEFF --> IA+1 (RBD) ----------
9273 */
9274     i__1 = ncut;
9275     for (i__ = *ncoeff; i__ >= i__1; --i__) {
9276 /*   Factor of renormalization. */
9277         bidon = xmaxj[i__ - ncut];
9278         i__2 = *ndimen;
9279         for (nd = 1; nd <= i__2; ++nd) {
9280             ycvmax[nd] += (d__1 = crvlgd[i__ + nd * crvlgd_dim1], advapp_abs(d__1)) *
9281                      bidon;
9282 /* L310: */
9283         }
9284 /*   Stop cutting if the norm becomes too great. */
9285         error = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
9286         if (error > *epsi3d) {
9287             *ncfnew = i__;
9288             goto L400;
9289         }
9290
9291 /* -- Error max cumulated when the I-eme coeff is removed. */
9292
9293         *epstrc = error;
9294
9295 /* L300: */
9296     }
9297
9298 /* ------- Cutting of zero coeffs of the pole of interpolation (RBD) -------
9299 */
9300
9301 L400:
9302     if (*ncfnew == ia) {
9303         AdvApp2Var_MathBase::mmeps1_(&eps1);
9304         for (i__ = ia; i__ >= 2; --i__) {
9305             bid = 0.;
9306             i__1 = *ndimen;
9307             for (nd = 1; nd <= i__1; ++nd) {
9308                 bid += (d__1 = crvlgd[i__ + nd * crvlgd_dim1], advapp_abs(d__1));
9309 /* L600: */
9310             }
9311             if (bid > eps1) {
9312                 *ncfnew = i__;
9313                 goto L9999;
9314             }
9315 /* L500: */
9316         }
9317 /* --- If all coeffs can be removed, this is a point. */
9318         *ncfnew = 1;
9319     }
9320
9321 /* --------------------------------- End --------------------------------
9322 */
9323
9324 L9999:
9325     return 0;
9326 } /* mmtrpj4_ */
9327
9328 //=======================================================================
9329 //function : mmtrpj6_
9330 //purpose  :
9331 //=======================================================================
9332 int mmtrpj6_(integer *ncofmx,
9333              integer *ndimen,
9334              integer *ncoeff,
9335              doublereal *epsi3d,
9336              doublereal *crvlgd,
9337              doublereal *ycvmax,
9338              doublereal *epstrc,
9339              integer *ncfnew)
9340
9341 {
9342     /* Initialized data */
9343
9344     static doublereal xmaxj[53] = { 1.21091229812484768570102219548814,
9345             1.11626917091567929907256116528817,
9346             1.1327140810290884106278510474203,
9347             1.1679452722668028753522098022171,
9348             1.20910611986279066645602153641334,
9349             1.25228283758701572089625983127043,
9350             1.29591971597287895911380446311508,
9351             1.3393138157481884258308028584917,
9352             1.3821288728999671920677617491385,
9353             1.42420414683357356104823573391816,
9354             1.46546895108549501306970087318319,
9355             1.50590085198398789708599726315869,
9356             1.54550385142820987194251585145013,
9357             1.58429644271680300005206185490937,
9358             1.62230484071440103826322971668038,
9359             1.65955905239130512405565733793667,
9360             1.69609056468292429853775667485212,
9361             1.73193098017228915881592458573809,
9362             1.7671112206990325429863426635397,
9363             1.80166107681586964987277458875667,
9364             1.83560897003644959204940535551721,
9365             1.86898184653271388435058371983316,
9366             1.90180515174518670797686768515502,
9367             1.93410285411785808749237200054739,
9368             1.96589749778987993293150856865539,
9369             1.99721027139062501070081653790635,
9370             2.02806108474738744005306947877164,
9371             2.05846864831762572089033752595401,
9372             2.08845055210580131460156962214748,
9373             2.11802334209486194329576724042253,
9374             2.14720259305166593214642386780469,
9375             2.17600297710595096918495785742803,
9376             2.20443832785205516555772788192013,
9377             2.2325216999457379530416998244706,
9378             2.2602654243075083168599953074345,
9379             2.28768115912702794202525264301585,
9380             2.3147799369092684021274946755348,
9381             2.34157220782483457076721300512406,
9382             2.36806787963276257263034969490066,
9383             2.39427635443992520016789041085844,
9384             2.42020656255081863955040620243062,
9385             2.44586699364757383088888037359254,
9386             2.47126572552427660024678584642791,
9387             2.49641045058324178349347438430311,
9388             2.52130850028451113942299097584818,
9389             2.54596686772399937214920135190177,
9390             2.5703922285006754089328998222275,
9391             2.59459096001908861492582631591134,
9392             2.61856915936049852435394597597773,
9393             2.64233265984385295286445444361827,
9394             2.66588704638685848486056711408168,
9395             2.68923766976735295746679957665724,
9396             2.71238965987606292679677228666411 };
9397
9398     /* System generated locals */
9399     integer crvlgd_dim1, crvlgd_offset, i__1, i__2;
9400     doublereal d__1;
9401
9402     /* Local variables */
9403     integer ncut, i__;
9404     doublereal bidon, error;
9405     integer ia, nd;
9406     doublereal bid, eps1;
9407
9408
9409
9410 /* ***********************************************************************
9411  */
9412
9413 /*     FUNCTION : */
9414 /*     ---------- */
9415 /*        Lowers the degree of a curve defined on (-1,1) in the direction of */
9416 /*        Legendre to a given precision. */
9417
9418 /*     KEYWORDS : */
9419 /*     ----------- */
9420 /*        LEGENDRE,POLYGON,TRUNCATION,CURVE,SMOOTHING. */
9421
9422 /*     INPUT ARGUMENTS : */
9423 /*     ------------------ */
9424 /*        NCOFMX : Max nb of coeff. of the curve (dimensioning). */
9425 /*        NDIMEN : Dimension of the space. */
9426 /*        NCOEFF : Degree +1 of the polynom. */
9427 /*        EPSI3D : Precision required for the approximation. */
9428 /*        CRVLGD : The curve the degree which of will be lowered. */
9429
9430 /*     OUTPUT ARGUMENTS : */
9431 /*     ------------------- */
9432 /*        YCVMAX : Auxiliary table (max error on each dimension). */
9433 /*        EPSTRC : Precision of the approximation. */
9434 /*        NCFNEW : Degree +1 of the resulting polynom. */
9435
9436 /*     COMMONS USED   : */
9437 /*     ---------------- */
9438
9439 /*     REFERENCES CALLED   : */
9440 /*     ----------------------- */
9441
9442 /*     DESCRIPTION/NOTES/LIMITATIONS : */
9443 /*     ----------------------------------- */
9444 /* > */
9445 /* ***********************************************************************
9446  */
9447
9448
9449     /* Parameter adjustments */
9450     --ycvmax;
9451     crvlgd_dim1 = *ncofmx;
9452     crvlgd_offset = crvlgd_dim1 + 1;
9453     crvlgd -= crvlgd_offset;
9454
9455     /* Function Body */
9456
9457
9458
9459 /*   Minimum degree that can be reached : Stop at IA (RBD). -------------
9460 */
9461     ia = 6;
9462     *ncfnew = ia;
9463 /* Init for error calculation. */
9464     i__1 = *ndimen;
9465     for (i__ = 1; i__ <= i__1; ++i__) {
9466         ycvmax[i__] = 0.;
9467 /* L100: */
9468     }
9469     *epstrc = 0.;
9470     error = 0.;
9471
9472 /*   Cutting of coefficients. */
9473
9474     ncut = ia + 1;
9475 /* ------ Loop on the series of Jacobi :NCOEFF --> IA+1 (RBD) ----------
9476 */
9477     i__1 = ncut;
9478     for (i__ = *ncoeff; i__ >= i__1; --i__) {
9479 /*   Factor of renormalization. */
9480         bidon = xmaxj[i__ - ncut];
9481         i__2 = *ndimen;
9482         for (nd = 1; nd <= i__2; ++nd) {
9483             ycvmax[nd] += (d__1 = crvlgd[i__ + nd * crvlgd_dim1], advapp_abs(d__1)) *
9484                      bidon;
9485 /* L310: */
9486         }
9487 /*   Stop cutting if the norm becomes too great. */
9488         error = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
9489         if (error > *epsi3d) {
9490             *ncfnew = i__;
9491             goto L400;
9492         }
9493
9494 /* --- Max error cumulated when the I-th coeff is removed. */
9495
9496         *epstrc = error;
9497
9498 /* L300: */
9499     }
9500
9501 /* ------- Cutting of zero coeff. of the pole of interpolation (RBD) -------
9502 */
9503
9504 L400:
9505     if (*ncfnew == ia) {
9506         AdvApp2Var_MathBase::mmeps1_(&eps1);
9507         for (i__ = ia; i__ >= 2; --i__) {
9508             bid = 0.;
9509             i__1 = *ndimen;
9510             for (nd = 1; nd <= i__1; ++nd) {
9511                 bid += (d__1 = crvlgd[i__ + nd * crvlgd_dim1], advapp_abs(d__1));
9512 /* L600: */
9513             }
9514             if (bid > eps1) {
9515                 *ncfnew = i__;
9516                 goto L9999;
9517             }
9518 /* L500: */
9519         }
9520 /* --- If all coeffs can be removed, this is a point. */
9521         *ncfnew = 1;
9522     }
9523
9524 /* --------------------------------- End --------------------------------
9525 */
9526
9527 L9999:
9528     return 0;
9529 } /* mmtrpj6_ */
9530
9531 //=======================================================================
9532 //function : AdvApp2Var_MathBase::mmtrpjj_
9533 //purpose  :
9534 //=======================================================================
9535  int AdvApp2Var_MathBase::mmtrpjj_(integer *ncofmx,
9536                             integer *ndimen,
9537                             integer *ncoeff,
9538                             doublereal *epsi3d,
9539                             integer *iordre,
9540                             doublereal *crvlgd,
9541                             doublereal *ycvmax,
9542                             doublereal *errmax,
9543                             integer *ncfnew)
9544 {
9545     /* System generated locals */
9546     integer crvlgd_dim1, crvlgd_offset;
9547
9548     /* Local variables */
9549     integer ia;
9550
9551
9552 /* ***********************************************************************
9553  */
9554
9555 /*     FUNCTION : */
9556 /*     ---------- */
9557 /*        Lower the degree of a curve defined on (-1,1) in the direction of */
9558 /*        Legendre with a given precision. */
9559
9560 /*     KEYWORDS : */
9561 /*     ----------- */
9562 /*        LEGENDRE, POLYGON, TRUNCATION, CURVE, SMOOTHING. */
9563
9564 /*     INPUT ARGUMENTS : */
9565 /*     ------------------ */
9566 /*        NCOFMX : Max Nb coeff. of the curve (dimensioning). */
9567 /*        NDIMEN : Dimension of the space. */
9568 /*        NCOEFF : Degree +1 of the polynom. */
9569 /*        EPSI3D : Precision required for the approximation. */
9570 /*        IORDRE : Order of continuity at the extremities. */
9571 /*        CRVLGD : The curve the degree which of should be lowered. */
9572
9573 /*     OUTPUT ARGUMENTS : */
9574 /*     ------------------- */
9575 /*        ERRMAX : Precision of the approximation. */
9576 /*        NCFNEW : Degree +1 of the resulting polynom. */
9577
9578 /*     COMMONS USED   : */
9579 /*     ---------------- */
9580
9581 /*     REFERENCES CALLED : */
9582 /*     ----------------------- */
9583
9584 /*     DESCRIPTION/NOTES/LIMITATIONS : */
9585 /*     ----------------------------------- */
9586 /* > */
9587 /* ***********************************************************************
9588  */
9589
9590
9591     /* Parameter adjustments */
9592     --ycvmax;
9593     crvlgd_dim1 = *ncofmx;
9594     crvlgd_offset = crvlgd_dim1 + 1;
9595     crvlgd -= crvlgd_offset;
9596
9597     /* Function Body */
9598     ia = (*iordre + 1) << 1;
9599
9600     if (ia == 0) {
9601         mmtrpj0_(ncofmx, ndimen, ncoeff, epsi3d, &crvlgd[crvlgd_offset], &
9602                 ycvmax[1], errmax, ncfnew);
9603     } else if (ia == 2) {
9604         mmtrpj2_(ncofmx, ndimen, ncoeff, epsi3d, &crvlgd[crvlgd_offset], &
9605                 ycvmax[1], errmax, ncfnew);
9606     } else if (ia == 4) {
9607         mmtrpj4_(ncofmx, ndimen, ncoeff, epsi3d, &crvlgd[crvlgd_offset], &
9608                 ycvmax[1], errmax, ncfnew);
9609     } else {
9610         mmtrpj6_(ncofmx, ndimen, ncoeff, epsi3d, &crvlgd[crvlgd_offset], &
9611                 ycvmax[1], errmax, ncfnew);
9612     }
9613
9614 /* ------------------------ End -----------------------------------------
9615 */
9616
9617     return 0;
9618 } /* mmtrpjj_ */
9619
9620 //=======================================================================
9621 //function : AdvApp2Var_MathBase::mmunivt_
9622 //purpose  :
9623 //=======================================================================
9624  int AdvApp2Var_MathBase::mmunivt_(integer *ndimen,
9625              doublereal *vector,
9626              doublereal *vecnrm,
9627              doublereal *epsiln,
9628              integer *iercod)
9629 {
9630
9631   doublereal c_b2 = 10.;
9632
9633     /* System generated locals */
9634     integer i__1;
9635     doublereal d__1;
9636
9637     /* Local variables */
9638     integer nchif, iunit = 1, izero;
9639     doublereal vnorm;
9640     integer ii;
9641     doublereal bid;
9642     doublereal eps0;
9643
9644
9645
9646
9647 /* ***********************************************************************
9648  */
9649
9650 /*     FUNCTION : */
9651 /*     ---------- */
9652 /*        CALCULATE THE NORMAL VECTOR BASING ON ANY VECTOR */
9653 /*        WITH PRECISION GIVEN BY THE USER. */
9654
9655 /*     KEYWORDS : */
9656 /*     ----------- */
9657 /*        ALL, MATH_ACCES :: */
9658 /*        VECTEUR&, NORMALISATION, &VECTEUR */
9659
9660 /*     INPUT ARGUMENTS : */
9661 /*     ------------------ */
9662 /*        NDIMEN   : DIMENSION OF THE SPACE */
9663 /*        VECTOR   : VECTOR TO BE NORMED */
9664 /*        EPSILN   : EPSILON BELOW WHICH IT IS CONSIDERED THAT THE */
9665 /*                 NORM OF THE VECTOR IS NULL. IF EPSILN<=0, A DEFAULT VALUE */
9666 /*                 IS IMPOSED (10.D-17 ON VAX). */
9667
9668 /*     OUTPUT ARGUMENTS : */
9669 /*     ------------------- */
9670 /*        VECNRM : NORMED VECTOR */
9671 /*        IERCOD  101 : THE VECTOR IS NULL UP TO EPSILN. */
9672 /*                  0 : OK. */
9673
9674 /*     COMMONS USED   : */
9675 /*     ---------------- */
9676
9677 /*     REFERENCES CALLED   : */
9678 /*     ----------------------- */
9679
9680 /*     DESCRIPTION/NOTES/LIMITATIONS : */
9681 /*     ----------------------------------- */
9682 /*     VECTOR and VECNRM can be identic. */
9683
9684 /*     The norm of vector is calculated and each component is divided by */
9685 /*     this norm. After this it is checked if all componentes of the */
9686 /*     vector except for one cost 0 with machine precision. In */
9687 /*     this case the quasi-null components are set to 0.D0. */
9688 /* > */
9689 /* ***********************************************************************
9690  */
9691
9692
9693     /* Parameter adjustments */
9694     --vecnrm;
9695     --vector;
9696
9697     /* Function Body */
9698     *iercod = 0;
9699
9700 /* -------- Precision by default : zero machine 10.D-17 on Vax ------
9701 */
9702
9703     AdvApp2Var_SysBase::maovsr8_(&nchif);
9704     if (*epsiln <= 0.) {
9705         i__1 = -nchif;
9706         eps0 = AdvApp2Var_MathBase::pow__di(&c_b2, &i__1);
9707     } else {
9708         eps0 = *epsiln;
9709     }
9710
9711 /* ------------------------- Calculation of the norm --------------------
9712 */
9713
9714     vnorm = AdvApp2Var_MathBase::mzsnorm_(ndimen, &vector[1]);
9715     if (vnorm <= eps0) {
9716         AdvApp2Var_SysBase::mvriraz_(ndimen, &vecnrm[1]);
9717         *iercod = 101;
9718         goto L9999;
9719     }
9720
9721 /* ---------------------- Calculation of the vector norm  ---------------
9722 */
9723
9724     izero = 0;
9725     i__1 = (-nchif - 1) / 2;
9726     eps0 = AdvApp2Var_MathBase::pow__di(&c_b2, &i__1);
9727     i__1 = *ndimen;
9728     for (ii = 1; ii <= i__1; ++ii) {
9729         vecnrm[ii] = vector[ii] / vnorm;
9730         if ((d__1 = vecnrm[ii], advapp_abs(d__1)) <= eps0) {
9731             ++izero;
9732         } else {
9733             iunit = ii;
9734         }
9735 /* L20: */
9736     }
9737
9738 /* ------ Case when all coordinates except for one are almost null ----
9739 */
9740 /* ------------- then one of coordinates costs 1.D0 or -1.D0 --------
9741 */
9742
9743     if (izero == *ndimen - 1) {
9744         bid = vecnrm[iunit];
9745         i__1 = *ndimen;
9746         for (ii = 1; ii <= i__1; ++ii) {
9747             vecnrm[ii] = 0.;
9748 /* L30: */
9749         }
9750         if (bid > 0.) {
9751             vecnrm[iunit] = 1.;
9752         } else {
9753             vecnrm[iunit] = -1.;
9754         }
9755     }
9756
9757 /* -------------------------------- The end -----------------------------
9758 */
9759
9760 L9999:
9761     return 0;
9762 } /* mmunivt_ */
9763
9764 //=======================================================================
9765 //function : AdvApp2Var_MathBase::mmveps3_
9766 //purpose  :
9767 //=======================================================================
9768  int AdvApp2Var_MathBase::mmveps3_(doublereal *eps03)
9769 {
9770   /* Initialized data */
9771
9772   static char nomprg[8+1] = "MMEPS1  ";
9773
9774   integer ibb;
9775
9776
9777
9778 /************************************************************************
9779 *******/
9780
9781 /*     FUNCTION : */
9782 /*     ---------- */
9783 /*        Extraction of EPS1 from COMMON MPRCSN. */
9784
9785 /*     KEYWORDS : */
9786 /*     ----------- */
9787 /*        MPRCSN,PRECISON,EPS3. */
9788
9789 /*     INPUT ARGUMENTS : */
9790 /*     ------------------ */
9791 /*       Humm. */
9792
9793 /*     OUTPUT ARGUMENTS : */
9794 /*     ------------------- */
9795 /*        EPS3 :  space zero of the denominator (10**-9) */
9796 /*        EPS3 should value 10**-15 */
9797
9798 /*     COMMONS USED   : */
9799 /*     ---------------- */
9800
9801 /*     REFERENCES CALLED   : */
9802 /*     ----------------------- */
9803
9804 /*     DESCRIPTION/NOTES/LIMITATIONS : */
9805 /*     ----------------------------------- */
9806
9807 /* > */
9808 /* ***********************************************************************
9809  */
9810
9811
9812
9813 /* ***********************************************************************
9814  */
9815
9816 /*     FUNCTION : */
9817 /*     ---------- */
9818 /*          GIVES TOLERANCES OF NULLITY IN STRIM */
9819 /*          AND LIMITS OF ITERATIVE PROCESSES */
9820
9821 /*          GENERAL CONTEXT, MODIFIABLE BY THE UTILISER */
9822
9823 /*     KEYWORDS : */
9824 /*     ----------- */
9825 /*          PARAMETER , TOLERANCE */
9826
9827 /*     DESCRIPTION/NOTES/LIMITATIONS : */
9828 /*     ----------------------------------- */
9829 /*       INITIALISATION   :  PROFILE , **VIA MPRFTX** AT INPUT IN STRIM*/
9830 /*       LOADING OF DEFAULT VALUES OF THE PROFILE IN MPRFTX AT INPUT*/
9831 /*       IN STRIM. THEY ARE PRESERVED IN THE LOCAL VARIABLES OF MPRFTX */
9832
9833 /*        RESET DEFAULT VALUES                   : MDFINT */
9834 /*        MODIFICATION INTERACTIVE BY THE USER   : MDBINT */
9835
9836 /*        ACCESS FUNCTION  :  MMEPS1  ...  EPS1 */
9837 /*                            MEPSPB  ...  EPS3,EPS4 */
9838 /*                            MEPSLN  ...  EPS2, NITERM , NITERR */
9839 /*                            MEPSNR  ...  EPS2 , NITERM */
9840 /*                            MITERR  ...  NITERR */
9841
9842 /* > */
9843 /* ***********************************************************************
9844  */
9845
9846 /*     NITERM : MAX NB OF ITERATIONS */
9847 /*     NITERR : NB OF RAPID ITERATIONS */
9848 /*     EPS1   : TOLERANCE OF 3D NULL DISTANCE */
9849 /*     EPS2   : TOLERANCE OF ZERO PARAMETRIC DISTANCE */
9850 /*     EPS3   : TOLERANCE TO AVOID DIVISION BY 0.. */
9851 /*     EPS4   : TOLERANCE ANGULAR */
9852
9853
9854
9855 /* ***********************************************************************
9856  */
9857
9858     ibb = AdvApp2Var_SysBase::mnfndeb_();
9859     if (ibb >= 5) {
9860         AdvApp2Var_SysBase::mgenmsg_(nomprg, 6L);
9861     }
9862
9863     *eps03 = mmprcsn_.eps3;
9864
9865     return 0;
9866 } /* mmveps3_ */
9867
9868 //=======================================================================
9869 //function : AdvApp2Var_MathBase::mmvncol_
9870 //purpose  :
9871 //=======================================================================
9872  int AdvApp2Var_MathBase::mmvncol_(integer *ndimen,
9873                             doublereal *vecin,
9874                             doublereal *vecout,
9875                             integer *iercod)
9876
9877 {
9878   /* System generated locals */
9879   integer i__1;
9880
9881   /* Local variables */
9882   logical ldbg;
9883   integer d__;
9884   doublereal vaux1[3], vaux2[3];
9885   logical colin;
9886   doublereal valaux;
9887   integer aux;
9888   logical nul;
9889
9890 /* ***********************************************************************
9891  */
9892
9893 /*     FUNCTION : */
9894 /*     ---------- */
9895 /*       CALCULATE A VECTOR NON-COLINEAR TO A GIVEN NON-NULL VECTOR */
9896
9897 /*     KEYWORDS : */
9898 /*     ----------- */
9899 /*      PUBLIC, VECTOR, FREE */
9900
9901 /*     INPUT ARGUMENTS  : */
9902 /*     -------------------- */
9903 /*       ndimen : dimension of the space */
9904 /*       vecin  : input vector */
9905
9906 /*     OUTPUT ARGUMENTS : */
9907 /*     --------------------- */
9908
9909 /*       vecout : vector non colinear to vecin */
9910
9911 /*     COMMONS USED : */
9912 /*     ------------------ */
9913
9914
9915 /*     REFERENCES CALLED : */
9916 /*     --------------------- */
9917
9918
9919 /*     DESCRIPTION/NOTES/LIMITATIONS : */
9920 /*     ----------------------------------- */
9921 /* > */
9922 /* ***********************************************************************
9923  */
9924 /*                            DECLARATIONS */
9925 /* ***********************************************************************
9926  */
9927
9928
9929
9930 /* ***********************************************************************
9931  */
9932 /*                      INITIALISATIONS */
9933 /* ***********************************************************************
9934  */
9935
9936     /* Parameter adjustments */
9937     --vecout;
9938     --vecin;
9939
9940     /* Function Body */
9941     ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 2;
9942     if (ldbg) {
9943         AdvApp2Var_SysBase::mgenmsg_("MMVNCOL", 7L);
9944     }
9945     *iercod = 0;
9946
9947 /* ***********************************************************************
9948  */
9949 /*                     PROCESSING */
9950 /* ***********************************************************************
9951  */
9952
9953     if (*ndimen <= 1 || *ndimen > 3) {
9954         goto L9101;
9955     }
9956     nul = FALSE_;
9957     d__ = 1;
9958     aux = 0;
9959     while(d__ <= *ndimen) {
9960         if (vecin[d__] == 0.) {
9961             ++aux;
9962         }
9963         ++d__;
9964     }
9965     if (aux == *ndimen) {
9966         goto L9101;
9967     }
9968
9969
9970     for (d__ = 1; d__ <= 3; ++d__) {
9971         vaux1[d__ - 1] = 0.;
9972     }
9973     i__1 = *ndimen;
9974     for (d__ = 1; d__ <= i__1; ++d__) {
9975         vaux1[d__ - 1] = vecin[d__];
9976         vaux2[d__ - 1] = vecin[d__];
9977     }
9978     colin = TRUE_;
9979     d__ = 0;
9980     while(colin) {
9981         ++d__;
9982         if (d__ > 3) {
9983             goto L9101;
9984         }
9985         vaux2[d__ - 1] += 1;
9986         valaux = vaux1[1] * vaux2[2] - vaux1[2] * vaux2[1];
9987         if (valaux == 0.) {
9988             valaux = vaux1[2] * vaux2[0] - vaux1[0] * vaux2[2];
9989             if (valaux == 0.) {
9990                 valaux = vaux1[0] * vaux2[1] - vaux1[1] * vaux2[0];
9991                 if (valaux != 0.) {
9992                     colin = FALSE_;
9993                 }
9994             } else {
9995                 colin = FALSE_;
9996             }
9997         } else {
9998             colin = FALSE_;
9999         }
10000     }
10001     if (colin) {
10002         goto L9101;
10003     }
10004     i__1 = *ndimen;
10005     for (d__ = 1; d__ <= i__1; ++d__) {
10006         vecout[d__] = vaux2[d__ - 1];
10007     }
10008
10009     goto L9999;
10010
10011 /* ***********************************************************************
10012  */
10013 /*                   ERROR PROCESSING */
10014 /* ***********************************************************************
10015  */
10016
10017
10018 L9101:
10019     *iercod = 1;
10020     goto L9999;
10021
10022
10023 /* ***********************************************************************
10024  */
10025 /*                   RETURN CALLING PROGRAM */
10026 /* ***********************************************************************
10027  */
10028
10029 L9999:
10030
10031
10032     AdvApp2Var_SysBase::maermsg_("MMVNCOL", iercod, 7L);
10033     if (ldbg) {
10034         AdvApp2Var_SysBase::mgsomsg_("MMVNCOL", 7L);
10035     }
10036  return 0 ;
10037 } /* mmvncol_ */
10038
10039 //=======================================================================
10040 //function : AdvApp2Var_MathBase::mmwprcs_
10041 //purpose  :
10042 //=======================================================================
10043 void AdvApp2Var_MathBase::mmwprcs_(doublereal *epsil1,
10044                                    doublereal *epsil2,
10045                                    doublereal *epsil3,
10046                                    doublereal *epsil4,
10047                                    integer *niter1,
10048                                    integer *niter2)
10049
10050 {
10051
10052
10053 /* ***********************************************************************
10054  */
10055
10056 /*     FUNCTION : */
10057 /*     ---------- */
10058 /*     ACCESS IN WRITING FOR COMMON MPRCSN */
10059
10060 /*     KEYWORDS : */
10061 /*     ----------- */
10062 /*     WRITING */
10063
10064 /*     INPUT ARGUMENTS : */
10065 /*     -------------------- */
10066 /*     EPSIL1  : TOLERANCE OF 3D NULL DISTANCE */
10067 /*     EPSIL2  : TOLERANCE OF PARAMETRIC NULL DISTANCE */
10068 /*     EPSIL3  : TOLERANCE TO AVOID DIVISION BY 0.. */
10069 /*     EPSIL4  : ANGULAR TOLERANCE */
10070 /*     NITER1  : MAX NB OF ITERATIONS */
10071 /*     NITER2  : NB OF RAPID ITERATIONS */
10072
10073 /*     OUTPUT ARGUMENTS : */
10074 /*     --------------------- */
10075 /*     NONE */
10076
10077 /*     COMMONS USED : */
10078 /*     ------------------ */
10079
10080
10081 /*     REFERENCES CALLED : */
10082 /*     --------------------- */
10083
10084
10085 /*     DESCRIPTION/NOTES/LIMITATIONS : */
10086 /*     ----------------------------------- */
10087
10088 /* > */
10089 /* ***********************************************************************
10090  */
10091 /*                            DECLARATIONS */
10092 /* ***********************************************************************
10093  */
10094
10095
10096 /* ***********************************************************************
10097  */
10098 /*                      INITIALIZATIONS */
10099 /* ***********************************************************************
10100  */
10101
10102 /* ***********************************************************************
10103  */
10104 /*                      PROCESSING */
10105 /* ***********************************************************************
10106  */
10107
10108 /* ***********************************************************************
10109  */
10110
10111 /*     FUNCTION : */
10112 /*     ---------- */
10113 /*          GIVES TOLERANCES OF NULLITY IN STRIM */
10114 /*          AND  LIMITS OF ITERATIVE PROCESSES */
10115
10116 /*          GENERAL CONTEXT, MODIFIABLE BY THE UTILISER */
10117
10118 /*     KEYWORDS : */
10119 /*     ----------- */
10120 /*          PARAMETER , TOLERANCE */
10121
10122 /*     DESCRIPTION/NOTES/LIMITATIONS : */
10123 /*     ----------------------------------- */
10124 /*       INITIALISATION   :  PROFILE , **VIA MPRFTX** AT INPUT IN STRIM*/
10125 /*       LOADING OF DEFAULT VALUES OF THE PROFILE IN MPRFTX AT INPUT*/
10126 /*       IN STRIM. THEY ARE PRESERVED IN THE LOCAL VARIABLES OF MPRFTX */
10127
10128 /*        RESET DEFAULT VALUES                   : MDFINT */
10129 /*        MODIFICATION INTERACTIVE BY THE USER   : MDBINT */
10130
10131 /*        ACCESS FUNCTION  :  MMEPS1  ...  EPS1 */
10132 /*                            MEPSPB  ...  EPS3,EPS4 */
10133 /*                            MEPSLN  ...  EPS2, NITERM , NITERR */
10134 /*                            MEPSNR  ...  EPS2 , NITERM */
10135 /*                            MITERR  ...  NITERR */
10136
10137 /* > */
10138 /* ***********************************************************************
10139  */
10140
10141 /*     NITERM : MAX NB OF ITERATIONS */
10142 /*     NITERR : NB OF RAPID ITERATIONS */
10143 /*     EPS1   : TOLERANCE OF 3D NULL DISTANCE */
10144 /*     EPS2   : TOLERANCE OF ZERO PARAMETRIC DISTANCE */
10145 /*     EPS3   : TOLERANCE TO AVOID DIVISION BY 0.. */
10146 /*     EPS4   : TOLERANCE ANGULAR */
10147
10148
10149 /* ***********************************************************************
10150  */
10151     mmprcsn_.eps1 = *epsil1;
10152     mmprcsn_.eps2 = *epsil2;
10153     mmprcsn_.eps3 = *epsil3;
10154     mmprcsn_.eps4 = *epsil4;
10155     mmprcsn_.niterm = *niter1;
10156     mmprcsn_.niterr = *niter2;
10157  return ;
10158 } /* mmwprcs_  */
10159
10160
10161 //=======================================================================
10162 //function : AdvApp2Var_MathBase::pow__di
10163 //purpose  :
10164 //=======================================================================
10165  doublereal AdvApp2Var_MathBase::pow__di (doublereal *x,
10166                                    integer *n)
10167 {
10168
10169   register integer ii ;
10170   doublereal result ;
10171   integer    absolute ;
10172   result = 1.0e0 ;
10173   if ( *n > 0 ) {absolute = *n;}
10174   else {absolute = -*n;}
10175     /* System generated locals */
10176   for(ii = 0 ; ii < absolute ; ii++) {
10177       result *=  *x ;
10178    }
10179   if (*n < 0) {
10180    result = 1.0e0 / result ;
10181  }
10182  return result ;
10183 }
10184
10185
10186 /* **********************************************************************
10187 */
10188
10189 /*     FUNCTION : */
10190 /*     ---------- */
10191 /*        Calculate integer function power not obligatory in the most efficient way ;
10192 */
10193
10194 /*     KEYWORDS : */
10195 /*     ----------- */
10196 /*       POWER */
10197
10198 /*     INPUT ARGUMENTS : */
10199 /*     ------------------ */
10200 /*        X      :  argument of X**N */
10201 /*        N      :  power */
10202
10203 /*     OUTPUT ARGUMENTS : */
10204 /*     ------------------- */
10205 /*        return X**N */
10206
10207 /*     COMMONS USED   : */
10208 /*     ---------------- */
10209
10210 /*     REFERENCES CALLED   : */
10211 /*     ----------------------- */
10212
10213 /*     DESCRIPTION/NOTES/LIMITATIONS : */
10214 /*     ----------------------------------- */
10215
10216 /* > */
10217 /* ***********************************************************************/
10218
10219 //=======================================================================
10220 //function : pow__ii
10221 //purpose  :
10222 //=======================================================================
10223 integer pow__ii(integer *x,
10224                 integer *n)
10225
10226 {
10227   register integer ii ;
10228   integer result ;
10229   integer    absolute ;
10230   result = 1 ;
10231   if ( *n > 0 ) {absolute = *n;}
10232   else {absolute = -*n;}
10233     /* System generated locals */
10234   for(ii = 0 ; ii < absolute ; ii++) {
10235       result *=  *x ;
10236    }
10237   if (*n < 0) {
10238    result = 1 / result ;
10239  }
10240  return result ;
10241 }
10242
10243
10244 /* **********************************************************************
10245 */
10246 /* **********************************************************************
10247 */
10248
10249 /*     FUNCTION : */
10250 /*     ---------- */
10251 /*        Calculate integer function power not obligatory in the most efficient way ;
10252 */
10253
10254 /*     KEYWORDS : */
10255 /*     ----------- */
10256 /*       POWER */
10257
10258 /*     INPUT ARGUMENTS : */
10259 /*     ------------------ */
10260 /*        X      :  argument of X**N */
10261 /*        N      :  power */
10262
10263 /*     OUTPUT ARGUMENTS : */
10264 /*     ------------------- */
10265 /*        return X**N */
10266
10267 /*     COMMONS USED   : */
10268 /*     ---------------- */
10269
10270 /*     REFERENCES CALLED   : */
10271 /*     ----------------------- */
10272
10273 /*     DESCRIPTION/NOTES/LIMITATIONS : */
10274 /*     ----------------------------------- */
10275
10276 /* > */
10277 /* ***********************************************************************/
10278
10279 //=======================================================================
10280 //function : AdvApp2Var_MathBase::msc_
10281 //purpose  :
10282 //=======================================================================
10283  doublereal AdvApp2Var_MathBase::msc_(integer *ndimen,
10284                                doublereal *vecte1,
10285                                doublereal *vecte2)
10286
10287 {
10288   /* System generated locals */
10289   integer i__1;
10290   doublereal ret_val;
10291
10292   /* Local variables */
10293   integer i__;
10294   doublereal x;
10295
10296
10297
10298 /************************************************************************
10299 *******/
10300
10301 /*     FUNCTION : */
10302 /*     ---------- */
10303 /*        Calculate the scalar product of 2 vectors in the space */
10304 /*        of dimension NDIMEN. */
10305
10306 /*     KEYWORDS : */
10307 /*     ----------- */
10308 /*        PRODUCT MSCALAIRE. */
10309
10310 /*     INPUT ARGUMENTS  : */
10311 /*     ------------------ */
10312 /*        NDIMEN : Dimension of the space. */
10313 /*        VECTE1,VECTE2: Vectors. */
10314
10315 /*     OUTPUT ARGUMENTS : */
10316 /*     ------------------- */
10317
10318 /*     COMMONS USED     : */
10319 /*     ---------------- */
10320
10321 /*     REFERENCES CALLED : */
10322 /*     ----------------------- */
10323
10324 /*     DESCRIPTION/NOTES/LIMITATIONS : */
10325 /*     ----------------------------------- */
10326
10327 /* > */
10328 /* ***********************************************************************
10329  */
10330
10331
10332 /*     PRODUIT MSCALAIRE */
10333     /* Parameter adjustments */
10334     --vecte2;
10335     --vecte1;
10336
10337     /* Function Body */
10338     x = 0.;
10339
10340     i__1 = *ndimen;
10341     for (i__ = 1; i__ <= i__1; ++i__) {
10342         x += vecte1[i__] * vecte2[i__];
10343 /* L100: */
10344     }
10345     ret_val = x;
10346
10347 /* ----------------------------------- THE END --------------------------
10348 */
10349
10350     return ret_val;
10351 } /* msc_ */
10352
10353 //=======================================================================
10354 //function : mvcvin2_
10355 //purpose  :
10356 //=======================================================================
10357 int mvcvin2_(integer *ncoeff,
10358              doublereal *crvold,
10359              doublereal *crvnew,
10360              integer *iercod)
10361
10362 {
10363   /* System generated locals */
10364   integer i__1, i__2;
10365
10366   /* Local variables */
10367   integer m1jm1, ncfm1, j, k;
10368   doublereal bid;
10369   doublereal cij1, cij2;
10370
10371
10372
10373 /************************************************************************
10374 *******/
10375
10376 /*     FONCTION : */
10377 /*     ---------- */
10378 /*        INVERSION OF THE PARAMETERS ON CURVE 2D. */
10379
10380 /*     KEYWORDS : */
10381 /*     ----------- */
10382 /*        CURVE,2D,INVERSION,PARAMETER. */
10383
10384 /*     INPUT ARGUMENTS : */
10385 /*     ------------------ */
10386 /*        NCOEFF   : NB OF COEFF OF THE CURVE. */
10387 /*        CRVOLD   : CURVE OF ORIGIN */
10388
10389 /*     OUTPUT ARGUMENTS : */
10390 /*     ------------------- */
10391 /*        CRVNEW   : THE RESULTING CURVE AFTER CHANGE OF T BY 1-T */
10392 /*        IERCOD   :  0 OK, */
10393 /*                   10 NB OF COEFF NULL OR TOO GREAT. */
10394
10395 /*     COMMONS USED   : */
10396 /*     ---------------- */
10397 /*    MCCNP */
10398
10399 /*     REFERENCES CALLED   : */
10400 /*     ---------------------- */
10401 /*            Neant */
10402 /*     DESCRIPTION/NOTES/LIMITATIONS : */
10403 /*     ----------------------------------- */
10404 /*     THE FOLLOWING CALL IS ABSOLUTELY LEGAL : */
10405 /*          CALL MVCVIN2(NCOEFF,CURVE,CURVE,IERCOD), THE TABLE CURVE */
10406 /*     BECOMES INPUT AND OUTPUT ARGUMENT (RBD). */
10407 /*     BECAUSE OF MCCNP, THE NB OF COEFF OF THE CURVE IS LIMITED TO */
10408 /*     NDGCNP+1 = 61. */
10409
10410 /* > */
10411 /* ***********************************************************************
10412  */
10413
10414
10415 /* **********************************************************************
10416 */
10417
10418 /*     FUNCTION : */
10419 /*     ---------- */
10420 /*      Serves to provide coefficients of the binome (triangle of Pascal). */
10421
10422 /*     KEYWORDS : */
10423 /*     ----------- */
10424 /*      Coeff of binome from 0 to 60. read only . init par block data */
10425
10426 /*     DEMSCRIPTION/NOTES/LIMITATIONS : */
10427 /*     ----------------------------------- */
10428 /*     The coefficients of the binome form a triangular matrix. */
10429 /*     This matrix is completed in table CNP by transposition. */
10430 /*     So: CNP(I,J) = CNP(J,I) for I and J = 0, ..., 60. */
10431
10432 /*     Initialization is done by block-data MMLLL09.RES, */
10433 /*     created by program MQINICNP.FOR (see the team (AC) ). */
10434
10435
10436 /* > */
10437 /* **********************************************************************
10438 */
10439
10440
10441
10442 /* ***********************************************************************
10443  */
10444
10445     /* Parameter adjustments */
10446     crvnew -= 3;
10447     crvold -= 3;
10448
10449     /* Function Body */
10450     if (*ncoeff < 1 || *ncoeff - 1 > 60) {
10451         *iercod = 10;
10452         goto L9999;
10453     }
10454     *iercod = 0;
10455
10456
10457 /* CONSTANT TERM OF THE NEW CURVE */
10458
10459     cij1 = crvold[3];
10460     cij2 = crvold[4];
10461     i__1 = *ncoeff;
10462     for (k = 2; k <= i__1; ++k) {
10463         cij1 += crvold[(k << 1) + 1];
10464         cij2 += crvold[(k << 1) + 2];
10465     }
10466     crvnew[3] = cij1;
10467     crvnew[4] = cij2;
10468     if (*ncoeff == 1) {
10469         goto L9999;
10470     }
10471
10472 /* INTERMEDIARY POWERS OF THE PARAMETER */
10473
10474     ncfm1 = *ncoeff - 1;
10475     m1jm1 = 1;
10476     i__1 = ncfm1;
10477     for (j = 2; j <= i__1; ++j) {
10478         m1jm1 = -m1jm1;
10479         cij1 = crvold[(j << 1) + 1];
10480         cij2 = crvold[(j << 1) + 2];
10481         i__2 = *ncoeff;
10482         for (k = j + 1; k <= i__2; ++k) {
10483             bid = mmcmcnp_.cnp[k - 1 + (j - 1) * 61];
10484             cij1 += crvold[(k << 1) + 1] * bid;
10485             cij2 += crvold[(k << 1) + 2] * bid;
10486         }
10487         crvnew[(j << 1) + 1] = cij1 * m1jm1;
10488         crvnew[(j << 1) + 2] = cij2 * m1jm1;
10489     }
10490
10491 /* TERM OF THE HIGHEST  DEGREE */
10492
10493     crvnew[(*ncoeff << 1) + 1] = -crvold[(*ncoeff << 1) + 1] * m1jm1;
10494     crvnew[(*ncoeff << 1) + 2] = -crvold[(*ncoeff << 1) + 2] * m1jm1;
10495
10496 L9999:
10497     if (*iercod > 0) {
10498         AdvApp2Var_SysBase::maermsg_("MVCVIN2", iercod, 7L);
10499     }
10500  return 0 ;
10501 } /* mvcvin2_ */
10502
10503 //=======================================================================
10504 //function : mvcvinv_
10505 //purpose  :
10506 //=======================================================================
10507 int mvcvinv_(integer *ncoeff,
10508              doublereal *crvold,
10509              doublereal *crvnew,
10510              integer *iercod)
10511
10512 {
10513   /* System generated locals */
10514   integer i__1, i__2;
10515
10516   /* Local variables */
10517   integer m1jm1, ncfm1, j, k;
10518   doublereal bid;
10519   //extern /* Subroutine */ int maermsg_();
10520   doublereal cij1, cij2, cij3;
10521
10522
10523 /* **********************************************************************
10524 */
10525
10526 /*     FUNCTION : */
10527 /*     ---------- */
10528 /*        INVERSION OF THE PARAMETER ON A CURBE 3D (I.E. INVERSION */
10529 /*        OF THE DIRECTION OF PARSING). */
10530
10531 /*     KEYWORDS : */
10532 /*     ----------- */
10533 /*        CURVE,INVERSION,PARAMETER. */
10534
10535 /*     INPUT ARGUMENTS : */
10536 /*     ------------------ */
10537 /*        NCOEFF   : NB OF COEFF OF THE CURVE. */
10538 /*        CRVOLD   : CURVE OF ORIGIN */
10539
10540 /*     OUTPUT ARGUMENTS : */
10541 /*     ------------------- */
10542 /*        CRVNEW   : RESULTING CURVE AFTER CHANGE OF T INTO 1-T */
10543 /*        IERCOD   :  0 OK, */
10544 /*                   10 NB OF COEFF NULL OR TOO GREAT. */
10545
10546 /*     COMMONS USED   : */
10547 /*     ---------------- */
10548 /*    MCCNP */
10549
10550 /*     REFERENCES CALLED   : */
10551 /*     ---------------------- */
10552 /*            Neant */
10553 /*     DESCRIPTION/NOTES/LIMITATIONS : */
10554 /*     ----------------------------------- */
10555 /*     THE FOLLOWING CALL IS ABSOLUTELY LEGAL : */
10556 /*          CALL MVCVINV(NCOEFF,CURVE,CURVE,IERCOD), TABLE CURVE */
10557 /*     BECOMES INPUT AND OUTPUT ARGUMENT (RBD). */
10558 /*     THE NUMBER OF COEFF OF THE CURVE IS LIMITED TO NDGCNP+1 = 61 */
10559 /*     BECAUSE OF USE OF COMMON MCCNP. */
10560 /* > */
10561 /* ***********************************************************************
10562  */
10563
10564 /* **********************************************************************
10565 */
10566
10567 /*     FUNCTION : */
10568 /*     ---------- */
10569 /*      Serves to provide the binomial coefficients (triangle of Pascal). */
10570
10571 /*     KEYWORDS : */
10572 /*     ----------- */
10573 /*      Binomial Coeff from 0 to 60. read only . init par block data */
10574
10575 /*     DEMSCRIPTION/NOTES/LIMITATIONS : */
10576 /*     ----------------------------------- */
10577 /*     The binomial coefficients form a triangular matrix. */
10578 /*     This matrix is completed in table CNP by its transposition. */
10579 /*     So: CNP(I,J) = CNP(J,I) for I and J = 0, ..., 60. */
10580
10581 /*     Initialisation is done by block-data MMLLL09.RES, */
10582 /*     created by program MQINICNP.FOR (see the team (AC) ). */
10583 /* > */
10584 /* **********************************************************************
10585 */
10586
10587
10588
10589 /* ***********************************************************************
10590  */
10591
10592     /* Parameter adjustments */
10593     crvnew -= 4;
10594     crvold -= 4;
10595
10596     /* Function Body */
10597     if (*ncoeff < 1 || *ncoeff - 1 > 60) {
10598         *iercod = 10;
10599         goto L9999;
10600     }
10601     *iercod = 0;
10602
10603 /* CONSTANT TERM OF THE NEW CURVE */
10604
10605     cij1 = crvold[4];
10606     cij2 = crvold[5];
10607     cij3 = crvold[6];
10608     i__1 = *ncoeff;
10609     for (k = 2; k <= i__1; ++k) {
10610         cij1 += crvold[k * 3 + 1];
10611         cij2 += crvold[k * 3 + 2];
10612         cij3 += crvold[k * 3 + 3];
10613 /* L30: */
10614     }
10615     crvnew[4] = cij1;
10616     crvnew[5] = cij2;
10617     crvnew[6] = cij3;
10618     if (*ncoeff == 1) {
10619         goto L9999;
10620     }
10621
10622 /* INTERMEDIARY POWER OF THE PARAMETER */
10623
10624     ncfm1 = *ncoeff - 1;
10625     m1jm1 = 1;
10626     i__1 = ncfm1;
10627     for (j = 2; j <= i__1; ++j) {
10628         m1jm1 = -m1jm1;
10629         cij1 = crvold[j * 3 + 1];
10630         cij2 = crvold[j * 3 + 2];
10631         cij3 = crvold[j * 3 + 3];
10632         i__2 = *ncoeff;
10633         for (k = j + 1; k <= i__2; ++k) {
10634             bid = mmcmcnp_.cnp[k - 1 + (j - 1) * 61];
10635             cij1 += crvold[k * 3 + 1] * bid;
10636             cij2 += crvold[k * 3 + 2] * bid;
10637             cij3 += crvold[k * 3 + 3] * bid;
10638 /* L40: */
10639         }
10640         crvnew[j * 3 + 1] = cij1 * m1jm1;
10641         crvnew[j * 3 + 2] = cij2 * m1jm1;
10642         crvnew[j * 3 + 3] = cij3 * m1jm1;
10643 /* L50: */
10644     }
10645
10646     /* TERM OF THE HIGHEST DEGREE */
10647
10648     crvnew[*ncoeff * 3 + 1] = -crvold[*ncoeff * 3 + 1] * m1jm1;
10649     crvnew[*ncoeff * 3 + 2] = -crvold[*ncoeff * 3 + 2] * m1jm1;
10650     crvnew[*ncoeff * 3 + 3] = -crvold[*ncoeff * 3 + 3] * m1jm1;
10651
10652 L9999:
10653     AdvApp2Var_SysBase::maermsg_("MVCVINV", iercod, 7L);
10654     return 0;
10655 } /* mvcvinv_ */
10656
10657 //=======================================================================
10658 //function : mvgaus0_
10659 //purpose  :
10660 //=======================================================================
10661 int mvgaus0_(integer *kindic,
10662              doublereal *urootl,
10663              doublereal *hiltab,
10664              integer *nbrval,
10665              integer *iercod)
10666
10667 {
10668     /* System generated locals */
10669     integer i__1;
10670
10671     /* Local variables */
10672     doublereal tamp[40];
10673     integer ndegl, kg, ii;
10674
10675 /* **********************************************************************
10676 */
10677
10678 /*      FUNCTION : */
10679 /*      -------- */
10680 /*  Loading of a degree gives roots of LEGENDRE polynom */
10681 /*  DEFINED on [-1,1] and weights of Gauss quadrature formulas */
10682 /*  (based on corresponding LAGRANGIAN interpolators). */
10683 /*  The symmetry relative to 0 is used between [-1,0] and [0,1]. */
10684
10685 /*      KEYWORDS : */
10686 /*      --------- */
10687 /*         . VOLUMIC, LEGENDRE, LAGRANGE, GAUSS */
10688
10689 /*      INPUT ARGUMENTSE : */
10690 /*      ------------------ */
10691
10692 /*  KINDIC : Takes values from 1 to 10 depending of the degree */
10693 /*           of the used polynom. */
10694 /*           The degree of the polynom is equal to 4 k, i.e. 4, 8, */
10695 /*           12, 16, 20, 24, 28, 32, 36 and 40. */
10696
10697 /*      OUTPUT ARGUMENTS : */
10698 /*      ------------------- */
10699
10700 /*  UROOTL : Roots of LEGENDRE polynom in domain [1,0] */
10701 /*           given in decreasing order. For domain [-1,0], it is */
10702 /*           necessary to take the opposite values. */
10703 /*  HILTAB : LAGRANGE interpolators associated to roots. For */
10704 /*           opposed roots, interpolatorsare equal. */
10705 /*  NBRVAL : Nb of coefficients. Is equal to the half of degree */
10706 /*           depending on the symmetry (i.e. 2*KINDIC). */
10707
10708 /*  IERCOD  :  Error code: */
10709 /*          < 0 ==> Attention - Warning */
10710 /*          =-1 ==> Value of false KINDIC. NBRVAL is forced to 20 */
10711 /*                  (order 40) */
10712 /*          = 0 ==> Everything is OK */
10713
10714 /*      COMMON USED : */
10715 /*      ---------------- */
10716
10717 /*      REFERENCES CALLED : */
10718 /*      ------------------- */
10719
10720 /*      DESCRIPTION/NOTES/LIMITATIONS : */
10721 /*      --------------------------------- */
10722 /*      If KINDIC is not correct (i.e < 1 or > 10), the degree is set */
10723 /*      to 40 directly (ATTENTION to overload - to avoid it, */
10724 /*      preview UROOTL and HILTAB dimensioned at least to 20). */
10725
10726 /*      The value of coefficients was calculated with quadruple precision */
10727 /*      by JJM with help of GD. */
10728 /*      Checking of roots was done by GD. */
10729
10730 /*      See detailed explications on the listing */
10731 /* > */
10732 /* **********************************************************************
10733 */
10734
10735
10736 /* ------------------------------------ */
10737 /* ****** Test  validity of KINDIC ** */
10738 /* ------------------------------------ */
10739
10740     /* Parameter adjustments */
10741     --hiltab;
10742     --urootl;
10743
10744     /* Function Body */
10745     *iercod = 0;
10746     kg = *kindic;
10747     if (kg < 1 || kg > 10) {
10748         kg = 10;
10749         *iercod = -1;
10750     }
10751     *nbrval = kg << 1;
10752     ndegl = *nbrval << 1;
10753
10754 /* ----------------------------------------------------------------------
10755 */
10756 /* ****** Load NBRVAL positive roots depending on the degree **
10757 */
10758 /* ----------------------------------------------------------------------
10759 */
10760 /* ATTENTION : Sign minus (-) in the loop is intentional. */
10761
10762     mmextrl_(&ndegl, tamp);
10763     i__1 = *nbrval;
10764     for (ii = 1; ii <= i__1; ++ii) {
10765         urootl[ii] = -tamp[ii - 1];
10766 /* L100: */
10767     }
10768
10769 /* ------------------------------------------------------------------- */
10770 /* ****** Loading of NBRVAL Gauss weight depending on the degree ** */
10771 /* ------------------------------------------------------------------- */
10772
10773     mmexthi_(&ndegl, tamp);
10774     i__1 = *nbrval;
10775     for (ii = 1; ii <= i__1; ++ii) {
10776         hiltab[ii] = tamp[ii - 1];
10777 /* L200: */
10778     }
10779
10780 /* ------------------------------- */
10781 /* ****** End of sub-program ** */
10782 /* ------------------------------- */
10783
10784     return 0;
10785 } /* mvgaus0_ */
10786
10787 //=======================================================================
10788 //function : mvpscr2_
10789 //purpose  :
10790 //=======================================================================
10791 int mvpscr2_(integer *ncoeff,
10792              doublereal *curve2,
10793              doublereal *tparam,
10794              doublereal *pntcrb)
10795 {
10796   /* System generated locals */
10797   integer i__1;
10798
10799   /* Local variables */
10800   integer ndeg, kk;
10801   doublereal xxx, yyy;
10802
10803
10804
10805 /* **********************************************************************
10806 */
10807
10808 /*     FUNCTION : */
10809 /*     ---------- */
10810 /*  POSITIONING ON CURVE (NCF,2) IN SPACE OF DIMENSION 2. */
10811
10812 /*     KEYWORDS : */
10813 /*     ----------- */
10814 /*     TOUS,MATH_ACCES:: COURBE&,POSITIONNEMENT,&POINT. */
10815
10816 /*     INPUT ARGUMENTS : */
10817 /*     ------------------ */
10818 /*     NCOEFF : NUMBER OF COEFFICIENTS OF THE CURVE */
10819 /*     CURVE2 : EQUATION OF CURVE 2D */
10820 /*     TPARAM : VALUE OF PARAMETER AT GIVEN POINT */
10821
10822 /*     OUTPUT ARGUMENTS : */
10823 /*     ------------------- */
10824 /*     PNTCRB : COORDINATES OF POINT CORRESPONDING TO PARAMETER */
10825 /*              TPARAM ON CURVE 2D CURVE2. */
10826
10827 /*     COMMONS USED   : */
10828 /*     ---------------- */
10829
10830 /*     REFERENCES CALLED   : */
10831 /*     ---------------------- */
10832
10833 /*     DESCRIPTION/NOTES/LIMITATIONS : */
10834 /*     ----------------------------------- */
10835 /*     MSCHEMA OF HORNER. */
10836
10837 /* > */
10838 /* **********************************************************************
10839 */
10840
10841
10842 /* -------- INITIALIZATIONS AND PROCESSING OF PARTICULAR CASES ----------
10843 */
10844
10845 /* ---> Cas when NCOEFF > 1 (case STANDARD). */
10846     /* Parameter adjustments */
10847     --pntcrb;
10848     curve2 -= 3;
10849
10850     /* Function Body */
10851     if (*ncoeff >= 2) {
10852         goto L1000;
10853     }
10854 /* ---> Case when NCOEFF <= 1. */
10855     if (*ncoeff <= 0) {
10856         pntcrb[1] = 0.;
10857         pntcrb[2] = 0.;
10858         goto L9999;
10859     } else if (*ncoeff == 1) {
10860         pntcrb[1] = curve2[3];
10861         pntcrb[2] = curve2[4];
10862         goto L9999;
10863     }
10864
10865 /* -------------------- MSCHEMA OF HORNER (PARTICULAR CASE) --------------
10866  */
10867
10868 L1000:
10869
10870     if (*tparam == 1.) {
10871         xxx = 0.;
10872         yyy = 0.;
10873         i__1 = *ncoeff;
10874         for (kk = 1; kk <= i__1; ++kk) {
10875             xxx += curve2[(kk << 1) + 1];
10876             yyy += curve2[(kk << 1) + 2];
10877 /* L100: */
10878         }
10879         goto L5000;
10880     } else if (*tparam == 0.) {
10881         pntcrb[1] = curve2[3];
10882         pntcrb[2] = curve2[4];
10883         goto L9999;
10884     }
10885
10886 /* ---------------------------- MSCHEMA OF HORNER ------------------------
10887  */
10888 /* ---> TPARAM is different from 1.D0 and 0.D0. */
10889
10890     ndeg = *ncoeff - 1;
10891     xxx = curve2[(*ncoeff << 1) + 1];
10892     yyy = curve2[(*ncoeff << 1) + 2];
10893     for (kk = ndeg; kk >= 1; --kk) {
10894         xxx = xxx * *tparam + curve2[(kk << 1) + 1];
10895         yyy = yyy * *tparam + curve2[(kk << 1) + 2];
10896 /* L200: */
10897     }
10898     goto L5000;
10899
10900 /* ------------------------ RECOVER THE CALCULATED POINT ---------------
10901 */
10902
10903 L5000:
10904     pntcrb[1] = xxx;
10905     pntcrb[2] = yyy;
10906
10907 /* ------------------------------ THE END -------------------------------
10908 */
10909
10910 L9999:
10911     return 0;
10912 } /* mvpscr2_ */
10913
10914 //=======================================================================
10915 //function : mvpscr3_
10916 //purpose  :
10917 //=======================================================================
10918 int mvpscr3_(integer *ncoeff,
10919              doublereal *curve3,
10920              doublereal *tparam,
10921              doublereal *pntcrb)
10922
10923 {
10924   /* System generated locals */
10925   integer i__1;
10926
10927   /* Local variables */
10928   integer ndeg, kk;
10929   doublereal xxx, yyy, zzz;
10930
10931
10932
10933 /* **********************************************************************
10934 */
10935
10936 /*     FUNCTION : */
10937 /*     ---------- */
10938 /* POSITIONING ON A CURVE (3,NCF) IN THE SPACE OF DIMENSION 3. */
10939
10940 /*     KEYWORDS : */
10941 /*     ----------- */
10942 /*     TOUS, MATH_ACCES:: COURBE&,POSITIONNEMENT,&POINT. */
10943
10944 /*     INPUT ARGUMENTS  : */
10945 /*     ------------------ */
10946 /*     NCOEFF : NB OF COEFFICIENTS OF THE CURVE */
10947 /*     CURVE3 : EQUATION OF CURVE 3D */
10948 /*     TPARAM : VALUE OF THE PARAMETER AT THE GIVEN POINT */
10949
10950 /*     OUTPUT ARGUMENTS : */
10951 /*     ------------------- */
10952 /*     PNTCRB : COORDINATES OF THE POINT CORRESPONDING TO PARAMETER */
10953 /*              TPARAM ON CURVE 3D CURVE3. */
10954
10955 /*     COMMONS USED   : */
10956 /*     ---------------- */
10957
10958 /*     REFERENCES CALLED   : */
10959 /*     ---------------------- */
10960 /*            Neant */
10961
10962 /*     DESCRIPTION/NOTES/LIMITATIONS : */
10963 /*     ----------------------------------- */
10964 /*     MSCHEMA OF HORNER. */
10965 /* > */
10966 /* **********************************************************************
10967 */
10968 /*                           DECLARATIONS */
10969 /* **********************************************************************
10970 */
10971
10972
10973 /* -------- INITIALISATIONS AND PROCESSING OF PARTICULAR CASES ----------
10974 */
10975
10976 /* ---> Case when NCOEFF > 1 (cas STANDARD). */
10977     /* Parameter adjustments */
10978     --pntcrb;
10979     curve3 -= 4;
10980
10981     /* Function Body */
10982     if (*ncoeff >= 2) {
10983         goto L1000;
10984     }
10985 /* ---> Case when NCOEFF <= 1. */
10986     if (*ncoeff <= 0) {
10987         pntcrb[1] = 0.;
10988         pntcrb[2] = 0.;
10989         pntcrb[3] = 0.;
10990         goto L9999;
10991     } else if (*ncoeff == 1) {
10992         pntcrb[1] = curve3[4];
10993         pntcrb[2] = curve3[5];
10994         pntcrb[3] = curve3[6];
10995         goto L9999;
10996     }
10997
10998 /* -------------------- MSCHEMA OF HORNER (PARTICULAR CASE) --------------
10999  */
11000
11001 L1000:
11002
11003     if (*tparam == 1.) {
11004         xxx = 0.;
11005         yyy = 0.;
11006         zzz = 0.;
11007         i__1 = *ncoeff;
11008         for (kk = 1; kk <= i__1; ++kk) {
11009             xxx += curve3[kk * 3 + 1];
11010             yyy += curve3[kk * 3 + 2];
11011             zzz += curve3[kk * 3 + 3];
11012 /* L100: */
11013         }
11014         goto L5000;
11015     } else if (*tparam == 0.) {
11016         pntcrb[1] = curve3[4];
11017         pntcrb[2] = curve3[5];
11018         pntcrb[3] = curve3[6];
11019         goto L9999;
11020     }
11021
11022 /* ---------------------------- MSCHEMA OF HORNER ------------------------
11023  */
11024 /* ---> Here TPARAM is different from 1.D0 and 0.D0. */
11025
11026     ndeg = *ncoeff - 1;
11027     xxx = curve3[*ncoeff * 3 + 1];
11028     yyy = curve3[*ncoeff * 3 + 2];
11029     zzz = curve3[*ncoeff * 3 + 3];
11030     for (kk = ndeg; kk >= 1; --kk) {
11031         xxx = xxx * *tparam + curve3[kk * 3 + 1];
11032         yyy = yyy * *tparam + curve3[kk * 3 + 2];
11033         zzz = zzz * *tparam + curve3[kk * 3 + 3];
11034 /* L200: */
11035     }
11036     goto L5000;
11037
11038 /* ------------------------ RETURN THE CALCULATED POINT ------------------
11039 */
11040
11041 L5000:
11042     pntcrb[1] = xxx;
11043     pntcrb[2] = yyy;
11044     pntcrb[3] = zzz;
11045
11046 /* ------------------------------ THE END -------------------------------
11047 */
11048
11049 L9999:
11050     return 0;
11051 } /* mvpscr3_ */
11052
11053 //=======================================================================
11054 //function : AdvApp2Var_MathBase::mvsheld_
11055 //purpose  :
11056 //=======================================================================
11057  int AdvApp2Var_MathBase::mvsheld_(integer *n,
11058                             integer *is,
11059                             doublereal *dtab,
11060                             integer *icle)
11061
11062 {
11063   /* System generated locals */
11064   integer dtab_dim1, dtab_offset, i__1, i__2;
11065
11066   /* Local variables */
11067   integer incr;
11068   doublereal dsave;
11069   integer i3, i4, i5, incrp1;
11070
11071
11072 /************************************************************************
11073 *******/
11074
11075 /*     FUNCTION : */
11076 /*     ---------- */
11077 /*       PARSING OF COLUMNS OF TABLE OF REAL*8 BY SHELL METHOD*/
11078 /*        (IN INCREASING ORDER) */
11079
11080 /*     KEYWORDS : */
11081 /*     ----------- */
11082 /*        POINT-ENTRY, PARSING, SHELL */
11083
11084 /*     INPUT ARGUMENTS : */
11085 /*     ------------------ */
11086 /*        N      : NUMBER OF COLUMNS OF THE TABLE */
11087 /*        IS     : NUMBER OF LINE OF THE TABLE */
11088 /*        DTAB   : TABLE OF REAL*8 TO BE PARSED */
11089 /*        ICLE   : POSITION OF THE KEY ON THE COLUMN */
11090
11091 /*     OUTPUT ARGUMENTS : */
11092 /*     ------------------- */
11093 /*        DTAB   : PARSED TABLE */
11094
11095 /*     COMMONS USED   : */
11096 /*     ---------------- */
11097
11098
11099 /*     REFERENCES CALLED   : */
11100 /*     ---------------------- */
11101 /*            Neant */
11102
11103 /*     DESCRIPTION/NOTES/LIMITATIONS : */
11104 /*     ----------------------------------- */
11105 /*     CLASSIC SHELL METHOD : PARSING BY SERIES */
11106 /*     Declaration DTAB(IS, 1) corresponds to DTAB(IS, *) */
11107 /* > */
11108 /* ***********************************************************************
11109  */
11110
11111
11112     /* Parameter adjustments */
11113     dtab_dim1 = *is;
11114     dtab_offset = dtab_dim1 + 1;
11115     dtab -= dtab_offset;
11116
11117     /* Function Body */
11118     if (*n <= 1) {
11119         goto L9900;
11120     }
11121 /*     ------------------------ */
11122
11123 /*  INITIALIZATION OF THE SEQUENCE OF INCREMENTS */
11124 /*  FIND THE GREATEST INCREMENT SO THAT INCR < N/9 */
11125
11126     incr = 1;
11127 L1001:
11128     if (incr >= *n / 9) {
11129         goto L1002;
11130     }
11131 /*     ----------------------------- */
11132     incr = incr * 3 + 1;
11133     goto L1001;
11134
11135 /*  LOOP ON INCREMENTS TILL INCR = 1 */
11136 /*  PARSING BY SERIES DISTANT FROM INCR */
11137
11138 L1002:
11139     incrp1 = incr + 1;
11140 /*     ----------------- */
11141     i__1 = *n;
11142     for (i3 = incrp1; i3 <= i__1; ++i3) {
11143 /*        ---------------------- */
11144
11145 /*  SET ELEMENT I3 AT ITS PLACE IN THE SERIES */
11146
11147         i4 = i3 - incr;
11148 L1004:
11149         if (i4 < 1) {
11150             goto L1003;
11151         }
11152 /*           ------------------------- */
11153         if (dtab[*icle + i4 * dtab_dim1] <= dtab[*icle + (i4 + incr) *
11154                 dtab_dim1]) {
11155             goto L1003;
11156         }
11157
11158         i__2 = *is;
11159         for (i5 = 1; i5 <= i__2; ++i5) {
11160 /*              ------------------ */
11161             dsave = dtab[i5 + i4 * dtab_dim1];
11162             dtab[i5 + i4 * dtab_dim1] = dtab[i5 + (i4 + incr) * dtab_dim1];
11163             dtab[i5 + (i4 + incr) * dtab_dim1] = dsave;
11164         }
11165 /*              -------- */
11166         i4 -= incr;
11167         goto L1004;
11168
11169 L1003:
11170         ;
11171     }
11172 /*           -------- */
11173
11174 /*  PASSAGE TO THE NEXT INCREMENT */
11175
11176     incr /= 3;
11177     if (incr >= 1) {
11178         goto L1002;
11179     }
11180
11181 L9900:
11182  return 0   ;
11183 } /* mvsheld_ */
11184
11185 //=======================================================================
11186 //function : AdvApp2Var_MathBase::mzsnorm_
11187 //purpose  :
11188 //=======================================================================
11189  doublereal AdvApp2Var_MathBase::mzsnorm_(integer *ndimen,
11190                                    doublereal *vecteu)
11191
11192 {
11193   /* System generated locals */
11194   integer i__1;
11195   doublereal ret_val, d__1, d__2;
11196
11197   /* Local variables */
11198   doublereal xsom;
11199   integer i__, irmax;
11200
11201
11202
11203 /* ***********************************************************************
11204  */
11205
11206 /*     FUNCTION : */
11207 /*     ---------- */
11208 /*        SERVES to calculate the euclidian norm of a vector : */
11209 /*                       ____________________________ */
11210 /*                  Z = V  V(1)**2 + V(2)**2 + ... */
11211
11212 /*     KEYWORDS : */
11213 /*     ----------- */
11214 /*        SURMFACIQUE, */
11215
11216 /*     INPUT ARGUMENTS : */
11217 /*     ------------------ */
11218 /*        NDIMEN : Dimension of the vector */
11219 /*        VECTEU : vector of dimension NDIMEN */
11220
11221 /*     OUTPUT ARGUMENTS : */
11222 /*     ------------------- */
11223 /*        MZSNORM : Value of the euclidian norm of vector VECTEU */
11224
11225 /*     COMMONS USED   : */
11226 /*     ---------------- */
11227
11228 /*      .Neant. */
11229
11230 /*     REFERENCES CALLED   : */
11231 /*     ---------------------- */
11232 /*     Type  Name */
11233 /*      R*8  ABS            R*8  SQRT */
11234
11235 /*     DESCRIPTION/NOTESS/LIMITATIONS : */
11236 /*     ----------------------------------- */
11237 /*     To limit the risks of overflow, */
11238 /*     the term of the strongest absolute value is factorized : */
11239 /*                                _______________________ */
11240 /*                  Z = !V(1)! * V  1 + (V(2)/V(1))**2 + ... */
11241
11242 /* > */
11243 /* ***********************************************************************
11244  */
11245 /*                      DECLARATIONS */
11246 /* ***********************************************************************
11247  */
11248
11249
11250 /* ***********************************************************************
11251  */
11252 /*                     PROCESSING */
11253 /* ***********************************************************************
11254  */
11255
11256 /* ___ Find the strongest absolute value term */
11257
11258     /* Parameter adjustments */
11259     --vecteu;
11260
11261     /* Function Body */
11262     irmax = 1;
11263     i__1 = *ndimen;
11264     for (i__ = 2; i__ <= i__1; ++i__) {
11265         if ((d__1 = vecteu[irmax], advapp_abs(d__1)) < (d__2 = vecteu[i__], advapp_abs(d__2)
11266                 )) {
11267             irmax = i__;
11268         }
11269 /* L100: */
11270     }
11271
11272 /* ___ Calculate the norme */
11273
11274     if ((d__1 = vecteu[irmax], advapp_abs(d__1)) < 1.) {
11275         xsom = 0.;
11276         i__1 = *ndimen;
11277         for (i__ = 1; i__ <= i__1; ++i__) {
11278 /* Computing 2nd power */
11279             d__1 = vecteu[i__];
11280             xsom += d__1 * d__1;
11281 /* L200: */
11282         }
11283         ret_val = sqrt(xsom);
11284     } else {
11285         xsom = 0.;
11286         i__1 = *ndimen;
11287         for (i__ = 1; i__ <= i__1; ++i__) {
11288             if (i__ == irmax) {
11289                 xsom += 1.;
11290             } else {
11291 /* Computing 2nd power */
11292                 d__1 = vecteu[i__] / vecteu[irmax];
11293                 xsom += d__1 * d__1;
11294             }
11295 /* L300: */
11296         }
11297         ret_val = (d__1 = vecteu[irmax], advapp_abs(d__1)) * sqrt(xsom);
11298     }
11299
11300 /* ***********************************************************************
11301  */
11302 /*                   RETURN CALLING PROGRAM */
11303 /* ***********************************************************************
11304  */
11305
11306     return ret_val;
11307 } /* mzsnorm_ */
11308