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 under
   6 // the terms of the GNU Lesser General Public License 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 #include <NCollection_Array1.hxx>
  21
  22 // statics
  23 static
  24 int mmchole_(integer *mxcoef,
  25              integer *dimens,
  26              doublereal *amatri,
  27              integer *aposit,
  28              integer *posuiv,
  29              doublereal *chomat,
  30              integer *iercod);
  31
  32
  33
  34
  35 static
  36 int mmrslss_(integer *mxcoef,
  37              integer *dimens,
  38              doublereal *smatri,
  39              integer *sposit,
  40              integer *posuiv,
  41              doublereal *mscnmbr,
  42              doublereal *soluti,
  43              integer *iercod);
  44
  45 static
  46 int mfac_(doublereal *f,
  47           integer *n);
  48
  49 static
  50 int mmaper0_(integer *ncofmx,
  51              integer *ndimen,
  52              integer *ncoeff,
  53              doublereal *crvlgd,
  54              integer *ncfnew,
  55              doublereal *ycvmax,
  56              doublereal *errmax);
  57 static
  58 int mmaper2_(integer *ncofmx,
  59              integer *ndimen,
  60              integer *ncoeff,
  61              doublereal *crvjac,
  62              integer *ncfnew,
  63              doublereal *ycvmax,
  64              doublereal *errmax);
  65
  66 static
  67 int mmaper4_(integer *ncofmx,
  68              integer *ndimen,
  69              integer *ncoeff,
  70              doublereal *crvjac,
  71              integer *ncfnew,
  72              doublereal *ycvmax,
  73              doublereal *errmax);
  74
  75 static
  76 int mmaper6_(integer *ncofmx,
  77              integer *ndimen,
  78              integer *ncoeff,
  79              doublereal *crvjac,
  80              integer *ncfnew,
  81              doublereal *ycvmax,
  82              doublereal *errmax);
  83
  84 static
  85 int mmarc41_(integer *ndimax,
  86              integer *ndimen,
  87              integer *ncoeff,
  88              doublereal *crvold,
  89              doublereal *upara0,
  90              doublereal *upara1,
  91              doublereal *crvnew,
  92              integer *iercod);
  93
  94 static
  95 int mmatvec_(integer *nligne,
  96              integer *ncolon,
  97              integer *gposit,
  98              integer *gnstoc,
  99              doublereal *gmatri,
 100              doublereal *vecin,
 101              integer *deblig,
 102              doublereal *vecout,
 103              integer *iercod);
 104
 105 static
 106 int mmcvstd_(integer *ncofmx,
 107              integer *ndimax,
 108              integer *ncoeff,
 109              integer *ndimen,
 110              doublereal *crvcan,
 111              doublereal *courbe);
 112
 113 static
 114 int mmdrvcb_(integer *ideriv,
 115              integer *ndim,
 116              integer *ncoeff,
 117              doublereal *courbe,
 118              doublereal *tparam,
 119              doublereal *tabpnt,
 120              integer *iercod);
 121
 122 static
 123 int mmexthi_(integer *ndegre,
 124              NCollection_Array1<doublereal>& hwgaus);
 125
 126 static
 127 int mmextrl_(integer *ndegre,
 128              NCollection_Array1<doublereal>& rootlg);
 129
 130
 131
 132 static
 133 int mmherm0_(doublereal *debfin,
 134              integer *iercod);
 135
 136 static
 137 int mmherm1_(doublereal *debfin,
 138              integer *ordrmx,
 139              integer *iordre,
 140              doublereal *hermit,
 141              integer *iercod);
 142 static
 143 int mmloncv_(integer *ndimax,
 144              integer *ndimen,
 145              integer *ncoeff,
 146              doublereal *courbe,
 147              doublereal *tdebut,
 148              doublereal *tfinal,
 149              doublereal *xlongc,
 150              integer *iercod);
 151 static
 152 int mmpojac_(doublereal *tparam,
 153              integer *iordre,
 154              integer *ncoeff,
 155              integer *nderiv,
 156        NCollection_Array1<doublereal>& valjac,
 157              integer *iercod);
 158
 159 static
 160 int mmrslw_(integer *normax,
 161             integer *nordre,
 162             integer *ndimen,
 163             doublereal *epspiv,
 164             doublereal *abmatr,
 165             doublereal *xmatri,
 166             integer *iercod);
 167 static
 168 int mmtmave_(integer *nligne,
 169              integer *ncolon,
 170              integer *gposit,
 171              integer *gnstoc,
 172              doublereal *gmatri,
 173              doublereal *vecin,
 174              doublereal *vecout,
 175              integer *iercod);
 176 static
 177 int mmtrpj0_(integer *ncofmx,
 178              integer *ndimen,
 179              integer *ncoeff,
 180              doublereal *epsi3d,
 181              doublereal *crvlgd,
 182              doublereal *ycvmax,
 183              doublereal *epstrc,
 184              integer *ncfnew);
 185 static
 186 int mmtrpj2_(integer *ncofmx,
 187              integer *ndimen,
 188              integer *ncoeff,
 189              doublereal *epsi3d,
 190              doublereal *crvlgd,
 191              doublereal *ycvmax,
 192              doublereal *epstrc,
 193              integer *ncfnew);
 194
 195 static
 196 int mmtrpj4_(integer *ncofmx,
 197              integer *ndimen,
 198              integer *ncoeff,
 199              doublereal *epsi3d,
 200              doublereal *crvlgd,
 201              doublereal *ycvmax,
 202              doublereal *epstrc,
 203              integer *ncfnew);
 204 static
 205 int mmtrpj6_(integer *ncofmx,
 206              integer *ndimen,
 207              integer *ncoeff,
 208              doublereal *epsi3d,
 209              doublereal *crvlgd,
 210              doublereal *ycvmax,
 211              doublereal *epstrc,
 212              integer *ncfnew);
 213 static
 214 integer  pow__ii(integer *x,
 215                  integer *n);
 216
 217 static
 218 int mvcvin2_(integer *ncoeff,
 219              doublereal *crvold,
 220              doublereal *crvnew,
 221              integer *iercod);
 222
 223 static
 224 int mvcvinv_(integer *ncoeff,
 225              doublereal *crvold,
 226              doublereal *crvnew,
 227              integer *iercod);
 228
 229 static
 230 int mvgaus0_(integer *kindic,
 231              doublereal *urootl,
 232              doublereal *hiltab,
 233              integer *nbrval,
 234              integer *iercod);
 235 static
 236 int mvpscr2_(integer *ncoeff,
 237              doublereal *curve2,
 238              doublereal *tparam,
 239              doublereal *pntcrb);
 240
 241 static
 242 int mvpscr3_(integer *ncoeff,
 243              doublereal *curve2,
 244              doublereal *tparam,
 245              doublereal *pntcrb);
 246
 247 static struct {
 248     doublereal eps1, eps2, eps3, eps4;
 249     integer niterm, niterr;
 250 } mmprcsn_;
 251
 252 static struct {
 253     doublereal tdebut, tfinal, verifi, cmherm[576];
 254 } mmcmher_;
 255
 256 //=======================================================================
 257 //function : AdvApp2Var_MathBase::mdsptpt_
 258 //purpose  :
 259 //=======================================================================
 260 int AdvApp2Var_MathBase::mdsptpt_(integer *ndimen,
 261                                   doublereal *point1,
 262                                   doublereal *point2,
 263                                   doublereal *distan)
 264
 265 {
 266   integer c__8 = 8;
 267   /* System generated locals */
 268   integer i__1;
 269   doublereal d__1;
 270
 271   /* Local variables */
 272   integer i__;
 273   doublereal* differ = 0;
 274   integer  ier;
 275   intptr_t iofset, j;
 276
 277 /* **********************************************************************
 278 */
 279
 280 /*     FUNCTION : */
 281 /*     ---------- */
 282 /*        CALCULATE DISTANCE BETWEEN TWO POINTS */
 283
 284 /*     KEYWORDS : */
 285 /*     ----------- */
 286 /*        DISTANCE,POINT. */
 287
 288 /*     INPUT ARGUMENTS : */
 289 /*     ------------------ */
 290 /*        NDIMEN: Space Dimension. */
 291 /*        POINT1: Table of coordinates of the 1st point. */
 292 /*        POINT2: Table of coordinates of the 2nd point. */
 293
 294 /*     OUTPUT ARGUMENTS : */
 295 /*     ------------------- */
 296 /*        DISTAN: Distance between 2 points. */
 297
 298 /*     COMMONS USED   : */
 299 /*     ---------------- */
 300
 301 /*     REFERENCES CALLED   : */
 302 /*     ----------------------- */
 303
 304 /*     DESCRIPTION/NOTES/LIMITATIONS : */
 305 /*     ----------------------------------- */
 306 /* > */
 307 /* **********************************************************************
 308 */
 309
 310
 311 /* ***********************************************************************
 312  */
 313 /*                      INITIALISATION */
 314 /* ***********************************************************************
 315  */
 316
 317     /* Parameter adjustment */
 318     --point2;
 319     --point1;
 320
 321     /* Function Body */
 322     iofset = 0;
 323     ier = 0;
 324
 325 /* ***********************************************************************
 326  */
 327 /*                     TRAITEMENT */
 328 /* ***********************************************************************
 329  */
 330
 331     AdvApp2Var_SysBase anAdvApp2Var_SysBase;
 332     if (*ndimen > 100) {
 333         anAdvApp2Var_SysBase.mcrrqst_(&c__8, ndimen, differ, &iofset, &ier);
 334     }
 335
 336 /* --- If allocation is refused, the trivial method is applied. */
 337
 338     if (ier > 0) {
 339
 340         *distan = 0.;
 341         i__1 = *ndimen;
 342         for (i__ = 1; i__ <= i__1; ++i__) {
 343 /* Computing 2nd power */
 344             d__1 = point1[i__] - point2[i__];
 345             *distan += d__1 * d__1;
 346         }
 347         *distan = sqrt(*distan);
 348
 349 /* --- Otherwise MZSNORM is used to minimize the risks of overflow
 350 */
 351
 352     } else {
 353         i__1 = *ndimen;
 354         for (i__ = 1; i__ <= i__1; ++i__) {
 355             j=iofset + i__ - 1;
 356             differ[j] = point2[i__] - point1[i__];
 357         }
 358
 359         *distan = AdvApp2Var_MathBase::mzsnorm_(ndimen, &differ[iofset]);
 360
 361     }
 362
 363 /* ***********************************************************************
 364  */
 365 /*                   RETURN CALLING PROGRAM */
 366 /* ***********************************************************************
 367  */
 368
 369 /* --- Dynamic Desallocation */
 370
 371     if (iofset != 0) {
 372         anAdvApp2Var_SysBase.mcrdelt_(&c__8, ndimen, differ, &iofset, &ier);
 373     }
 374
 375  return 0 ;
 376 } /* mdsptpt_ */
 377
 378 //=======================================================================
 379 //function : mfac_
 380 //purpose  :
 381 //=======================================================================
 382 int mfac_(doublereal *f,
 383           integer *n)
 384
 385 {
 386     /* System generated locals */
 387     integer i__1;
 388
 389     /* Local variables */
 390     integer i__;
 391
 392 /*    FORTRAN CONFORME AU TEXT */
 393 /*     CALCUL DE MFACTORIEL N */
 394     /* Parameter adjustments */
 395     --f;
 396
 397     /* Function Body */
 398     f[1] = (float)1.;
 399     i__1 = *n;
 400     for (i__ = 2; i__ <= i__1; ++i__) {
 401 /* L10: */
 402         f[i__] = i__ * f[i__ - 1];
 403     }
 404     return 0;
 405 } /* mfac_ */
 406
 407 //=======================================================================
 408 //function : AdvApp2Var_MathBase::mmapcmp_
 409 //purpose  :
 410 //=======================================================================
 411 int AdvApp2Var_MathBase::mmapcmp_(integer *ndim,
 412                                   integer *ncofmx,
 413                                   integer *ncoeff,
 414                                   doublereal *crvold,
 415                                   doublereal *crvnew)
 416
 417 {
 418   /* System generated locals */
 419   integer crvold_dim1, crvold_offset, crvnew_dim1, crvnew_offset, i__1,
 420   i__2;
 421
 422   /* Local variables */
 423   integer ipair, nd, ndegre, impair, ibb, idg;
 424   //extern  int  mgsomsg_();//mgenmsg_(),
 425
 426 /* **********************************************************************
 427 */
 428
 429 /*     FUNCTION : */
 430 /*     ---------- */
 431 /*        Compression of curve CRVOLD in a table of  */
 432 /*        coeff. of even : CRVNEW(*,0,*) */
 433 /*        and uneven range : CRVNEW(*,1,*). */
 434
 435 /*     KEYWORDS : */
 436 /*     ----------- */
 437 /*        COMPRESSION,CURVE. */
 438
 439 /*     INPUT ARGUMENTS : */
 440 /*     ------------------ */
 441 /*     NDIM   : Space Dimension. */
 442 /*     NCOFMX : Max nb of coeff. of the curve to compress. */
 443 /*     NCOEFF : Max nb of coeff. of the compressed curve. */
 444 /*     CRVOLD : The curve (0:NCOFMX-1,NDIM) to compress. */
 445
 446 /*     OUTPUT ARGUMENTS : */
 447 /*     ------------------- */
 448 /*     CRVNEW : Curve compacted in (0:(NCOEFF-1)/2,0,NDIM) (containing
 449 */
 450 /*              even terms) and in (0:(NCOEFF-1)/2,1,NDIM) */
 451 /*              (containing uneven terms). */
 452
 453 /*     COMMONS USED   : */
 454 /*     ---------------- */
 455
 456 /*     REFERENCES CALLED   : */
 457 /*     ----------------------- */
 458
 459 /*     DESCRIPTION/NOTES/LIMITATIONS : */
 460 /*     ----------------------------------- */
 461 /*     This routine is useful to prepare coefficients of a */
 462 /*     curve in an orthogonal base (Legendre or Jacobi) before */
 463 /*     calculating the coefficients in the canonical; base [-1,1] by */
 464 /*     MMJACAN. */
 465 /* ***********************************************************************
 466  */
 467
 468 /*   Name of the routine */
 469
 470     /* Parameter adjustments */
 471     crvold_dim1 = *ncofmx;
 472     crvold_offset = crvold_dim1;
 473     crvold -= crvold_offset;
 474     crvnew_dim1 = (*ncoeff - 1) / 2 + 1;
 475     crvnew_offset = crvnew_dim1 << 1;
 476     crvnew -= crvnew_offset;
 477
 478     /* Function Body */
 479     ibb = AdvApp2Var_SysBase::mnfndeb_();
 480     if (ibb >= 3) {
 481         AdvApp2Var_SysBase::mgenmsg_("MMAPCMP", 7L);
 482     }
 483
 484     ndegre = *ncoeff - 1;
 485     i__1 = *ndim;
 486     for (nd = 1; nd <= i__1; ++nd) {
 487         ipair = 0;
 488         i__2 = ndegre / 2;
 489         for (idg = 0; idg <= i__2; ++idg) {
 490             crvnew[idg + (nd << 1) * crvnew_dim1] = crvold[ipair + nd *
 491                     crvold_dim1];
 492             ipair += 2;
 493 /* L200: */
 494         }
 495         if (ndegre < 1) {
 496             goto L400;
 497         }
 498         impair = 1;
 499         i__2 = (ndegre - 1) / 2;
 500         for (idg = 0; idg <= i__2; ++idg) {
 501             crvnew[idg + ((nd << 1) + 1) * crvnew_dim1] = crvold[impair + nd *
 502                      crvold_dim1];
 503             impair += 2;
 504 /* L300: */
 505         }
 506
 507 L400:
 508 /* L100: */
 509         ;
 510     }
 511
 512 /* ---------------------------------- The end ---------------------------
 513 */
 514
 515     if (ibb >= 3) {
 516         AdvApp2Var_SysBase::mgsomsg_("MMAPCMP", 7L);
 517     }
 518     return 0;
 519 } /* mmapcmp_ */
 520
 521 //=======================================================================
 522 //function : mmaper0_
 523 //purpose  :
 524 //=======================================================================
 525 int mmaper0_(integer *ncofmx,
 526              integer *ndimen,
 527              integer *ncoeff,
 528              doublereal *crvlgd,
 529              integer *ncfnew,
 530              doublereal *ycvmax,
 531              doublereal *errmax)
 532
 533 {
 534   /* System generated locals */
 535   integer crvlgd_dim1, crvlgd_offset, i__1, i__2;
 536   doublereal d__1;
 537
 538   /* Local variables */
 539   integer ncut;
 540   doublereal bidon;
 541   integer ii, nd;
 542
 543 /* ***********************************************************************
 544  */
 545
 546 /*     FUNCTION : */
 547 /*     ---------- */
 548 /*        Calculate the max error of approximation done when */
 549 /*        only the first NCFNEW coefficients of a curve are preserved.
 550 */
 551 /*        Degree NCOEFF-1 written in the base of Legendre (Jacobi */
 552 /*        of  order 0). */
 553
 554 /*     KEYWORDS : */
 555 /*     ----------- */
 556 /*        LEGENDRE,POLYGON,APPROXIMATION,ERROR. */
 557
 558 /*     INPUT ARGUMENTS : */
 559 /*     ------------------ */
 560 /*        NCOFMX : Max. degree of the curve. */
 561 /*        NDIMEN : Space dimension. */
 562 /*        NCOEFF : Degree +1 of the curve. */
 563 /*        CRVLGD : Curve the degree which of should be lowered. */
 564 /*        NCFNEW : Degree +1 of the resulting polynom. */
 565
 566 /*     OUTPUT ARGUMENTS : */
 567 /*     ------------------- */
 568 /*        YCVMAX : Auxiliary Table (max error on each dimension).
 569 */
 570 /*        ERRMAX : Precision of the approximation. */
 571
 572 /*     COMMONS USED   : */
 573 /*     ---------------- */
 574
 575 /*     REFERENCES CALLED   : */
 576 /*     ----------------------- */
 577
 578 /*     DESCRIPTION/NOTES/LIMITATIONS : */
 579 /*     ----------------------------------- */
 580 /* ***********************************************************************
 581  */
 582
 583
 584 /* ------------------- Init to calculate an error -----------------------
 585 */
 586
 587     /* Parameter adjustments */
 588     --ycvmax;
 589     crvlgd_dim1 = *ncofmx;
 590     crvlgd_offset = crvlgd_dim1 + 1;
 591     crvlgd -= crvlgd_offset;
 592
 593     /* Function Body */
 594     i__1 = *ndimen;
 595     for (ii = 1; ii <= i__1; ++ii) {
 596         ycvmax[ii] = 0.;
 597 /* L100: */
 598     }
 599
 600 /* ------ Minimum that can be reached : Stop at 1 or NCFNEW ------
 601 */
 602
 603     ncut = 1;
 604     if (*ncfnew + 1 > ncut) {
 605         ncut = *ncfnew + 1;
 606     }
 607
 608 /* -------------- Elimination of high degree coefficients-----------
 609 */
 610 /* ----------- Loop on the series of Legendre: NCUT --> NCOEFF --------
 611 */
 612
 613     i__1 = *ncoeff;
 614     for (ii = ncut; ii <= i__1; ++ii) {
 615 /*   Factor of renormalization (Maximum of Li(t)). */
 616         bidon = ((ii - 1) * 2. + 1.) / 2.;
 617         bidon = sqrt(bidon);
 618
 619         i__2 = *ndimen;
 620         for (nd = 1; nd <= i__2; ++nd) {
 621             ycvmax[nd] += (d__1 = crvlgd[ii + nd * crvlgd_dim1], advapp_abs(d__1)) *
 622                     bidon;
 623 /* L310: */
 624         }
 625 /* L300: */
 626     }
 627
 628 /* -------------- The error is the norm of the vector error ---------------
 629 */
 630
 631     *errmax = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
 632
 633 /* --------------------------------- Fin --------------------------------
 634 */
 635
 636     return 0;
 637 } /* mmaper0_ */
 638
 639 //=======================================================================
 640 //function : mmaper2_
 641 //purpose  :
 642 //=======================================================================
 643 int mmaper2_(integer *ncofmx,
 644              integer *ndimen,
 645              integer *ncoeff,
 646              doublereal *crvjac,
 647              integer *ncfnew,
 648              doublereal *ycvmax,
 649              doublereal *errmax)
 650
 651 {
 652   /* Initialized data */
 653
 654     static doublereal xmaxj[57] = { .9682458365518542212948163499456,
 655             .986013297183269340427888048593603,
 656             1.07810420343739860362585159028115,
 657             1.17325804490920057010925920756025,
 658             1.26476561266905634732910520370741,
 659             1.35169950227289626684434056681946,
 660             1.43424378958284137759129885012494,
 661             1.51281316274895465689402798226634,
 662             1.5878364329591908800533936587012,
 663             1.65970112228228167018443636171226,
 664             1.72874345388622461848433443013543,
 665             1.7952515611463877544077632304216,
 666             1.85947199025328260370244491818047,
 667             1.92161634324190018916351663207101,
 668             1.98186713586472025397859895825157,
 669             2.04038269834980146276967984252188,
 670             2.09730119173852573441223706382076,
 671             2.15274387655763462685970799663412,
 672             2.20681777186342079455059961912859,
 673             2.25961782459354604684402726624239,
 674             2.31122868752403808176824020121524,
 675             2.36172618435386566570998793688131,
 676             2.41117852396114589446497298177554,
 677             2.45964731268663657873849811095449,
 678             2.50718840313973523778244737914028,
 679             2.55385260994795361951813645784034,
 680             2.59968631659221867834697883938297,
 681             2.64473199258285846332860663371298,
 682             2.68902863641518586789566216064557,
 683             2.73261215675199397407027673053895,
 684             2.77551570192374483822124304745691,
 685             2.8177699459714315371037628127545,
 686             2.85940333797200948896046563785957,
 687             2.90044232019793636101516293333324,
 688             2.94091151970640874812265419871976,
 689             2.98083391718088702956696303389061,
 690             3.02023099621926980436221568258656,
 691             3.05912287574998661724731962377847,
 692             3.09752842783622025614245706196447,
 693             3.13546538278134559341444834866301,
 694             3.17295042316122606504398054547289,
 695             3.2099992681699613513775259670214,
 696             3.24662674946606137764916854570219,
 697             3.28284687953866689817670991319787,
 698             3.31867291347259485044591136879087,
 699             3.35411740487202127264475726990106,
 700             3.38919225660177218727305224515862,
 701             3.42390876691942143189170489271753,
 702             3.45827767149820230182596660024454,
 703             3.49230918177808483937957161007792,
 704             3.5260130200285724149540352829756,
 705             3.55939845146044235497103883695448,
 706             3.59247431368364585025958062194665,
 707             3.62524904377393592090180712976368,
 708             3.65773070318071087226169680450936,
 709             3.68992700068237648299565823810245,
 710             3.72184531357268220291630708234186 };
 711
 712     /* System generated locals */
 713     integer crvjac_dim1, crvjac_offset, i__1, i__2;
 714     doublereal d__1;
 715
 716     /* Local variables */
 717     integer idec, ncut;
 718     doublereal bidon;
 719     integer ii, nd;
 720
 721
 722
 723 /* ***********************************************************************
 724  */
 725
 726 /*     FONCTION : */
 727 /*     ---------- */
 728 /*        Calculate max approximation error i faite lorsque l' on */
 729 /*        ne conserve que les premiers NCFNEW coefficients d' une courbe
 730 */
 731 /*        de degre NCOEFF-1 ecrite dans la base de Jacobi d' ordre 2. */
 732
 733 /*     KEYWORDS : */
 734 /*     ----------- */
 735 /*        JACOBI, POLYGON, APPROXIMATION, ERROR. */
 736 /**/
 737 /*  INPUT ARGUMENTS : */
 738 /*     ------------------ */
 739 /*        NCOFMX : Max. degree of the curve. */
 740 /*        NDIMEN : Space dimension. */
 741 /*        NCOEFF : Degree +1 of the curve. */
 742 /*        CRVLGD : Curve the degree which of should be lowered. */
 743 /*        NCFNEW : Degree +1 of the resulting polynom. */
 744
 745 /*     OUTPUT ARGUMENTS : */
 746 /*     ------------------- */
 747 /*        YCVMAX : Auxiliary Table (max error on each dimension).
 748 */
 749 /*        ERRMAX : Precision of the approximation. */
 750
 751 /*     COMMONS USED   : */
 752 /*     ---------------- */
 753
 754 /*     REFERENCES CALLED   : */
 755 /*     ----------------------- */
 756 /*     DESCRIPTION/NOTES/LIMITATIONS : */
 757 /*     ----------------------------------- */
 758
 759
 760
 761 /* ------------------ Table of maximums of (1-t2)*Ji(t) ----------------
 762 */
 763
 764     /* Parameter adjustments */
 765     --ycvmax;
 766     crvjac_dim1 = *ncofmx;
 767     crvjac_offset = crvjac_dim1 + 1;
 768     crvjac -= crvjac_offset;
 769
 770     /* Function Body */
 771
 772
 773
 774 /* ------------------- Init for error  calculation -----------------------
 775 */
 776
 777     i__1 = *ndimen;
 778     for (ii = 1; ii <= i__1; ++ii) {
 779         ycvmax[ii] = 0.;
 780 /* L100: */
 781     }
 782
 783 /* ------ Min. Degree that can be attained : Stop at 3 or NCFNEW ------
 784 */
 785
 786     idec = 3;
 787 /* Computing MAX */
 788     i__1 = idec, i__2 = *ncfnew + 1;
 789     ncut = advapp_max(i__1,i__2);
 790
 791 /* -------------- Removal of coefficients of high degree -----------
 792 */
 793 /* ----------- Loop on the series of Jacobi :NCUT --> NCOEFF ----------
 794 */
 795
 796     i__1 = *ncoeff;
 797     for (ii = ncut; ii <= i__1; ++ii) {
 798 /*   Factor of renormalization. */
 799         bidon = xmaxj[ii - idec];
 800         i__2 = *ndimen;
 801         for (nd = 1; nd <= i__2; ++nd) {
 802             ycvmax[nd] += (d__1 = crvjac[ii + nd * crvjac_dim1], advapp_abs(d__1)) *
 803                     bidon;
 804 /* L310: */
 805         }
 806 /* L300: */
 807     }
 808
 809 /* -------------- The error is the norm of the vector error ---------------
 810 */
 811
 812     *errmax = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
 813
 814 /* --------------------------------- Fin --------------------------------
 815 */
 816
 817     return 0;
 818 } /* mmaper2_ */
 819
 820 /* MAPER4.f -- translated by f2c (version 19960827).
 821    You must link the resulting object file with the libraries:
 822         -lf2c -lm   (in that order)
 823 */
 824
 825 /* Subroutine */
 826 //=======================================================================
 827 //function : mmaper4_
 828 //purpose  :
 829 //=======================================================================
 830 int mmaper4_(integer *ncofmx,
 831              integer *ndimen,
 832              integer *ncoeff,
 833              doublereal *crvjac,
 834              integer *ncfnew,
 835              doublereal *ycvmax,
 836              doublereal *errmax)
 837 {
 838     /* Initialized data */
 839
 840     static doublereal xmaxj[55] = { 1.1092649593311780079813740546678,
 841             1.05299572648705464724876659688996,
 842             1.0949715351434178709281698645813,
 843             1.15078388379719068145021100764647,
 844             1.2094863084718701596278219811869,
 845             1.26806623151369531323304177532868,
 846             1.32549784426476978866302826176202,
 847             1.38142537365039019558329304432581,
 848             1.43575531950773585146867625840552,
 849             1.48850442653629641402403231015299,
 850             1.53973611681876234549146350844736,
 851             1.58953193485272191557448229046492,
 852             1.63797820416306624705258190017418,
 853             1.68515974143594899185621942934906,
 854             1.73115699602477936547107755854868,
 855             1.77604489805513552087086912113251,
 856             1.81989256661534438347398400420601,
 857             1.86276344480103110090865609776681,
 858             1.90471563564740808542244678597105,
 859             1.94580231994751044968731427898046,
 860             1.98607219357764450634552790950067,
 861             2.02556989246317857340333585562678,
 862             2.06433638992049685189059517340452,
 863             2.10240936014742726236706004607473,
 864             2.13982350649113222745523925190532,
 865             2.17661085564771614285379929798896,
 866             2.21280102016879766322589373557048,
 867             2.2484214321456956597803794333791,
 868             2.28349755104077956674135810027654,
 869             2.31805304852593774867640120860446,
 870             2.35210997297725685169643559615022,
 871             2.38568889602346315560143377261814,
 872             2.41880904328694215730192284109322,
 873             2.45148841120796359750021227795539,
 874             2.48374387161372199992570528025315,
 875             2.5155912654873773953959098501893,
 876             2.54704548720896557684101746505398,
 877             2.57812056037881628390134077704127,
 878             2.60882970619319538196517982945269,
 879             2.63918540521920497868347679257107,
 880             2.66919945330942891495458446613851,
 881             2.69888301230439621709803756505788,
 882             2.72824665609081486737132853370048,
 883             2.75730041251405791603760003778285,
 884             2.78605380158311346185098508516203,
 885             2.81451587035387403267676338931454,
 886             2.84269522483114290814009184272637,
 887             2.87060005919012917988363332454033,
 888             2.89823818258367657739520912946934,
 889             2.92561704377132528239806135133273,
 890             2.95274375377994262301217318010209,
 891             2.97962510678256471794289060402033,
 892             3.00626759936182712291041810228171,
 893             3.03267744830655121818899164295959,
 894             3.05886060707437081434964933864149 };
 895
 896     /* System generated locals */
 897     integer crvjac_dim1, crvjac_offset, i__1, i__2;
 898     doublereal d__1;
 899
 900     /* Local variables */
 901     integer idec, ncut;
 902     doublereal bidon;
 903     integer ii, nd;
 904
 905
 906
 907 /* ***********************************************************************
 908  */
 909
 910 /*     FUNCTION : */
 911 /*     ---------- */
 912 /*        Calculate the max. error of approximation made when  */
 913 /*        only first NCFNEW coefficients of a curve are preserved
 914 */
 915 /*        degree NCOEFF-1 is written in the base of Jacobi of order 4. */
 916 /*        KEYWORDS : */
 917 /*     ----------- */
 918 /*        LEGENDRE,POLYGON,APPROXIMATION,ERROR. */
 919
 920 /*     INPUT ARGUMENTS : */
 921 /*     ------------------ */
 922 /*        NCOFMX : Max. degree of the curve. */
 923 /*        NDIMEN : Space dimension. */
 924 /*        NCOEFF : Degree +1 of the curve. */
 925 /*        CRVJAC : Curve the degree which of should be lowered. */
 926 /*        NCFNEW : Degree +1 of the resulting polynom. */
 927
 928 /*     OUTPUT ARGUMENTS : */
 929 /*     ------------------- */
 930 /*        YCVMAX : Auxiliary Table (max error on each dimension).
 931 */
 932 /*        ERRMAX : Precision of the approximation. */
 933
 934 /*     COMMONS USED   : */
 935 /*     ---------------- */
 936
 937 /*     REFERENCES CALLED   : */
 938 /*     ----------------------- */
 939
 940 /*     DESCRIPTION/NOTES/LIMITATIONS : */
 941
 942
 943 /* ***********************************************************************
 944  */
 945
 946
 947 /* ---------------- Table of maximums of ((1-t2)2)*Ji(t) ---------------
 948 */
 949
 950     /* Parameter adjustments */
 951     --ycvmax;
 952     crvjac_dim1 = *ncofmx;
 953     crvjac_offset = crvjac_dim1 + 1;
 954     crvjac -= crvjac_offset;
 955
 956     /* Function Body */
 957
 958
 959
 960 /* ------------------- Init for error calculation -----------------------
 961 */
 962
 963     i__1 = *ndimen;
 964     for (ii = 1; ii <= i__1; ++ii) {
 965         ycvmax[ii] = 0.;
 966 /* L100: */
 967     }
 968
 969 /* ------ Min. Degree that can be attained : Stop at 5 or NCFNEW ------
 970 */
 971
 972     idec = 5;
 973 /* Computing MAX */
 974     i__1 = idec, i__2 = *ncfnew + 1;
 975     ncut = advapp_max(i__1,i__2);
 976
 977 /* -------------- Removal of high degree coefficients -----------
 978 */
 979 /* ----------- Loop on the series of Jacobi :NCUT --> NCOEFF ----------
 980 */
 981
 982     i__1 = *ncoeff;
 983     for (ii = ncut; ii <= i__1; ++ii) {
 984 /*   Factor of renormalisation. */
 985         bidon = xmaxj[ii - idec];
 986         i__2 = *ndimen;
 987         for (nd = 1; nd <= i__2; ++nd) {
 988             ycvmax[nd] += (d__1 = crvjac[ii + nd * crvjac_dim1], advapp_abs(d__1)) *
 989                     bidon;
 990 /* L310: */
 991         }
 992 /* L300: */
 993     }
 994
 995 /* -------------- The error is the norm of the error vector ---------------
 996 */
 997
 998     *errmax = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
 999
1000 /* --------------------------------- End --------------------------------
1001 */
1002
1003     return 0;
1004 } /* mmaper4_ */
1005
1006 //=======================================================================
1007 //function : mmaper6_
1008 //purpose  :
1009 //=======================================================================
1010 int mmaper6_(integer *ncofmx,
1011              integer *ndimen,
1012              integer *ncoeff,
1013              doublereal *crvjac,
1014              integer *ncfnew,
1015              doublereal *ycvmax,
1016              doublereal *errmax)
1017
1018 {
1019     /* Initialized data */
1020
1021     static doublereal xmaxj[53] = { 1.21091229812484768570102219548814,
1022             1.11626917091567929907256116528817,
1023             1.1327140810290884106278510474203,
1024             1.1679452722668028753522098022171,
1025             1.20910611986279066645602153641334,
1026             1.25228283758701572089625983127043,
1027             1.29591971597287895911380446311508,
1028             1.3393138157481884258308028584917,
1029             1.3821288728999671920677617491385,
1030             1.42420414683357356104823573391816,
1031             1.46546895108549501306970087318319,
1032             1.50590085198398789708599726315869,
1033             1.54550385142820987194251585145013,
1034             1.58429644271680300005206185490937,
1035             1.62230484071440103826322971668038,
1036             1.65955905239130512405565733793667,
1037             1.69609056468292429853775667485212,
1038             1.73193098017228915881592458573809,
1039             1.7671112206990325429863426635397,
1040             1.80166107681586964987277458875667,
1041             1.83560897003644959204940535551721,
1042             1.86898184653271388435058371983316,
1043             1.90180515174518670797686768515502,
1044             1.93410285411785808749237200054739,
1045             1.96589749778987993293150856865539,
1046             1.99721027139062501070081653790635,
1047             2.02806108474738744005306947877164,
1048             2.05846864831762572089033752595401,
1049             2.08845055210580131460156962214748,
1050             2.11802334209486194329576724042253,
1051             2.14720259305166593214642386780469,
1052             2.17600297710595096918495785742803,
1053             2.20443832785205516555772788192013,
1054             2.2325216999457379530416998244706,
1055             2.2602654243075083168599953074345,
1056             2.28768115912702794202525264301585,
1057             2.3147799369092684021274946755348,
1058             2.34157220782483457076721300512406,
1059             2.36806787963276257263034969490066,
1060             2.39427635443992520016789041085844,
1061             2.42020656255081863955040620243062,
1062             2.44586699364757383088888037359254,
1063             2.47126572552427660024678584642791,
1064             2.49641045058324178349347438430311,
1065             2.52130850028451113942299097584818,
1066             2.54596686772399937214920135190177,
1067             2.5703922285006754089328998222275,
1068             2.59459096001908861492582631591134,
1069             2.61856915936049852435394597597773,
1070             2.64233265984385295286445444361827,
1071             2.66588704638685848486056711408168,
1072             2.68923766976735295746679957665724,
1073             2.71238965987606292679677228666411 };
1074
1075     /* System generated locals */
1076     integer crvjac_dim1, crvjac_offset, i__1, i__2;
1077     doublereal d__1;
1078
1079     /* Local variables */
1080     integer idec, ncut;
1081     doublereal bidon;
1082     integer ii, nd;
1083
1084
1085
1086 /* ***********************************************************************
1087  */
1088 /*     FUNCTION : */
1089 /*     ---------- */
1090 /*        Calculate the max. error of approximation made when  */
1091 /*        only first NCFNEW coefficients of a curve are preserved
1092 */
1093 /*        degree NCOEFF-1 is written in the base of Jacobi of order 6. */
1094 /*        KEYWORDS : */
1095 /*     ----------- */
1096 /*        JACOBI,POLYGON,APPROXIMATION,ERROR. */
1097
1098 /*     INPUT ARGUMENTS : */
1099 /*     ------------------ */
1100 /*        NCOFMX : Max. degree of the curve. */
1101 /*        NDIMEN : Space dimension. */
1102 /*        NCOEFF : Degree +1 of the curve. */
1103 /*        CRVJAC : Curve the degree which of should be lowered. */
1104 /*        NCFNEW : Degree +1 of the resulting polynom. */
1105
1106 /*     OUTPUT ARGUMENTS : */
1107 /*     ------------------- */
1108 /*        YCVMAX : Auxiliary Table (max error on each dimension).
1109 */
1110 /*        ERRMAX : Precision of the approximation. */
1111
1112 /*     COMMONS USED   : */
1113 /*     ---------------- */
1114
1115 /*     REFERENCES CALLED   : */
1116 /*     ----------------------- */
1117
1118 /*     DESCRIPTION/NOTES/LIMITATIONS : */
1119 /* > */
1120 /* ***********************************************************************
1121  */
1122
1123
1124 /* ---------------- Table of maximums of ((1-t2)3)*Ji(t) ---------------
1125 */
1126
1127     /* Parameter adjustments */
1128     --ycvmax;
1129     crvjac_dim1 = *ncofmx;
1130     crvjac_offset = crvjac_dim1 + 1;
1131     crvjac -= crvjac_offset;
1132
1133     /* Function Body */
1134
1135
1136
1137 /* ------------------- Init for error calculation -----------------------
1138 */
1139
1140     i__1 = *ndimen;
1141     for (ii = 1; ii <= i__1; ++ii) {
1142         ycvmax[ii] = 0.;
1143 /* L100: */
1144     }
1145
1146 /* ------ Min Degree that can be attained : Stop at 3 or NCFNEW ------
1147 */
1148
1149     idec = 7;
1150 /* Computing MAX */
1151     i__1 = idec, i__2 = *ncfnew + 1;
1152     ncut = advapp_max(i__1,i__2);
1153
1154 /* -------------- Removal of high degree coefficients -----------
1155 */
1156 /* ----------- Loop on the series of Jacobi :NCUT --> NCOEFF ----------
1157 */
1158
1159     i__1 = *ncoeff;
1160     for (ii = ncut; ii <= i__1; ++ii) {
1161 /*   Factor of renormalization. */
1162         bidon = xmaxj[ii - idec];
1163         i__2 = *ndimen;
1164         for (nd = 1; nd <= i__2; ++nd) {
1165             ycvmax[nd] += (d__1 = crvjac[ii + nd * crvjac_dim1], advapp_abs(d__1)) *
1166                     bidon;
1167 /* L310: */
1168         }
1169 /* L300: */
1170     }
1171
1172 /* -------------- The error is the norm of the vector error ---------------
1173 */
1174
1175     *errmax = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
1176
1177 /* --------------------------------- END --------------------------------
1178 */
1179
1180     return 0;
1181 } /* mmaper6_ */
1182
1183 //=======================================================================
1184 //function : AdvApp2Var_MathBase::mmaperx_
1185 //purpose  :
1186 //=======================================================================
1187 int AdvApp2Var_MathBase::mmaperx_(integer *ncofmx,
1188                                   integer *ndimen,
1189                                   integer *ncoeff,
1190                                   integer *iordre,
1191                                   doublereal *crvjac,
1192                                   integer *ncfnew,
1193                                   doublereal *ycvmax,
1194                                   doublereal *errmax,
1195                                   integer *iercod)
1196
1197 {
1198   /* System generated locals */
1199   integer crvjac_dim1, crvjac_offset;
1200
1201   /* Local variables */
1202   integer jord;
1203
1204 /* **********************************************************************
1205 */
1206 /*     FUNCTION : */
1207 /*     ---------- */
1208 /*        Calculate the max. error of approximation made when  */
1209 /*        only first NCFNEW coefficients of a curve are preserved
1210 */
1211 /*        degree NCOEFF-1 is written in the base of Jacobi of order IORDRE. */
1212 /*        KEYWORDS : */
1213 /*     ----------- */
1214 /*        JACOBI,LEGENDRE,POLYGON,APPROXIMATION,ERROR. */
1215
1216 /*     INPUT ARGUMENTS : */
1217 /*     ------------------ */
1218 /*        NCOFMX : Max. degree of the curve. */
1219 /*        NDIMEN : Space dimension. */
1220 /*        NCOEFF : Degree +1 of the curve. */
1221 /*        IORDRE : Order of continuity at the extremities. */
1222 /*        CRVJAC : Curve the degree which of should be lowered. */
1223 /*        NCFNEW : Degree +1 of the resulting polynom. */
1224
1225 /*     OUTPUT ARGUMENTS : */
1226 /*     ------------------- */
1227 /*        YCVMAX : Auxiliary Table (max error on each dimension).
1228 */
1229 /*        ERRMAX : Precision of the approximation. */
1230 /*        IERCOD = 0, OK */
1231 /*               = 1, order of constraints (IORDRE) is not within the */
1232 /*                    autorized values. */
1233 /*     COMMONS USED   : */
1234 /*     ---------------- */
1235
1236 /*     REFERENCES CALLED   : */
1237 /*     ----------------------- */
1238
1239 /*     DESCRIPTION/NOTES/LIMITATIONS : */
1240 /*     ----------------------------------- */
1241 /*     Canceled and replaced MMAPERR. */
1242 /* ***********************************************************************
1243  */
1244
1245
1246     /* Parameter adjustments */
1247     --ycvmax;
1248     crvjac_dim1 = *ncofmx;
1249     crvjac_offset = crvjac_dim1 + 1;
1250     crvjac -= crvjac_offset;
1251
1252     /* Function Body */
1253     *iercod = 0;
1254 /* --> Order of Jacobi polynoms */
1255     jord = ( *iordre + 1) << 1;
1256
1257     if (jord == 0) {
1258         mmaper0_(ncofmx, ndimen, ncoeff, &crvjac[crvjac_offset], ncfnew, &
1259                 ycvmax[1], errmax);
1260     } else if (jord == 2) {
1261         mmaper2_(ncofmx, ndimen, ncoeff, &crvjac[crvjac_offset], ncfnew, &
1262                 ycvmax[1], errmax);
1263     } else if (jord == 4) {
1264         mmaper4_(ncofmx, ndimen, ncoeff, &crvjac[crvjac_offset], ncfnew, &
1265                 ycvmax[1], errmax);
1266     } else if (jord == 6) {
1267         mmaper6_(ncofmx, ndimen, ncoeff, &crvjac[crvjac_offset], ncfnew, &
1268                 ycvmax[1], errmax);
1269     } else {
1270         *iercod = 1;
1271     }
1272
1273 /* ----------------------------------- Fin ------------------------------
1274 */
1275
1276     return 0;
1277 } /* mmaperx_ */
1278
1279 //=======================================================================
1280 //function : mmarc41_
1281 //purpose  :
1282 //=======================================================================
1283  int mmarc41_(integer *ndimax,
1284               integer *ndimen,
1285               integer *ncoeff,
1286               doublereal *crvold,
1287               doublereal *upara0,
1288               doublereal *upara1,
1289               doublereal *crvnew,
1290               integer *iercod)
1291
1292 {
1293   /* System generated locals */
1294     integer crvold_dim1, crvold_offset, crvnew_dim1, crvnew_offset, i__1,
1295     i__2, i__3;
1296
1297     /* Local variables */
1298     integer nboct;
1299     doublereal tbaux[61];
1300     integer nd;
1301     doublereal bid;
1302     integer ncf, ncj;
1303
1304
1305 /*      IMPLICIT DOUBLE PRECISION(A-H,O-Z) */
1306 /*      IMPLICIT INTEGER (I-N) */
1307
1308 /* ***********************************************************************
1309  */
1310
1311 /*     FUNCTION : */
1312 /*     ---------- */
1313 /*     Creation of curve C2(v) defined on (0,1) identic to */
1314 /*     curve C1(u) defined on (U0,U1) (change of parameter */
1315 /*     of a curve). */
1316
1317 /*     KEYWORDS : */
1318 /*     ----------- */
1319 /*        LIMITATION, RESTRICTION, CURVE */
1320
1321 /*     INPUT ARGUMENTS : */
1322 /*     ------------------ */
1323 /*   NDIMAX : Space Dimensioning. */
1324 /*   NDIMEN : Curve Dimension. */
1325 /*   NCOEFF : Nb of coefficients of the curve. */
1326 /*   CRVOLD : Curve to be limited. */
1327 /*   UPARA0     : Min limit of the interval limiting the curve.
1328 */
1329 /*   UPARA1     : Max limit of the interval limiting the curve.
1330 */
1331
1332 /*     OUTPUT ARGUMENTS : */
1333 /*     ------------------- */
1334 /*   CRVNEW : Relimited curve, defined on (0,1) and equal to */
1335 /*            CRVOLD defined on (U0,U1). */
1336 /*   IERCOD : = 0, OK */
1337 /*            =10, Nb of coeff. <1 or > 61. */
1338
1339 /*     COMMONS USED   : */
1340 /*     ---------------- */
1341 /*     REFERENCES CALLED   : */
1342 /*     ---------------------- */
1343 /*     Type  Name */
1344 /*           MAERMSG              MCRFILL              MVCVIN2 */
1345 /*           MVCVINV */
1346
1347 /*     DESCRIPTION/NOTES/LIMITATIONS : */
1348 /*     ----------------------------------- */
1349 /* ---> Algorithm used in this general case is based on the */
1350 /*     following principle  : */
1351 /*        Let S(t) = a0 + a1*t + a2*t**2 + ... of degree NCOEFF-1, and */
1352 /*               U(t) = b0 + b1*t, then the coeff. of */
1353 /*        S(U(t)) are calculated step by step with help of table TBAUX. */
1354 /*        At each step number N (N=2 to NCOEFF), TBAUX(n) contains */
1355 /*        the n-th coefficient of U(t)**N for n=1 to N. (RBD) */
1356 /* ---> Reference : KNUTH, 'The Art of Computer Programming', */
1357 /*                        Vol. 2/'Seminumerical Algorithms', */
1358 /*                        Ex. 11 p:451 et solution p:562. (RBD) */
1359
1360 /* ---> Removal of the input argument CRVOLD by CRVNEW is */
1361 /*     possible, which means that the call : */
1362 /*       CALL MMARC41(NDIMAX,NDIMEN,NCOEFF,CURVE,UPARA0,UPARA1 */
1363 /*                  ,CURVE,IERCOD) */
1364 /*     is absolutely LEGAL. (RBD) */
1365
1366 /* > */
1367 /* **********************************************************************
1368 */
1369
1370 /*   Name of the routine */
1371
1372 /*   Auxiliary table of coefficients of (UPARA1-UPARA0)T+UPARA0  */
1373 /*   with power N=1 to NCOEFF-1. */
1374
1375
1376     /* Parameter adjustments */
1377     crvnew_dim1 = *ndimax;
1378     crvnew_offset = crvnew_dim1 + 1;
1379     crvnew -= crvnew_offset;
1380     crvold_dim1 = *ndimax;
1381     crvold_offset = crvold_dim1 + 1;
1382     crvold -= crvold_offset;
1383
1384     /* Function Body */
1385     *iercod = 0;
1386 /* **********************************************************************
1387 */
1388 /*                CASE WHEN PROCESSING CAN'T BE DONE */
1389 /* **********************************************************************
1390 */
1391     if (*ncoeff > 61 || *ncoeff < 1) {
1392         *iercod = 10;
1393         goto L9999;
1394     }
1395 /* **********************************************************************
1396 */
1397 /*                         IF NO CHANGES */
1398 /* **********************************************************************
1399 */
1400     if (*ndimen == *ndimax && *upara0 == 0. && *upara1 == 1.) {
1401         nboct = (*ndimax << 3) * *ncoeff;
1402         AdvApp2Var_SysBase::mcrfill_(&nboct,
1403                  &crvold[crvold_offset],
1404                  &crvnew[crvnew_offset]);
1405         goto L9999;
1406     }
1407 /* **********************************************************************
1408 */
1409 /*                    INVERSION 3D : FAST PROCESSING */
1410 /* **********************************************************************
1411 */
1412     if (*upara0 == 1. && *upara1 == 0.) {
1413         if (*ndimen == 3 && *ndimax == 3 && *ncoeff <= 21) {
1414             mvcvinv_(ncoeff, &crvold[crvold_offset], &crvnew[crvnew_offset],
1415                     iercod);
1416             goto L9999;
1417         }
1418 /* ******************************************************************
1419 **** */
1420 /*                    INVERSION 2D : FAST PROCESSING */
1421 /* ******************************************************************
1422 **** */
1423         if (*ndimen == 2 && *ndimax == 2 && *ncoeff <= 21) {
1424             mvcvin2_(ncoeff, &crvold[crvold_offset], &crvnew[crvnew_offset],
1425                     iercod);
1426             goto L9999;
1427         }
1428     }
1429 /* **********************************************************************
1430 */
1431 /*                          GENERAL PROCESSING */
1432 /* **********************************************************************
1433 */
1434 /* -------------------------- Initializations ---------------------------
1435 */
1436
1437     i__1 = *ndimen;
1438     for (nd = 1; nd <= i__1; ++nd) {
1439         crvnew[nd + crvnew_dim1] = crvold[nd + crvold_dim1];
1440 /* L100: */
1441     }
1442     if (*ncoeff == 1) {
1443         goto L9999;
1444     }
1445     tbaux[0] = *upara0;
1446     tbaux[1] = *upara1 - *upara0;
1447
1448 /* ----------------------- Calculation of coeff. of CRVNEW ------------------
1449 */
1450
1451     i__1 = *ncoeff - 1;
1452     for (ncf = 2; ncf <= i__1; ++ncf) {
1453
1454 /* ------------ Take into account NCF-th coeff. of CRVOLD --------
1455 ---- */
1456
1457         i__2 = ncf - 1;
1458         for (ncj = 1; ncj <= i__2; ++ncj) {
1459             bid = tbaux[ncj - 1];
1460             i__3 = *ndimen;
1461             for (nd = 1; nd <= i__3; ++nd) {
1462                 crvnew[nd + ncj * crvnew_dim1] += crvold[nd + ncf *
1463                         crvold_dim1] * bid;
1464 /* L400: */
1465             }
1466 /* L300: */
1467         }
1468
1469         bid = tbaux[ncf - 1];
1470         i__2 = *ndimen;
1471         for (nd = 1; nd <= i__2; ++nd) {
1472             crvnew[nd + ncf * crvnew_dim1] = crvold[nd + ncf * crvold_dim1] *
1473                     bid;
1474 /* L500: */
1475         }
1476
1477 /* --------- Calculate (NCF+1) coeff. of ((U1-U0)*t + U0)**(NCF) ---
1478 ---- */
1479
1480         bid = *upara1 - *upara0;
1481         tbaux[ncf] = tbaux[ncf - 1] * bid;
1482         for (ncj = ncf; ncj >= 2; --ncj) {
1483             tbaux[ncj - 1] = tbaux[ncj - 1] * *upara0 + tbaux[ncj - 2] * bid;
1484 /* L600: */
1485         }
1486         tbaux[0] *= *upara0;
1487
1488 /* L200: */
1489     }
1490
1491 /* -------------- Take into account the last coeff. of CRVOLD -----------
1492 */
1493
1494     i__1 = *ncoeff - 1;
1495     for (ncj = 1; ncj <= i__1; ++ncj) {
1496         bid = tbaux[ncj - 1];
1497         i__2 = *ndimen;
1498         for (nd = 1; nd <= i__2; ++nd) {
1499             crvnew[nd + ncj * crvnew_dim1] += crvold[nd + *ncoeff *
1500                     crvold_dim1] * bid;
1501 /* L800: */
1502         }
1503 /* L700: */
1504     }
1505     i__1 = *ndimen;
1506     for (nd = 1; nd <= i__1; ++nd) {
1507         crvnew[nd + *ncoeff * crvnew_dim1] = crvold[nd + *ncoeff *
1508                 crvold_dim1] * tbaux[*ncoeff - 1];
1509 /* L900: */
1510     }
1511
1512 /* ---------------------------- The end ---------------------------------
1513 */
1514
1515 L9999:
1516     if (*iercod != 0) {
1517         AdvApp2Var_SysBase::maermsg_("MMARC41", iercod, 7L);
1518     }
1519
1520  return 0 ;
1521 } /* mmarc41_ */
1522
1523 //=======================================================================
1524 //function : AdvApp2Var_MathBase::mmarcin_
1525 //purpose  :
1526 //=======================================================================
1527 int AdvApp2Var_MathBase::mmarcin_(integer *ndimax,
1528                                   integer *ndim,
1529                                   integer *ncoeff,
1530                                   doublereal *crvold,
1531                                   doublereal *u0,
1532                                   doublereal *u1,
1533                                   doublereal *crvnew,
1534                                   integer *iercod)
1535
1536 {
1537   /* System generated locals */
1538   integer crvold_dim1, crvold_offset, crvnew_dim1, crvnew_offset, i__1,
1539   i__2, i__3;
1540   doublereal d__1;
1541
1542   /* Local variables */
1543   doublereal x0, x1;
1544   integer nd;
1545   doublereal tabaux[61];
1546   integer ibb;
1547   doublereal bid;
1548   integer ncf;
1549   integer ncj;
1550   doublereal eps3;
1551
1552
1553
1554 /* **********************************************************************
1555 *//*     FUNCTION : */
1556 /*     ---------- */
1557 /*     Creation of curve C2(v) defined on [U0,U1] identic to */
1558 /*     curve C1(u) defined on [-1,1] (change of parameter */
1559 /*     of a curve) with INVERSION of indices of the resulting table. */
1560
1561 /*     KEYWORDS : */
1562 /*     ----------- */
1563 /*        GENERALIZED LIMITATION, RESTRICTION, INVERSION, CURVE */
1564
1565 /*     INPUT ARGUMENTS : */
1566 /*     ------------------ */
1567 /*   NDIMAX : Maximum Space Dimensioning. */
1568 /*   NDIMEN : Curve Dimension. */
1569 /*   NCOEFF : Nb of coefficients of the curve. */
1570 /*   CRVOLD : Curve to be limited. */
1571 /*   U0     : Min limit of the interval limiting the curve.
1572 */
1573 /*   U1     : Max limit of the interval limiting the curve.
1574 */
1575
1576 /*     OUTPUT ARGUMENTS : */
1577 /*     ------------------- */
1578 /*   CRVNEW : Relimited curve, defined on  [U0,U1] and equal to */
1579 /*            CRVOLD defined on [-1,1]. */
1580 /*   IERCOD : = 0, OK */
1581 /*            =10, Nb of coeff. <1 or > 61. */
1582 /*            =13, the requested interval of variation is null. */
1583 /*     COMMONS USED   : */
1584 /*     ---------------- */
1585 /*     REFERENCES CALLED   : */
1586 /*     ---------------------- */
1587 /*     DESCRIPTION/NOTES/LIMITATIONS : */
1588 /*     ----------------------------------- */
1589 /* > */
1590 /* **********************************************************************
1591 */
1592
1593 /*   Name of the routine */
1594
1595 /*   Auxiliary table of coefficients of X1*T+X0 */
1596 /*   with power N=1 to NCOEFF-1. */
1597
1598
1599     /* Parameter adjustments */
1600     crvnew_dim1 = *ndimax;
1601     crvnew_offset = crvnew_dim1 + 1;
1602     crvnew -= crvnew_offset;
1603     crvold_dim1 = *ncoeff;
1604     crvold_offset = crvold_dim1 + 1;
1605     crvold -= crvold_offset;
1606
1607     /* Function Body */
1608     ibb = AdvApp2Var_SysBase::mnfndeb_();
1609     if (ibb >= 2) {
1610         AdvApp2Var_SysBase::mgenmsg_("MMARCIN", 7L);
1611     }
1612
1613 /* At zero machine it is tested if the output interval is not null */
1614
1615     AdvApp2Var_MathBase::mmveps3_(&eps3);
1616     if ((d__1 = *u1 - *u0, advapp_abs(d__1)) < eps3) {
1617         *iercod = 13;
1618         goto L9999;
1619     }
1620     *iercod = 0;
1621
1622 /* **********************************************************************
1623 */
1624 /*                CASE WHEN THE PROCESSING IS IMPOSSIBLE */
1625 /* **********************************************************************
1626 */
1627     if (*ncoeff > 61 || *ncoeff < 1) {
1628         *iercod = 10;
1629         goto L9999;
1630     }
1631 /* **********************************************************************
1632 */
1633 /*          IF NO CHANGE OF THE INTERVAL OF DEFINITION */
1634 /*          (ONLY INVERSION OF INDICES OF TABLE CRVOLD) */
1635 /* **********************************************************************
1636 */
1637     if (*ndim == *ndimax && *u0 == -1. && *u1 == 1.) {
1638         AdvApp2Var_MathBase::mmcvinv_(ndim, ncoeff, ndim, &crvold[crvold_offset], &crvnew[
1639                 crvnew_offset]);
1640         goto L9999;
1641     }
1642 /* **********************************************************************
1643 */
1644 /*          CASE WHEN THE NEW INTERVAL OF DEFINITION IS [0,1] */
1645 /* **********************************************************************
1646 */
1647     if (*u0 == 0. && *u1 == 1.) {
1648         mmcvstd_(ncoeff, ndimax, ncoeff, ndim, &crvold[crvold_offset], &
1649                 crvnew[crvnew_offset]);
1650         goto L9999;
1651     }
1652 /* **********************************************************************
1653 */
1654 /*                          GENERAL PROCESSING */
1655 /* **********************************************************************
1656 */
1657 /* -------------------------- Initialization ---------------------------
1658 */
1659
1660     x0 = -(*u1 + *u0) / (*u1 - *u0);
1661     x1 = 2. / (*u1 - *u0);
1662     i__1 = *ndim;
1663     for (nd = 1; nd <= i__1; ++nd) {
1664         crvnew[nd + crvnew_dim1] = crvold[nd * crvold_dim1 + 1];
1665 /* L100: */
1666     }
1667     if (*ncoeff == 1) {
1668         goto L9999;
1669     }
1670     tabaux[0] = x0;
1671     tabaux[1] = x1;
1672
1673 /* ----------------------- Calculation of coeff. of CRVNEW ------------------
1674 */
1675
1676     i__1 = *ncoeff - 1;
1677     for (ncf = 2; ncf <= i__1; ++ncf) {
1678
1679 /* ------------ Take into account the NCF-th coeff. of CRVOLD --------
1680 ---- */
1681
1682         i__2 = ncf - 1;
1683         for (ncj = 1; ncj <= i__2; ++ncj) {
1684             bid = tabaux[ncj - 1];
1685             i__3 = *ndim;
1686             for (nd = 1; nd <= i__3; ++nd) {
1687                 crvnew[nd + ncj * crvnew_dim1] += crvold[ncf + nd *
1688                         crvold_dim1] * bid;
1689 /* L400: */
1690             }
1691 /* L300: */
1692         }
1693
1694         bid = tabaux[ncf - 1];
1695         i__2 = *ndim;
1696         for (nd = 1; nd <= i__2; ++nd) {
1697             crvnew[nd + ncf * crvnew_dim1] = crvold[ncf + nd * crvold_dim1] *
1698                     bid;
1699 /* L500: */
1700         }
1701
1702 /* --------- Calculation of (NCF+1) coeff. of [X1*t + X0]**(NCF) --------
1703 ---- */
1704
1705         tabaux[ncf] = tabaux[ncf - 1] * x1;
1706         for (ncj = ncf; ncj >= 2; --ncj) {
1707             tabaux[ncj - 1] = tabaux[ncj - 1] * x0 + tabaux[ncj - 2] * x1;
1708 /* L600: */
1709         }
1710         tabaux[0] *= x0;
1711
1712 /* L200: */
1713     }
1714
1715 /* -------------- Take into account the last coeff. of CRVOLD -----------
1716 */
1717
1718     i__1 = *ncoeff - 1;
1719     for (ncj = 1; ncj <= i__1; ++ncj) {
1720         bid = tabaux[ncj - 1];
1721         i__2 = *ndim;
1722         for (nd = 1; nd <= i__2; ++nd) {
1723             crvnew[nd + ncj * crvnew_dim1] += crvold[*ncoeff + nd *
1724                     crvold_dim1] * bid;
1725 /* L800: */
1726         }
1727 /* L700: */
1728     }
1729     i__1 = *ndim;
1730     for (nd = 1; nd <= i__1; ++nd) {
1731         crvnew[nd + *ncoeff * crvnew_dim1] = crvold[*ncoeff + nd *
1732                 crvold_dim1] * tabaux[*ncoeff - 1];
1733 /* L900: */
1734     }
1735
1736 /* ---------------------------- The end ---------------------------------
1737 */
1738
1739 L9999:
1740     if (*iercod > 0) {
1741         AdvApp2Var_SysBase::maermsg_("MMARCIN", iercod, 7L);
1742     }
1743     if (ibb >= 2) {
1744         AdvApp2Var_SysBase::mgsomsg_("MMARCIN", 7L);
1745     }
1746     return 0;
1747 } /* mmarcin_ */
1748
1749 //=======================================================================
1750 //function : mmatvec_
1751 //purpose  :
1752 //=======================================================================
1753 int mmatvec_(integer *nligne,
1754              integer *,//ncolon,
1755              integer *gposit,
1756              integer *,//gnstoc,
1757              doublereal *gmatri,
1758              doublereal *vecin,
1759              integer *deblig,
1760              doublereal *vecout,
1761              integer *iercod)
1762
1763 {
1764   /* System generated locals */
1765   integer i__1, i__2;
1766
1767   /* Local variables */
1768     logical ldbg;
1769   integer jmin, jmax, i__, j, k;
1770   doublereal somme;
1771   integer aux;
1772
1773
1774 /* ***********************************************************************
1775  */
1776
1777 /*     FUNCTION : */
1778 /*     ---------- */
1779 /*      Produce vector matrix in form of profile */
1780
1781
1782 /*     MOTS CLES : */
1783 /*     ----------- */
1784 /*      RESERVE, MATRIX, PRODUCT, VECTOR, PROFILE */
1785
1786 /*     INPUT ARGUMENTS : */
1787 /*     -------------------- */
1788 /*       NLIGNE : Line number of the matrix of constraints */
1789 /*       NCOLON : Number of column of the matrix of constraints */
1790 /*       GNSTOC: Number of coefficients in the profile of matrix GMATRI */
1791
1792 /*       GPOSIT: Table of positioning of terms of storage */
1793 /*               GPOSIT(1,I) contains the number of terms-1 on the line I */
1794 /*               in the profile of the matrix. */
1795 /*              GPOSIT(2,I) contains the index of storage of diagonal term*/
1796 /*               of line I */
1797 /*               GPOSIT(3,I) contains the index of column of the first term of */
1798 /*                           profile of line I */
1799 /*       GNSTOC: Number of coefficients in the profile of matrix */
1800 /*               GMATRI */
1801 /*       GMATRI : Matrix of constraints in form of profile */
1802 /*       VECIN  : Input vector */
1803 /*       DEBLIG : Line indexusing which the vector matrix is calculated */
1804 /**/
1805 /*     OUTPUT ARGUMENTS */
1806 /*     --------------------- */
1807 /*       VECOUT : VECTOR PRODUCT */
1808
1809 /*       IERCOD : ERROR CODE */
1810
1811
1812 /*     COMMONS USED : */
1813 /*     ------------------ */
1814
1815
1816 /*     REFERENCES CALLED : */
1817 /*     --------------------- */
1818
1819
1820 /*     DESCRIPTION/NOTES/LIMITATIONS : */
1821 /*     ----------------------------------- */
1822
1823 /* ***********************************************************************
1824  */
1825 /*                            DECLARATIONS */
1826 /* ***********************************************************************
1827  */
1828
1829
1830
1831 /* ***********************************************************************
1832  */
1833 /*                      INITIALISATIONS */
1834 /* ***********************************************************************
1835  */
1836
1837     /* Parameter adjustments */
1838     --vecout;
1839     gposit -= 4;
1840     --vecin;
1841     --gmatri;
1842
1843     /* Function Body */
1844     ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 2;
1845     if (ldbg) {
1846         AdvApp2Var_SysBase::mgenmsg_("MMATVEC", 7L);
1847     }
1848     *iercod = 0;
1849
1850 /* ***********************************************************************
1851  */
1852 /*                    Processing */
1853 /* ***********************************************************************
1854  */
1855     AdvApp2Var_SysBase::mvriraz_(nligne,
1856              &vecout[1]);
1857     i__1 = *nligne;
1858     for (i__ = *deblig; i__ <= i__1; ++i__) {
1859         somme = 0.;
1860         jmin = gposit[i__ * 3 + 3];
1861         jmax = gposit[i__ * 3 + 1] + gposit[i__ * 3 + 3] - 1;
1862         aux = gposit[i__ * 3 + 2] - gposit[i__ * 3 + 1] - jmin + 1;
1863         i__2 = jmax;
1864         for (j = jmin; j <= i__2; ++j) {
1865             k = j + aux;
1866             somme += gmatri[k] * vecin[j];
1867         }
1868         vecout[i__] = somme;
1869     }
1870
1871
1872
1873
1874
1875     goto L9999;
1876
1877 /* ***********************************************************************
1878  */
1879 /*                   ERROR PROCESSING */
1880 /* ***********************************************************************
1881  */
1882
1883
1884
1885
1886 /* ***********************************************************************
1887  */
1888 /*                   RETURN CALLING PROGRAM */
1889 /* ***********************************************************************
1890  */
1891
1892 L9999:
1893
1894 /* ___ DESALLOCATION, ... */
1895
1896     AdvApp2Var_SysBase::maermsg_("MMATVEC", iercod, 7L);
1897     if (ldbg) {
1898         AdvApp2Var_SysBase::mgsomsg_("MMATVEC", 7L);
1899     }
1900
1901  return 0 ;
1902 } /* mmatvec_ */
1903
1904 //=======================================================================
1905 //function : mmbulld_
1906 //purpose  :
1907 //=======================================================================
1908 int AdvApp2Var_MathBase::mmbulld_(integer *nbcoln,
1909                                   integer *nblign,
1910                                   doublereal *dtabtr,
1911                                   integer *numcle)
1912
1913 {
1914   /* System generated locals */
1915   integer dtabtr_dim1, dtabtr_offset, i__1, i__2;
1916
1917   /* Local variables */
1918   logical ldbg;
1919   doublereal daux;
1920   integer nite1, nite2, nchan, i1, i2;
1921
1922 /* ***********************************************************************
1923  */
1924
1925 /*     FUNCTION : */
1926 /*     ---------- */
1927 /*        Parsing of columns of a table of integers in increasing order */
1928 /*     KEYWORDS : */
1929 /*     ----------- */
1930 /*     POINT-ENTRY, PARSING */
1931 /*     INPUT ARGUMENTS : */
1932 /*     -------------------- */
1933 /*       - NBCOLN : Number of columns in the table */
1934 /*       - NBLIGN : Number of lines in the table */
1935 /*       - DTABTR : Table of integers to be parsed */
1936 /*       - NUMCLE : Position of the key on the column */
1937
1938 /*     OUTPUT ARGUMENTS : */
1939 /*     --------------------- */
1940 /*       - DTABTR : Parsed table */
1941
1942 /*     COMMONS USED : */
1943 /*     ------------------ */
1944
1945
1946 /*     REFERENCES CALLED : */
1947 /*     --------------------- */
1948
1949
1950 /*     DESCRIPTION/NOTES/LIMITATIONS : */
1951 /*     ----------------------------------- */
1952 /*     Particularly performant if the table is almost parsed */
1953 /*     In the opposite case it is better to use MVSHELD */
1954 /* ***********************************************************************
1955  */
1956
1957     /* Parameter adjustments */
1958     dtabtr_dim1 = *nblign;
1959     dtabtr_offset = dtabtr_dim1 + 1;
1960     dtabtr -= dtabtr_offset;
1961
1962     /* Function Body */
1963     ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 2;
1964     if (ldbg) {
1965         AdvApp2Var_SysBase::mgenmsg_("MMBULLD", 7L);
1966     }
1967     nchan = 1;
1968     nite1 = *nbcoln;
1969     nite2 = 2;
1970
1971 /* ***********************************************************************
1972  */
1973 /*                     PROCESSING */
1974 /* ***********************************************************************
1975  */
1976
1977 /* ---->ALGORITHM in N^2 / 2 additional iteration */
1978
1979     while(nchan != 0) {
1980
1981 /* ----> Parsing from left to the right */
1982
1983         nchan = 0;
1984         i__1 = nite1;
1985         for (i1 = nite2; i1 <= i__1; ++i1) {
1986             if (dtabtr[*numcle + i1 * dtabtr_dim1] < dtabtr[*numcle + (i1 - 1)
1987                      * dtabtr_dim1]) {
1988                 i__2 = *nblign;
1989                 for (i2 = 1; i2 <= i__2; ++i2) {
1990                     daux = dtabtr[i2 + (i1 - 1) * dtabtr_dim1];
1991                     dtabtr[i2 + (i1 - 1) * dtabtr_dim1] = dtabtr[i2 + i1 *
1992                             dtabtr_dim1];
1993                     dtabtr[i2 + i1 * dtabtr_dim1] = daux;
1994                 }
1995                 if (nchan == 0) {
1996                     nchan = 1;
1997                 }
1998             }
1999         }
2000         --nite1;
2001
2002 /* ----> Parsing from right to the left */
2003
2004         if (nchan != 0) {
2005             nchan = 0;
2006             i__1 = nite2;
2007             for (i1 = nite1; i1 >= i__1; --i1) {
2008                 if (dtabtr[*numcle + i1 * dtabtr_dim1] < dtabtr[*numcle + (i1
2009                         - 1) * dtabtr_dim1]) {
2010                     i__2 = *nblign;
2011                     for (i2 = 1; i2 <= i__2; ++i2) {
2012                         daux = dtabtr[i2 + (i1 - 1) * dtabtr_dim1];
2013                         dtabtr[i2 + (i1 - 1) * dtabtr_dim1] = dtabtr[i2 + i1 *
2014                                  dtabtr_dim1];
2015                         dtabtr[i2 + i1 * dtabtr_dim1] = daux;
2016                     }
2017                     if (nchan == 0) {
2018                         nchan = 1;
2019                     }
2020                 }
2021             }
2022             ++nite2;
2023         }
2024     }
2025
2026
2027     goto L9999;
2028
2029 /* ***********************************************************************
2030  */
2031 /*                   ERROR PROCESSING */
2032 /* ***********************************************************************
2033  */
2034
2035 /* ----> No errors at calling functions, only tests and loops. */
2036
2037 /* ***********************************************************************
2038  */
2039 /*                   RETURN CALLING PROGRAM */
2040 /* ***********************************************************************
2041  */
2042
2043 L9999:
2044
2045     if (ldbg) {
2046         AdvApp2Var_SysBase::mgsomsg_("MMBULLD", 7L);
2047     }
2048
2049  return 0 ;
2050 } /* mmbulld_ */
2051
2052
2053 //=======================================================================
2054 //function : AdvApp2Var_MathBase::mmcdriv_
2055 //purpose  :
2056 //=======================================================================
2057 int AdvApp2Var_MathBase::mmcdriv_(integer *ndimen,
2058                                   integer *ncoeff,
2059                                   doublereal *courbe,
2060                                   integer *ideriv,
2061                                   integer *ncofdv,
2062                                   doublereal *crvdrv)
2063
2064
2065 {
2066   /* System generated locals */
2067   integer courbe_dim1, courbe_offset, crvdrv_dim1, crvdrv_offset, i__1,
2068   i__2;
2069
2070   /* Local variables */
2071   integer i__, j, k;
2072   doublereal mfactk, bid;
2073
2074
2075 /* ***********************************************************************
2076  */
2077
2078 /*     FUNCTION : */
2079 /*     ---------- */
2080 /*     Calculate matrix of a derivate curve of order IDERIV. */
2081 /*     with input parameters other than output parameters. */
2082
2083
2084 /*     KEYWORDS : */
2085 /*     ----------- */
2086 /*     COEFFICIENTS,CURVE,DERIVATE I-EME. */
2087
2088 /*     INPUT ARGUMENTS : */
2089 /*     ------------------ */
2090 /*   NDIMEN  : Space dimension (2 or 3 in general) */
2091 /*   NCOEFF  : Degree +1 of the curve. */
2092 /*   COURBE  : Table of coefficients of the curve. */
2093 /*   IDERIV  : Required order of derivation : 1=1st derivate, etc... */
2094
2095 /*     OUTPUT ARGUMENTS : */
2096 /*     ------------------- */
2097 /*   NCOFDV  : Degree +1 of the derivative of order IDERIV of the curve. */
2098 /*   CRVDRV  : Table of coefficients of the derivative of order IDERIV */
2099 /*            of the curve. */
2100
2101 /*     COMMONS USED   : */
2102 /*     ---------------- */
2103
2104 /*     REFERENCES CALLED   : */
2105 /*     ----------------------- */
2106
2107 /*     DESCRIPTION/NOTES/LIMITATIONS : */
2108 /*     ----------------------------------- */
2109
2110 /* ---> It is possible to take as output argument the curve */
2111 /*     and the number of coeff passed at input by making : */
2112 /*        CALL MMCDRIV(NDIMEN,NCOEFF,COURBE,IDERIV,NCOEFF,COURBE). */
2113 /*     After this call, NCOEFF does the number of coeff of the derived */
2114 /*     curve the coefficients which of are stored in CURVE. */
2115 /*     Attention to the coefficients of CURVE of rank superior to */
2116 /*     NCOEFF : they are not set to zero. */
2117
2118 /* ---> Algorithm : */
2119 /*     The code below was written basing on the following algorithm:
2120 */
2121
2122 /*     Let P(t) = a1 + a2*t + ... an*t**n. Derivate of order k of P */
2123 /*     (containing n-k coefficients) is calculated as follows : */
2124
2125 /*       Pk(t) = a(k+1)*CNP(k,k)*k! */
2126 /*             + a(k+2)*CNP(k+1,k)*k! * t */
2127 /*             . */
2128 /*             . */
2129 /*             . */
2130 /*             + a(n)*CNP(n-1,k)*k! * t**(n-k-1). */
2131 /* ***********************************************************************
2132  */
2133
2134
2135 /* -------------- Case when the order of derivative is  -------------------
2136 */
2137 /* ---------------- greater than the degree of the curve ---------------------
2138 */
2139
2140 /* **********************************************************************
2141 */
2142
2143 /*     FUNCTION : */
2144 /*     ---------- */
2145 /*      Serves to provide the coefficients of binome (Pascal's triangle). */
2146
2147 /*     KEYWORDS : */
2148 /*     ----------- */
2149 /*      Binomial coeff from 0 to 60. read only . init par block data */
2150
2151 /*     DEMSCRIPTION/NOTES/LIMITATIONS : */
2152 /*     ----------------------------------- */
2153 /*     Binomial coefficients form a triangular matrix. */
2154 /*     This matrix is completed in table CNP by its transposition. */
2155 /*     So: CNP(I,J) = CNP(J,I) for I and J = 0, ..., 60. */
2156
2157 /*     Initialization is done by block-data MMLLL09.RES, */
2158 /*     created by program MQINICNP.FOR). */
2159 /* **********************************************************************
2160 */
2161
2162
2163
2164 /* ***********************************************************************
2165  */
2166
2167     /* Parameter adjustments */
2168     crvdrv_dim1 = *ndimen;
2169     crvdrv_offset = crvdrv_dim1 + 1;
2170     crvdrv -= crvdrv_offset;
2171     courbe_dim1 = *ndimen;
2172     courbe_offset = courbe_dim1 + 1;
2173     courbe -= courbe_offset;
2174
2175     /* Function Body */
2176     if (*ideriv >= *ncoeff) {
2177         i__1 = *ndimen;
2178         for (i__ = 1; i__ <= i__1; ++i__) {
2179             crvdrv[i__ + crvdrv_dim1] = 0.;
2180 /* L10: */
2181         }
2182         *ncofdv = 1;
2183         goto L9999;
2184     }
2185 /* **********************************************************************
2186 */
2187 /*                        General processing */
2188 /* **********************************************************************
2189 */
2190 /* --------------------- Calculation of Factorial(IDERIV) ------------------
2191 */
2192
2193     k = *ideriv;
2194     mfactk = 1.;
2195     i__1 = k;
2196     for (i__ = 2; i__ <= i__1; ++i__) {
2197         mfactk *= i__;
2198 /* L50: */
2199     }
2200
2201 /* ------------ Calculation of coeff of the derived of order IDERIV ----------
2202 */
2203 /* ---> Attention :  coefficient binomial C(n,m) is represented in */
2204 /*                 MCCNP by CNP(N+1,M+1). */
2205
2206     i__1 = *ncoeff;
2207     for (j = k + 1; j <= i__1; ++j) {
2208         bid = mmcmcnp_.cnp[j - 1 + k * 61] * mfactk;
2209         i__2 = *ndimen;
2210         for (i__ = 1; i__ <= i__2; ++i__) {
2211             crvdrv[i__ + (j - k) * crvdrv_dim1] = bid * courbe[i__ + j *
2212                     courbe_dim1];
2213 /* L200: */
2214         }
2215 /* L100: */
2216     }
2217
2218     *ncofdv = *ncoeff - *ideriv;
2219
2220 /* -------------------------------- The end -----------------------------
2221 */
2222
2223 L9999:
2224     return 0;
2225 } /* mmcdriv_ */
2226
2227 //=======================================================================
2228 //function : AdvApp2Var_MathBase::mmcglc1_
2229 //purpose  :
2230 //=======================================================================
2231 int AdvApp2Var_MathBase::mmcglc1_(integer *ndimax,
2232                                   integer *ndimen,
2233                                   integer *ncoeff,
2234                                   doublereal *courbe,
2235                                   doublereal *tdebut,
2236                                   doublereal *tfinal,
2237                                   doublereal *epsiln,
2238                                   doublereal *xlongc,
2239                                   doublereal *erreur,
2240                                   integer *iercod)
2241
2242
2243 {
2244   /* System generated locals */
2245   integer courbe_dim1, courbe_offset, i__1;
2246   doublereal d__1;
2247
2248   /* Local variables */
2249   integer ndec;
2250   doublereal tdeb, tfin;
2251   integer iter;
2252   doublereal oldso = 0.;
2253   integer itmax;
2254   doublereal sottc;
2255   integer kk, ibb;
2256   doublereal dif, pas;
2257   doublereal som;
2258
2259
2260 /* ***********************************************************************
2261  */
2262
2263 /*     FUNCTION : */
2264 /*     ---------- */
2265 /*      Allows calculating the length of an arc of curve POLYNOMIAL */
2266 /*      on an interval [A,B]. */
2267
2268 /*     KEYWORDS : */
2269 /*     ----------- */
2270 /*        LENGTH,CURVE,GAUSS,PRIVATE. */
2271
2272 /*     INPUT ARGUMENTS : */
2273 /*     ------------------ */
2274 /*      NDIMAX : Max. number of lines of tables */
2275 /*               (i.e. max. nb of polynoms). */
2276 /*      NDIMEN : Dimension of the space (nb of polynoms). */
2277 /*      NCOEFF : Nb of coefficients of the polynom. This is degree + 1.
2278 */
2279 /*      COURBE(NDIMAX,NCOEFF) : Coefficients of the curve. */
2280 /*      TDEBUT : Lower limit of the interval of integration for  */
2281 /*               length calculation. */
2282 /*      TFINAL : Upper limit of the interval of integration for */
2283 /*               length calculation. */
2284 /*      EPSILN : REQIRED precision for length calculation. */
2285
2286 /*     OUTPUT ARGUMENTS : */
2287 /*     ------------------- */
2288 /*      XLONGC : Length of the arc of curve */
2289 /*      ERREUR : Precision OBTAINED for the length calculation. */
2290 /*      IERCOD : Error code, 0 OK, >0 Serious error. */
2291 /*               = 1 Too much iterations, the best calculated resultat */
2292 /*                   (is almost ERROR) */
2293 /*               = 2 Pb MMLONCV (no result) */
2294 /*               = 3 NDIM or NCOEFF invalid (no result) */
2295
2296 /*     COMMONS USED : */
2297 /*     ---------------- */
2298
2299 /*     REFERENCES CALLED : */
2300 /*     ----------------------- */
2301
2302 /*     DESCRIPTION/NOTES/LIMITATIONS : */
2303 /*     ----------------------------------- */
2304 /*      The polynom is actually a set of polynoms with */
2305 /*      coefficients arranged in a table of 2 indices, */
2306 /*      each line relative to the polynom. */
2307 /*      The polynom is defined by these coefficients ordered */
2308 /*      by increasing power of the variable. */
2309 /*      All polynoms have the same number of coefficients (the */
2310 /*      same degree). */
2311
2312 /*      This program cancels and replaces LENGCV, MLONGC and MLENCV. */
2313
2314 /*      ATTENTION : if TDEBUT > TFINAL, the length is NEGATIVE. */
2315
2316 /* > */
2317 /* ***********************************************************************
2318  */
2319
2320 /*   Name of the routine */
2321
2322
2323 /* ------------------------ General Initialization ---------------------
2324 */
2325
2326     /* Parameter adjustments */
2327     courbe_dim1 = *ndimax;
2328     courbe_offset = courbe_dim1 + 1;
2329     courbe -= courbe_offset;
2330
2331     /* Function Body */
2332     ibb = AdvApp2Var_SysBase::mnfndeb_();
2333     if (ibb >= 2) {
2334         AdvApp2Var_SysBase::mgenmsg_("MMCGLC1", 7L);
2335     }
2336
2337     *iercod = 0;
2338     *xlongc = 0.;
2339     *erreur = 0.;
2340
2341 /* ------ Test of equity of limits */
2342
2343     if (*tdebut == *tfinal) {
2344         *iercod = 0;
2345         goto L9999;
2346     }
2347
2348 /* ------ Test of the dimension and the number of coefficients */
2349
2350     if (*ndimen <= 0 || *ncoeff <= 0) {
2351         goto L9003;
2352     }
2353
2354 /* ----- Nb of current cutting, nb of iteration, */
2355 /*       max nb of iterations */
2356
2357     ndec = 1;
2358     iter = 1;
2359
2360     itmax = 13;
2361
2362 /* ------ Variation of the nb of intervals */
2363 /*       Multiplied by 2 at each iteration */
2364
2365 L5000:
2366     pas = (*tfinal - *tdebut) / ndec;
2367     sottc = 0.;
2368
2369 /* ------ Loop on all current NDEC intervals */
2370
2371     i__1 = ndec;
2372     for (kk = 1; kk <= i__1; ++kk) {
2373
2374 /* ------ Limits of the current integration interval */
2375
2376         tdeb = *tdebut + (kk - 1) * pas;
2377         tfin = tdeb + pas;
2378         mmloncv_(ndimax, ndimen, ncoeff, &courbe[courbe_offset], &tdeb, &tfin,
2379                  &som, iercod);
2380         if (*iercod > 0) {
2381             goto L9002;
2382         }
2383
2384         sottc += som;
2385
2386 /* L100: */
2387     }
2388
2389
2390 /* ----------------- Test of the maximum number of iterations ------------
2391 */
2392
2393 /*  Test if passes at least once ** */
2394
2395     if (iter == 1) {
2396         oldso = sottc;
2397         ndec <<= 1;
2398         ++iter;
2399         goto L5000;
2400     } else {
2401
2402 /* ------ Take into account DIF - Test of convergence */
2403
2404         ++iter;
2405         dif = (d__1 = sottc - oldso, advapp_abs(d__1));
2406
2407 /* ------ If DIF is OK, leave..., otherwise: */
2408
2409         if (dif > *epsiln) {
2410
2411 /* ------ If nb iteration exceeded, leave */
2412
2413             if (iter > itmax) {
2414                 *iercod = 1;
2415                 goto L9000;
2416             } else {
2417
2418 /* ------ Otherwise continue by cutting the initial interval.
2419  */
2420
2421                 oldso = sottc;
2422                 ndec <<= 1;
2423                 goto L5000;
2424             }
2425         }
2426     }
2427
2428 /* ------------------------------ THE END -------------------------------
2429 */
2430
2431 L9000:
2432     *xlongc = sottc;
2433     *erreur = dif;
2434     goto L9999;
2435
2436 /* ---> PB in MMLONCV */
2437
2438 L9002:
2439     *iercod = 2;
2440     goto L9999;
2441
2442 /* ---> NCOEFF or NDIM invalid. */
2443
2444 L9003:
2445     *iercod = 3;
2446     goto L9999;
2447
2448 L9999:
2449     if (*iercod > 0) {
2450         AdvApp2Var_SysBase::maermsg_("MMCGLC1", iercod, 7L);
2451     }
2452     if (ibb >= 2) {
2453         AdvApp2Var_SysBase::mgsomsg_("MMCGLC1", 7L);
2454     }
2455     return 0;
2456 } /* mmcglc1_ */
2457
2458 //=======================================================================
2459 //function : mmchole_
2460 //purpose  :
2461 //=======================================================================
2462 int mmchole_(integer *,//mxcoef,
2463              integer *dimens,
2464              doublereal *amatri,
2465              integer *aposit,
2466              integer *posuiv,
2467              doublereal *chomat,
2468              integer *iercod)
2469
2470 {
2471   /* System generated locals */
2472   integer i__1, i__2, i__3;
2473   doublereal d__1;
2474
2475   /* Builtin functions */
2476   //double sqrt();
2477
2478     /* Local variables */
2479   logical ldbg;
2480   integer kmin, i__, j, k;
2481   doublereal somme;
2482   integer ptini, ptcou;
2483
2484
2485 /* ***********************************************************************
2486  */
2487
2488 /*     FUNCTION : */
2489 /*     ----------                                                  T */
2490 /*     Produce decomposition of choleski of matrix A in S.S */
2491 /*     Calculate inferior triangular matrix S. */
2492
2493 /*     KEYWORDS : */
2494 /*     ----------- */
2495 /*     RESOLUTION, MFACTORISATION, MATRIX_PROFILE, CHOLESKI */
2496
2497 /*     INPUT ARGUMENTS : */
2498 /*     -------------------- */
2499 /*     MXCOEF : Max number of terms in the hessian profile */
2500 /*     DIMENS : Dimension of the problem */
2501 /*     AMATRI(MXCOEF) : Coefficients of the matrix profile */
2502 /*        APOSIT(1,*) : Distance diagonal-left extremity of the line
2503 */
2504 /*        APOSIT(2,*) : Position of diagonal terms in HESSIE */
2505 /*     POSUIV(MXCOEF) :  first line inferior not out of profile */
2506
2507 /*     OUTPUT ARGUMENTS : */
2508 /*     --------------------- */
2509 /*      CHOMAT(MXCOEF) : Inferior triangular matrix preserving the */
2510 /*                       profile of AMATRI. */
2511 /*      IERCOD : error code */
2512 /*               = 0 : ok */
2513 /*               = 1 : non-defined positive matrix */
2514
2515 /*     COMMONS USED : */
2516 /*     ------------------ */
2517
2518 /*      .Neant. */
2519
2520 /*     REFERENCES CALLED   : */
2521 /*     ---------------------- */
2522
2523 /*     DESCRIPTION/NOTES/LIMITATIONS : */
2524 /*     ----------------------------------- */
2525 /*     DEBUG LEVEL = 4 */
2526 /* ***********************************************************************
2527  */
2528 /*                            DECLARATIONS */
2529 /* ***********************************************************************
2530  */
2531
2532
2533
2534 /* ***********************************************************************
2535  */
2536 /*                      INITIALISATIONS */
2537 /* ***********************************************************************
2538  */
2539
2540     /* Parameter adjustments */
2541     --chomat;
2542     --posuiv;
2543     --amatri;
2544     aposit -= 3;
2545
2546     /* Function Body */
2547     ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 4;
2548     if (ldbg) {
2549         AdvApp2Var_SysBase::mgenmsg_("MMCHOLE", 7L);
2550     }
2551     *iercod = 0;
2552
2553 /* ***********************************************************************
2554  */
2555 /*                    PROCESSING */
2556 /* ***********************************************************************
2557  */
2558
2559     i__1 = *dimens;
2560     for (j = 1; j <= i__1; ++j) {
2561
2562         ptini = aposit[(j << 1) + 2];
2563
2564         somme = 0.;
2565         i__2 = ptini - 1;
2566         for (k = ptini - aposit[(j << 1) + 1]; k <= i__2; ++k) {
2567 /* Computing 2nd power */
2568             d__1 = chomat[k];
2569             somme += d__1 * d__1;
2570         }
2571
2572         if (amatri[ptini] - somme < 1e-32) {
2573             goto L9101;
2574         }
2575         chomat[ptini] = sqrt(amatri[ptini] - somme);
2576
2577         ptcou = ptini;
2578
2579         while(posuiv[ptcou] > 0) {
2580
2581             i__ = posuiv[ptcou];
2582             ptcou = aposit[(i__ << 1) + 2] - (i__ - j);
2583
2584 /*           Calculate the sum of S  .S   for k =1 a j-1 */
2585 /*                               ik  jk */
2586             somme = 0.;
2587 /* Computing MAX */
2588             i__2 = i__ - aposit[(i__ << 1) + 1], i__3 = j - aposit[(j << 1) +
2589                     1];
2590             kmin = advapp_max(i__2,i__3);
2591             i__2 = j - 1;
2592             for (k = kmin; k <= i__2; ++k) {
2593                 somme += chomat[aposit[(i__ << 1) + 2] - (i__ - k)] * chomat[
2594                         aposit[(j << 1) + 2] - (j - k)];
2595             }
2596
2597             chomat[ptcou] = (amatri[ptcou] - somme) / chomat[ptini];
2598         }
2599     }
2600
2601     goto L9999;
2602
2603 /* ***********************************************************************
2604  */
2605 /*                   ERROR PROCESSING */
2606 /* ***********************************************************************
2607  */
2608
2609 L9101:
2610     *iercod = 1;
2611     goto L9999;
2612
2613 /* ***********************************************************************
2614  */
2615 /*                  RETURN CALLING PROGRAM */
2616 /* ***********************************************************************
2617  */
2618
2619 L9999:
2620
2621     AdvApp2Var_SysBase::maermsg_("MMCHOLE", iercod, 7L);
2622     if (ldbg) {
2623         AdvApp2Var_SysBase::mgsomsg_("MMCHOLE", 7L);
2624     }
2625
2626  return 0 ;
2627 } /* mmchole_ */
2628
2629 //=======================================================================
2630 //function : AdvApp2Var_MathBase::mmcvctx_
2631 //purpose  :
2632 //=======================================================================
2633 int AdvApp2Var_MathBase::mmcvctx_(integer *ndimen,
2634                                   integer *ncofmx,
2635                                   integer *nderiv,
2636                                   doublereal *ctrtes,
2637                                   doublereal *crvres,
2638                                   doublereal *tabaux,
2639                                   doublereal *xmatri,
2640                                   integer *iercod)
2641
2642 {
2643   /* System generated locals */
2644   integer ctrtes_dim1, ctrtes_offset, crvres_dim1, crvres_offset,
2645   xmatri_dim1, xmatri_offset, tabaux_dim1, tabaux_offset, i__1,
2646   i__2;
2647
2648   /* Local variables */
2649   integer moup1, nordr;
2650   integer nd;
2651   integer ibb, ncf, ndv;
2652   doublereal eps1;
2653
2654
2655 /* ***********************************************************************
2656  */
2657
2658 /*     FUNCTION : */
2659 /*     ---------- */
2660 /*        Calculate a polynomial curve checking the  */
2661 /*        passage constraints (interpolation) */
2662 /*        from first derivatives, etc... to extremities. */
2663 /*        Parameters at the extremities are supposed to be -1 and 1. */
2664
2665 /*     KEYWORDS : */
2666 /*     ----------- */
2667 /*     ALL, AB_SPECIFI::CONSTRAINTS&,INTERPOLATION,&CURVE */
2668
2669 /*     INPUT ARGUMENTS : */
2670 /*     ------------------ */
2671 /*     NDIMEN : Space Dimension. */
2672 /*     NCOFMX : Nb of coeff. of curve CRVRES on each */
2673 /*              dimension. */
2674 /*     NDERIV : Order of constraint with derivatives : */
2675 /*              0 --> interpolation simple. */
2676 /*              1 --> interpolation+constraints with 1st. */
2677 /*              2 --> cas (0)+ (1) +   "         "   2nd derivatives. */
2678 /*                 etc... */
2679 /*     CTRTES : Table of constraints. */
2680 /*              CTRTES(*,1,*) = contraints at -1. */
2681 /*              CTRTES(*,2,*) = contraints at  1. */
2682
2683 /*     OUTPUT ARGUMENTS : */
2684 /*     ------------------- */
2685 /*     CRVRES : Resulting curve defined on (-1,1). */
2686 /*     TABAUX : Auxilliary matrix. */
2687 /*     XMATRI : Auxilliary matrix. */
2688
2689 /*     COMMONS UTILISES   : */
2690 /*     ---------------- */
2691
2692 /*      .Neant. */
2693
2694 /*     REFERENCES CALLED   : */
2695 /*     ---------------------- */
2696 /*     Type  Name */
2697 /*           MAERMSG         R*8  DFLOAT              MGENMSG */
2698 /*           MGSOMSG              MMEPS1               MMRSLW */
2699 /*      I*4  MNFNDEB */
2700
2701 /*     DESCRIPTION/NOTES/LIMITATIONS : */
2702 /*     ----------------------------------- */
2703 /*        The polynom (or the curve) is calculated by solving a */
2704 /*        system of linear equations. If the imposed degree is great */
2705 /*        it is preferable to call a routine based on */
2706 /*        Lagrange or Hermite interpolation depending on the case. */
2707 /*        (for a high degree the matrix of the system can be badly */
2708 /*        conditionned). */
2709 /*        This routine returns a curve defined in (-1,1). */
2710 /*        In general case, it is necessary to use MCVCTG. */
2711 /* > */
2712 /* ***********************************************************************
2713  */
2714
2715 /*   Name of the routine */
2716
2717
2718     /* Parameter adjustments */
2719     crvres_dim1 = *ncofmx;
2720     crvres_offset = crvres_dim1 + 1;
2721     crvres -= crvres_offset;
2722     xmatri_dim1 = *nderiv + 1;
2723     xmatri_offset = xmatri_dim1 + 1;
2724     xmatri -= xmatri_offset;
2725     tabaux_dim1 = *nderiv + 1 + *ndimen;
2726     tabaux_offset = tabaux_dim1 + 1;
2727     tabaux -= tabaux_offset;
2728     ctrtes_dim1 = *ndimen;
2729     ctrtes_offset = ctrtes_dim1 * 3 + 1;
2730     ctrtes -= ctrtes_offset;
2731
2732     /* Function Body */
2733     ibb = AdvApp2Var_SysBase::mnfndeb_();
2734     if (ibb >= 3) {
2735         AdvApp2Var_SysBase::mgenmsg_("MMCVCTX", 7L);
2736     }
2737 /*   Precision. */
2738     AdvApp2Var_MathBase::mmeps1_(&eps1);
2739
2740 /* ****************** CALCULATION OF EVEN COEFFICIENTS *********************
2741 */
2742 /* ------------------------- Initialization -----------------------------
2743 */
2744
2745     nordr = *nderiv + 1;
2746     i__1 = nordr;
2747     for (ncf = 1; ncf <= i__1; ++ncf) {
2748         tabaux[ncf + tabaux_dim1] = 1.;
2749 /* L100: */
2750     }
2751
2752 /* ---------------- Calculation of terms corresponding to derivatives -------
2753 */
2754
2755     i__1 = nordr;
2756     for (ndv = 2; ndv <= i__1; ++ndv) {
2757         i__2 = nordr;
2758         for (ncf = 1; ncf <= i__2; ++ncf) {
2759             tabaux[ncf + ndv * tabaux_dim1] = tabaux[ncf + (ndv - 1) *
2760                     tabaux_dim1] * (doublereal) ((ncf << 1) - ndv);
2761 /* L300: */
2762         }
2763 /* L200: */
2764     }
2765
2766 /* ------------------ Writing the second member -----------------------
2767 */
2768
2769     moup1 = 1;
2770     i__1 = nordr;
2771     for (ndv = 1; ndv <= i__1; ++ndv) {
2772         i__2 = *ndimen;
2773         for (nd = 1; nd <= i__2; ++nd) {
2774             tabaux[nordr + nd + ndv * tabaux_dim1] = (ctrtes[nd + ((ndv << 1)
2775                     + 2) * ctrtes_dim1] + moup1 * ctrtes[nd + ((ndv << 1) + 1)
2776                      * ctrtes_dim1]) / 2.;
2777 /* L500: */
2778         }
2779         moup1 = -moup1;
2780 /* L400: */
2781     }
2782
2783 /* -------------------- Resolution of the system ---------------------------
2784 */
2785
2786     mmrslw_(&nordr, &nordr, ndimen, &eps1, &tabaux[tabaux_offset], &xmatri[
2787             xmatri_offset], iercod);
2788     if (*iercod > 0) {
2789         goto L9999;
2790     }
2791     i__1 = *ndimen;
2792     for (nd = 1; nd <= i__1; ++nd) {
2793         i__2 = nordr;
2794         for (ncf = 1; ncf <= i__2; ++ncf) {
2795             crvres[(ncf << 1) - 1 + nd * crvres_dim1] = xmatri[ncf + nd *
2796                     xmatri_dim1];
2797 /* L700: */
2798         }
2799 /* L600: */
2800     }
2801
2802 /* ***************** CALCULATION OF UNEVEN COEFFICIENTS ********************
2803 */
2804 /* ------------------------- Initialization -----------------------------
2805 */
2806
2807
2808     i__1 = nordr;
2809     for (ncf = 1; ncf <= i__1; ++ncf) {
2810         tabaux[ncf + tabaux_dim1] = 1.;
2811 /* L1100: */
2812     }
2813
2814 /* ---------------- Calculation of terms corresponding to derivatives -------
2815 */
2816
2817     i__1 = nordr;
2818     for (ndv = 2; ndv <= i__1; ++ndv) {
2819         i__2 = nordr;
2820         for (ncf = 1; ncf <= i__2; ++ncf) {
2821             tabaux[ncf + ndv * tabaux_dim1] = tabaux[ncf + (ndv - 1) *
2822                     tabaux_dim1] * (doublereal) ((ncf << 1) - ndv + 1);
2823 /* L1300: */
2824         }
2825 /* L1200: */
2826     }
2827
2828 /* ------------------ Writing of the second member -----------------------
2829 */
2830
2831     moup1 = -1;
2832     i__1 = nordr;
2833     for (ndv = 1; ndv <= i__1; ++ndv) {
2834         i__2 = *ndimen;
2835         for (nd = 1; nd <= i__2; ++nd) {
2836             tabaux[nordr + nd + ndv * tabaux_dim1] = (ctrtes[nd + ((ndv << 1)
2837                     + 2) * ctrtes_dim1] + moup1 * ctrtes[nd + ((ndv << 1) + 1)
2838                      * ctrtes_dim1]) / 2.;
2839 /* L1500: */
2840         }
2841         moup1 = -moup1;
2842 /* L1400: */
2843     }
2844
2845 /* -------------------- Solution of the system ---------------------------
2846 */
2847
2848     mmrslw_(&nordr, &nordr, ndimen, &eps1, &tabaux[tabaux_offset], &xmatri[
2849             xmatri_offset], iercod);
2850     if (*iercod > 0) {
2851         goto L9999;
2852     }
2853     i__1 = *ndimen;
2854     for (nd = 1; nd <= i__1; ++nd) {
2855         i__2 = nordr;
2856         for (ncf = 1; ncf <= i__2; ++ncf) {
2857             crvres[(ncf << 1) + nd * crvres_dim1] = xmatri[ncf + nd *
2858                     xmatri_dim1];
2859 /* L1700: */
2860         }
2861 /* L1600: */
2862     }
2863
2864 /* --------------------------- The end ----------------------------------
2865 */
2866
2867 L9999:
2868     if (*iercod != 0) {
2869         AdvApp2Var_SysBase::maermsg_("MMCVCTX", iercod, 7L);
2870     }
2871     if (ibb >= 3) {
2872         AdvApp2Var_SysBase::mgsomsg_("MMCVCTX", 7L);
2873     }
2874
2875  return 0 ;
2876 } /* mmcvctx_ */
2877
2878 //=======================================================================
2879 //function : AdvApp2Var_MathBase::mmcvinv_
2880 //purpose  :
2881 //=======================================================================
2882  int AdvApp2Var_MathBase::mmcvinv_(integer *ndimax,
2883                             integer *ncoef,
2884                             integer *ndim,
2885                             doublereal *curveo,
2886                             doublereal *curve)
2887
2888 {
2889   /* Initialized data */
2890
2891   static char nomprg[8+1] = "MMCVINV ";
2892
2893   /* System generated locals */
2894   integer curve_dim1, curve_offset, curveo_dim1, curveo_offset, i__1, i__2;
2895
2896   /* Local variables */
2897   integer i__, nd, ibb;
2898
2899
2900 /* ***********************************************************************
2901  */
2902
2903 /*     FUNCTION : */
2904 /*     ---------- */
2905 /*        Inversion of arguments of the final curve. */
2906
2907 /*     KEYWORDS : */
2908 /*     ----------- */
2909 /*        SMOOTHING,CURVE */
2910
2911
2912 /*     INPUT ARGUMENTS : */
2913 /*     ------------------ */
2914
2915 /*        NDIM: Space Dimension. */
2916 /*        NCOEF: Degree of the polynom. */
2917 /*        CURVEO: The curve before inversion. */
2918
2919 /*     OUTPUT ARGUMENTS : */
2920 /*     ------------------- */
2921 /*        CURVE: The curve after inversion. */
2922
2923 /*     COMMONS USED : */
2924 /*     ---------------- */
2925 /*     REFERENCES APPELEES   : */
2926 /*     ----------------------- */
2927 /*     DESCRIPTION/NOTES/LIMITATIONS : */
2928 /*     ----------------------------------- */
2929 /* ***********************************************************************
2930  */
2931
2932 /*   The name of the routine */
2933     /* Parameter adjustments */
2934     curve_dim1 = *ndimax;
2935     curve_offset = curve_dim1 + 1;
2936     curve -= curve_offset;
2937     curveo_dim1 = *ncoef;
2938     curveo_offset = curveo_dim1 + 1;
2939     curveo -= curveo_offset;
2940
2941     /* Function Body */
2942
2943     ibb = AdvApp2Var_SysBase::mnfndeb_();
2944     if (ibb >= 2) {
2945         AdvApp2Var_SysBase::mgenmsg_(nomprg, 6L);
2946     }
2947
2948     i__1 = *ncoef;
2949     for (i__ = 1; i__ <= i__1; ++i__) {
2950         i__2 = *ndim;
2951         for (nd = 1; nd <= i__2; ++nd) {
2952             curve[nd + i__ * curve_dim1] = curveo[i__ + nd * curveo_dim1];
2953 /* L300: */
2954         }
2955     }
2956
2957 /* L9999: */
2958     return 0;
2959 } /* mmcvinv_ */
2960
2961 //=======================================================================
2962 //function : mmcvstd_
2963 //purpose  :
2964 //=======================================================================
2965 int mmcvstd_(integer *ncofmx,
2966              integer *ndimax,
2967              integer *ncoeff,
2968              integer *ndimen,
2969              doublereal *crvcan,
2970              doublereal *courbe)
2971
2972 {
2973   /* System generated locals */
2974   integer courbe_dim1, crvcan_dim1, crvcan_offset, i__1, i__2, i__3;
2975
2976   /* Local variables */
2977   integer ndeg, i__, j, j1, nd, ibb;
2978   doublereal bid;
2979
2980
2981 /* ***********************************************************************
2982  */
2983
2984 /*     FUNCTION : */
2985 /*     ---------- */
2986 /*        Transform curve defined between [-1,1] into [0,1]. */
2987
2988 /*     KEYWORDS : */
2989 /*     ----------- */
2990 /*        LIMITATION,RESTRICTION,CURVE */
2991
2992 /*     INPUT ARGUMENTS : */
2993 /*     ------------------ */
2994 /*        NDIMAX : Dimension of the space. */
2995 /*        NDIMEN : Dimension of the curve. */
2996 /*        NCOEFF : Degree of the curve. */
2997 /*        CRVCAN(NCOFMX,NDIMEN): The curve is defined at the interval [-1,1]. */
2998
2999 /*     OUTPUT ARGUMENTS : */
3000 /*     ------------------- */
3001 /*        CURVE(NDIMAX,NCOEFF): Curve defined at the interval [0,1]. */
3002
3003 /*     COMMONS USED   : */
3004 /*     ---------------- */
3005
3006 /*     REFERENCES CALLED   : */
3007 /*     ----------------------- */
3008
3009 /*     DESCRIPTION/NOTES/LIMITATIONS : */
3010 /*     ----------------------------------- */
3011 /* > */
3012 /* ***********************************************************************
3013  */
3014
3015 /*   Name of the program. */
3016
3017
3018 /* **********************************************************************
3019 */
3020
3021 /*     FUNCTION : */
3022 /*     ---------- */
3023 /*      Provides binomial coefficients (Pascal triangle). */
3024
3025 /*     KEYWORDS : */
3026 /*     ----------- */
3027 /*      Binomial coefficient from 0 to 60. read only . init by block data */
3028
3029 /*     DEMSCRIPTION/NOTES/LIMITATIONS : */
3030 /*     ----------------------------------- */
3031 /*     Binomial coefficients form a triangular matrix. */
3032 /*     This matrix is completed in table CNP by its transposition. */
3033 /*     So: CNP(I,J) = CNP(J,I) for I and J = 0, ..., 60. */
3034
3035 /*     Initialization is done with block-data MMLLL09.RES, */
3036 /*     created by the program MQINICNP.FOR. */
3037 /* > */
3038 /* **********************************************************************
3039 */
3040
3041
3042
3043 /* ***********************************************************************
3044  */
3045
3046     /* Parameter adjustments */
3047     courbe_dim1 = *ndimax;
3048     --courbe;
3049     crvcan_dim1 = *ncofmx;
3050     crvcan_offset = crvcan_dim1;
3051     crvcan -= crvcan_offset;
3052
3053     /* Function Body */
3054     ibb = AdvApp2Var_SysBase::mnfndeb_();
3055     if (ibb >= 3) {
3056         AdvApp2Var_SysBase::mgenmsg_("MMCVSTD", 7L);
3057     }
3058     ndeg = *ncoeff - 1;
3059
3060 /* ------------------ Construction of the resulting curve ----------------
3061 */
3062
3063     i__1 = *ndimen;
3064     for (nd = 1; nd <= i__1; ++nd) {
3065         i__2 = ndeg;
3066         for (j = 0; j <= i__2; ++j) {
3067             bid = 0.;
3068             i__3 = ndeg;
3069             for (i__ = j; i__ <= i__3; i__ += 2) {
3070                 bid += crvcan[i__ + nd * crvcan_dim1] * mmcmcnp_.cnp[i__ + j
3071                         * 61];
3072 /* L410: */
3073             }
3074             courbe[nd + j * courbe_dim1] = bid;
3075
3076             bid = 0.;
3077             j1 = j + 1;
3078             i__3 = ndeg;
3079             for (i__ = j1; i__ <= i__3; i__ += 2) {
3080                 bid += crvcan[i__ + nd * crvcan_dim1] * mmcmcnp_.cnp[i__ + j
3081                         * 61];
3082 /* L420: */
3083             }
3084             courbe[nd + j * courbe_dim1] -= bid;
3085 /* L400: */
3086         }
3087 /* L300: */
3088     }
3089
3090 /* ------------------- Renormalization of the CURVE -------------------------
3091  */
3092
3093     bid = 1.;
3094     i__1 = ndeg;
3095     for (i__ = 0; i__ <= i__1; ++i__) {
3096         i__2 = *ndimen;
3097         for (nd = 1; nd <= i__2; ++nd) {
3098             courbe[nd + i__ * courbe_dim1] *= bid;
3099 /* L510: */
3100         }
3101         bid *= 2.;
3102 /* L500: */
3103     }
3104
3105 /* ----------------------------- The end --------------------------------
3106 */
3107
3108     if (ibb >= 3) {
3109         AdvApp2Var_SysBase::mgsomsg_("MMCVSTD", 7L);
3110     }
3111     return 0;
3112 } /* mmcvstd_ */
3113
3114 //=======================================================================
3115 //function : AdvApp2Var_MathBase::mmdrc11_
3116 //purpose  :
3117 //=======================================================================
3118 int AdvApp2Var_MathBase::mmdrc11_(integer *iordre,
3119                                   integer *ndimen,
3120                                   integer *ncoeff,
3121                                   doublereal *courbe,
3122                                   doublereal *points,
3123                                   doublereal *mfactab)
3124
3125 {
3126   /* System generated locals */
3127   integer courbe_dim1, courbe_offset, points_dim2, points_offset, i__1,
3128   i__2;
3129
3130   /* Local variables */
3131
3132   integer ndeg, i__, j, ndgcb, nd, ibb;
3133
3134
3135 /* **********************************************************************
3136 */
3137
3138 /*     FUNCTION : */
3139 /*     ---------- */
3140 /*        Calculation of successive derivatives of equation CURVE with */
3141 /*        parameters -1, 1 from order 0 to order IORDRE */
3142 /*        included. The calculation is produced without knowing the coefficients of */
3143 /*        derivatives of the curve. */
3144
3145 /*     KEYWORDS : */
3146 /*     ----------- */
3147 /*        POSITIONING,EXTREMITIES,CURVE,DERIVATIVE. */
3148
3149 /*     INPUT ARGUMENTS : */
3150 /*     ------------------ */
3151 /*        IORDRE  : Maximum order of calculation of derivatives. */
3152 /*        NDIMEN  : Dimension of the space. */
3153 /*        NCOEFF  : Number of coefficients of the curve (degree+1). */
3154 /*        COURBE  : Table of coefficients of the curve. */
3155
3156 /*     OUTPUT ARGUMENTS : */
3157 /*     ------------------- */
3158 /*        POINTS    : Table of values of consecutive derivatives */
3159 /*                 of parameters -1.D0 and 1.D0. */
3160 /*        MFACTAB : Auxiliary table for calculation of factorial(I).
3161 */
3162
3163 /*     COMMONS USED   : */
3164 /*     ---------------- */
3165 /*        None. */
3166
3167 /*     REFERENCES CALLED   : */
3168 /*     ----------------------- */
3169
3170 /*     DESCRIPTION/NOTES/LIMITATIONS : */
3171 /*     ----------------------------------- */
3172
3173 /* ---> ATTENTION, the coefficients of the curve are  */
3174 /*     in a reverse order. */
3175
3176 /* ---> The algorithm of calculation of derivatives is based on */
3177 /*     generalization of Horner scheme : */
3178 /*                          k             2 */
3179 /*          Let C(t) = uk.t  + ... + u2.t  + u1.t + u0 . */
3180
3181
3182 /*      a0 = uk, b0 = 0, c0 = 0 and for 1<=j<=k, it is calculated : */
3183
3184 /*          aj = a(j-1).x + u(k-j) */
3185 /*          bj = b(j-1).x + a(j-1) */
3186 /*          cj = c(j-1).x + b(j-1) */
3187
3188 /*     So : C(x) = ak, C'(x) = bk, C"(x) = 2.ck  . */
3189
3190 /*     The algorithm is generalized easily for calculation of */
3191
3192 /*               (n) */
3193 /*              C  (x)   . */
3194 /*             --------- */
3195 /*                n! */
3196
3197 /*      Reference : D. KNUTH, "The Art of Computer Programming" */
3198 /*      ---------              Vol. 2/Seminumerical Algorithms */
3199 /*                             Addison-Wesley Pub. Co. (1969) */
3200 /*                             pages 423-425. */
3201 /* > */
3202 /* **********************************************************************
3203 */
3204
3205 /*   Name of the routine */
3206
3207     /* Parameter adjustments */
3208     points_dim2 = *iordre + 1;
3209     points_offset = (points_dim2 << 1) + 1;
3210     points -= points_offset;
3211     courbe_dim1 = *ncoeff;
3212     courbe_offset = courbe_dim1;
3213     courbe -= courbe_offset;
3214
3215     /* Function Body */
3216     ibb = AdvApp2Var_SysBase::mnfndeb_();
3217     if (ibb >= 2) {
3218         AdvApp2Var_SysBase::mgenmsg_("MMDRC11", 7L);
3219     }
3220
3221     if (*iordre < 0 || *ncoeff < 1) {
3222         goto L9999;
3223     }
3224
3225 /* ------------------- Initialization of table POINTS -----------------
3226 */
3227
3228     ndgcb = *ncoeff - 1;
3229     i__1 = *ndimen;
3230     for (nd = 1; nd <= i__1; ++nd) {
3231         points[(nd * points_dim2 << 1) + 1] = courbe[ndgcb + nd * courbe_dim1]
3232                 ;
3233         points[(nd * points_dim2 << 1) + 2] = courbe[ndgcb + nd * courbe_dim1]
3234                 ;
3235 /* L100: */
3236     }
3237
3238     i__1 = *ndimen;
3239     for (nd = 1; nd <= i__1; ++nd) {
3240         i__2 = *iordre;
3241         for (j = 1; j <= i__2; ++j) {
3242             points[((j + nd * points_dim2) << 1) + 1] = 0.;
3243             points[((j + nd * points_dim2) << 1) + 2] = 0.;
3244 /* L400: */
3245         }
3246 /* L300: */
3247     }
3248
3249 /*    Calculation with parameter -1 and 1 */
3250
3251     i__1 = *ndimen;
3252     for (nd = 1; nd <= i__1; ++nd) {
3253         i__2 = ndgcb;
3254         for (ndeg = 1; ndeg <= i__2; ++ndeg) {
3255             for (i__ = *iordre; i__ >= 1; --i__) {
3256                 points[((i__ + nd * points_dim2) << 1) + 1] = -points[((i__ + nd
3257                         * points_dim2) << 1) + 1] + points[((i__ - 1 + nd *
3258                         points_dim2) << 1) + 1];
3259                 points[((i__ + nd * points_dim2) << 1) + 2] += points[((i__ - 1
3260                         + nd * points_dim2) << 1) + 2];
3261 /* L800: */
3262             }
3263             points[(nd * points_dim2 << 1) + 1] = -points[(nd * points_dim2 <<
3264                      1) + 1] + courbe[ndgcb - ndeg + nd * courbe_dim1];
3265             points[(nd * points_dim2 << 1) + 2] += courbe[ndgcb - ndeg + nd *
3266                     courbe_dim1];
3267 /* L700: */
3268         }
3269 /* L600: */
3270     }
3271
3272 /* --------------------- Multiplication by factorial(I) --------------
3273 */
3274
3275     if (*iordre > 1) {
3276         mfac_(&mfactab[1], iordre);
3277
3278         i__1 = *ndimen;
3279         for (nd = 1; nd <= i__1; ++nd) {
3280             i__2 = *iordre;
3281             for (i__ = 2; i__ <= i__2; ++i__) {
3282                 points[((i__ + nd * points_dim2) << 1) + 1] = mfactab[i__] *
3283                         points[((i__ + nd * points_dim2) << 1) + 1];
3284                 points[((i__ + nd * points_dim2) << 1) + 2] = mfactab[i__] *
3285                         points[((i__ + nd * points_dim2) << 1) + 2];
3286 /* L1000: */
3287             }
3288 /* L900: */
3289         }
3290     }
3291
3292 /* ---------------------------- End -------------------------------------
3293 */
3294
3295 L9999:
3296     if (ibb >= 2) {
3297         AdvApp2Var_SysBase::mgsomsg_("MMDRC11", 7L);
3298     }
3299     return 0;
3300 } /* mmdrc11_ */
3301
3302 //=======================================================================
3303 //function : mmdrvcb_
3304 //purpose  :
3305 //=======================================================================
3306 int mmdrvcb_(integer *ideriv,
3307              integer *ndim,
3308              integer *ncoeff,
3309              doublereal *courbe,
3310              doublereal *tparam,
3311              doublereal *tabpnt,
3312              integer *iercod)
3313
3314 {
3315   /* System generated locals */
3316   integer courbe_dim1, tabpnt_dim1, i__1, i__2, i__3;
3317
3318   /* Local variables */
3319   integer ndeg, i__, j, nd, ndgcrb, iptpnt, ibb;
3320
3321
3322 /* *********************************************************************** */
3323 /*     FUNCTION : */
3324 /*     ---------- */
3325
3326 /*        Calculation of successive derivatives of equation CURVE with */
3327 /*        parameter TPARAM from order 0 to order IDERIV included. */
3328 /*        The calculation is produced without knowing the coefficients of */
3329 /*        derivatives of the CURVE. */
3330
3331 /*     KEYWORDS : */
3332 /*     ----------- */
3333 /*        POSITIONING,PARAMETER,CURVE,DERIVATIVE. */
3334
3335 /*     INPUT ARGUMENTS : */
3336 /*     ------------------ */
3337 /*        IORDRE  : Maximum order of calculation of derivatives. */
3338 /*        NDIMEN  : Dimension of the space. */
3339 /*        NCOEFF  : Number of coefficients of the curve (degree+1). */
3340 /*        COURBE  : Table of coefficients of the curve. */
3341 /*        TPARAM  : Value of the parameter where the curve should be evaluated. */
3342
3343 /*     OUTPUT ARGUMENTS : */
3344 /*     ------------------- */
3345 /*        TABPNT  : Table of values of consecutive derivatives */
3346 /*                  of parameter TPARAM. */
3347   /*        IERCOD  : 0 = OK, */
3348 /*                    1 = incoherent input. */
3349
3350 /*     COMMONS USED  : */
3351 /*     ---------------- */
3352 /*        None. */
3353
3354 /*     REFERENCES CALLED   : */
3355 /*     ----------------------- */
3356
3357 /*     DESCRIPTION/NOTES/LIMITATIONS : */
3358 /*     ----------------------------------- */
3359
3360 /*     The algorithm of  calculation of derivatives is based on */
3361 /*     generalization of the Horner scheme : */
3362 /*                          k             2 */
3363 /*          Let C(t) = uk.t  + ... + u2.t  + u1.t + u0 . */
3364
3365
3366 /*      a0 = uk, b0 = 0, c0 = 0 and for 1<=j<=k, it is calculated : */
3367
3368 /*          aj = a(j-1).x + u(k-j) */
3369 /*          bj = b(j-1).x + a(j-1) */
3370 /*          cj = c(j-1).x + b(j-1) */
3371
3372 /*     So, it is obtained : C(x) = ak, C'(x) = bk, C"(x) = 2.ck  . */
3373
3374 /*     The algorithm can be easily generalized for the calculation of */
3375
3376 /*               (n) */
3377 /*              C  (x)   . */
3378 /*             --------- */
3379 /*                n! */
3380
3381 /*      Reference : D. KNUTH, "The Art of Computer Programming" */
3382 /*      ---------              Vol. 2/Seminumerical Algorithms */
3383 /*                             Addison-Wesley Pub. Co. (1969) */
3384 /*                             pages 423-425. */
3385
3386 /* ---> To evaluare derivatives at 0 and 1, it is preferable */
3387 /*      to use routine MDRV01.FOR . */
3388 /* > */
3389 /* **********************************************************************
3390 */
3391
3392 /*   Name of the routine */
3393
3394     /* Parameter adjustments */
3395     tabpnt_dim1 = *ndim;
3396     --tabpnt;
3397     courbe_dim1 = *ndim;
3398     --courbe;
3399
3400     /* Function Body */
3401     ibb = AdvApp2Var_SysBase::mnfndeb_();
3402     if (ibb >= 2) {
3403         AdvApp2Var_SysBase::mgenmsg_("MMDRVCB", 7L);
3404     }
3405
3406     if (*ideriv < 0 || *ncoeff < 1) {
3407         *iercod = 1;
3408         goto L9999;
3409     }
3410     *iercod = 0;
3411
3412 /* ------------------- Initialization of table TABPNT -----------------
3413 */
3414
3415     ndgcrb = *ncoeff - 1;
3416     i__1 = *ndim;
3417     for (nd = 1; nd <= i__1; ++nd) {
3418         tabpnt[nd] = courbe[nd + ndgcrb * courbe_dim1];
3419 /* L100: */
3420     }
3421
3422     if (*ideriv < 1) {
3423         goto L200;
3424     }
3425     iptpnt = *ndim * *ideriv;
3426     AdvApp2Var_SysBase::mvriraz_(&iptpnt,
3427              &tabpnt[tabpnt_dim1 + 1]);
3428 L200:
3429
3430 /* ------------------------ Calculation of parameter TPARAM ------------------
3431 */
3432
3433     i__1 = ndgcrb;
3434     for (ndeg = 1; ndeg <= i__1; ++ndeg) {
3435         i__2 = *ndim;
3436         for (nd = 1; nd <= i__2; ++nd) {
3437             for (i__ = *ideriv; i__ >= 1; --i__) {
3438                 tabpnt[nd + i__ * tabpnt_dim1] = tabpnt[nd + i__ *
3439                         tabpnt_dim1] * *tparam + tabpnt[nd + (i__ - 1) *
3440                         tabpnt_dim1];
3441 /* L700: */
3442             }
3443             tabpnt[nd] = tabpnt[nd] * *tparam + courbe[nd + (ndgcrb - ndeg) *
3444                     courbe_dim1];
3445 /* L600: */
3446         }
3447 /* L500: */
3448     }
3449
3450 /* --------------------- Multiplication by factorial(I) -------------
3451 */
3452
3453     i__1 = *ideriv;
3454     for (i__ = 2; i__ <= i__1; ++i__) {
3455         i__2 = i__;
3456         for (j = 2; j <= i__2; ++j) {
3457             i__3 = *ndim;
3458             for (nd = 1; nd <= i__3; ++nd) {
3459                 tabpnt[nd + i__ * tabpnt_dim1] = (doublereal) j * tabpnt[nd +
3460                         i__ * tabpnt_dim1];
3461 /* L1200: */
3462             }
3463 /* L1100: */
3464         }
3465 /* L1000: */
3466     }
3467
3468 /* --------------------------- The end ---------------------------------
3469 */
3470
3471 L9999:
3472     if (*iercod > 0) {
3473         AdvApp2Var_SysBase::maermsg_("MMDRVCB", iercod, 7L);
3474     }
3475     return 0;
3476 } /* mmdrvcb_ */
3477
3478 //=======================================================================
3479 //function : AdvApp2Var_MathBase::mmdrvck_
3480 //purpose  :
3481 //=======================================================================
3482 int AdvApp2Var_MathBase::mmdrvck_(integer *ncoeff,
3483                                   integer *ndimen,
3484                                   doublereal *courbe,
3485                                   integer *ideriv,
3486                                   doublereal *tparam,
3487                                   doublereal *pntcrb)
3488
3489 {
3490   /* Initialized data */
3491
3492   static doublereal mmfack[21] = { 1.,2.,6.,24.,120.,720.,5040.,40320.,
3493             362880.,3628800.,39916800.,479001600.,6227020800.,87178291200.,
3494             1.307674368e12,2.0922789888e13,3.55687428096e14,6.402373705728e15,
3495             1.21645100408832e17,2.43290200817664e18,5.109094217170944e19 };
3496
3497   /* System generated locals */
3498   integer courbe_dim1, courbe_offset, i__1, i__2;
3499
3500   /* Local variables */
3501   integer i__, j, k, nd;
3502   doublereal mfactk, bid;
3503
3504
3505 /*      IMPLICIT INTEGER (I-N) */
3506 /*      IMPLICIT DOUBLE PRECISION(A-H,O-Z) */
3507
3508
3509 /* ***********************************************************************
3510  */
3511
3512 /*     FONCTION : */
3513 /*     ---------- */
3514 /*     Calculate the value of a derived curve of order IDERIV in */
3515 /*     a point of parameter TPARAM. */
3516
3517 /*     KEYWORDS : */
3518 /*     ----------- */
3519 /*     POSITIONING,CURVE,DERIVATIVE of ORDER K. */
3520
3521 /*     INPUT ARGUMENTS  : */
3522 /*     ------------------ */
3523 /*   NCOEFF  : Degree +1 of the curve. */
3524 /*   NDIMEN   : Dimension of the space (2 or 3 in general) */
3525 /*   COURBE  : Table of coefficients of the curve. */
3526 /*   IDERIV : Required order of derivation : 1=1st derivative, etc... */
3527 /*   TPARAM : Value of parameter of the curve. */
3528
3529 /*     OUTPUT ARGUMENTS  : */
3530 /*     ------------------- */
3531 /*   PNTCRB  : Point of parameter TPARAM on the derivative of order */
3532 /*            IDERIV of CURVE. */
3533
3534 /*     COMMONS USED   : */
3535 /*     ---------------- */
3536 /*    MMCMCNP */
3537
3538 /*     REFERENCES CALLED   : */
3539 /*     ---------------------- */
3540 /*      None. */
3541 /*     DESCRIPTION/NOTES/LIMITATIONS : */
3542 /*     ----------------------------------- */
3543
3544 /*    The code below was written basing on the following algorithm :
3545 */
3546
3547 /*    Let P(t) = a1 + a2*t + ... an*t**n. The derivative of order k of P */
3548 /*    (containing n-k coefficients) is calculated as follows : */
3549
3550 /*       Pk(t) = a(k+1)*CNP(k,k)*k! */
3551 /*             + a(k+2)*CNP(k+1,k)*k! * t */
3552 /*             . */
3553 /*             . */
3554 /*             . */
3555 /*             + a(n)*CNP(n-1,k)*k! * t**(n-k-1). */
3556
3557 /*    Evaluation is produced following the classic Horner scheme. */
3558 /* > */
3559 /* ***********************************************************************
3560  */
3561
3562
3563 /*     Factorials (1 to 21)  caculated on VAX in R*16 */
3564
3565
3566 /* **********************************************************************
3567 */
3568
3569 /*     FUNCTION : */
3570 /*     ---------- */
3571 /*      Serves to provide binomial coefficients (Pascal triangle). */
3572
3573 /*     KEYWORDS : */
3574 /*     ----------- */
3575 /*      Binomial Coeff from 0 to 60. read only . init by block data */
3576
3577 /*     DEMSCRIPTION/NOTES/LIMITATIONS : */
3578 /*     ----------------------------------- */
3579 /*     Binomial coefficients form a triangular matrix. */
3580 /*     This matrix is completed in table CNP by its transposition. */
3581 /*     So: CNP(I,J) = CNP(J,I) for I and J = 0, ..., 60. */
3582
3583 /*     Initialization is done by block-data MMLLL09.RES, */
3584 /*     created by program MQINICNP.FOR. */
3585 /* > */
3586 /* **********************************************************************
3587 */
3588
3589
3590
3591 /* ***********************************************************************
3592  */
3593
3594     /* Parameter adjustments */
3595     --pntcrb;
3596     courbe_dim1 = *ndimen;
3597     courbe_offset = courbe_dim1 + 1;
3598     courbe -= courbe_offset;
3599
3600     /* Function Body */
3601
3602 /* -------------- Case when the order of derivative is greater than -------------------
3603 */
3604 /* ---------------- the degree of the curve ---------------------
3605 */
3606
3607     if (*ideriv >= *ncoeff) {
3608         i__1 = *ndimen;
3609         for (nd = 1; nd <= i__1; ++nd) {
3610             pntcrb[nd] = 0.;
3611 /* L100: */
3612         }
3613         goto L9999;
3614     }
3615 /* **********************************************************************
3616 */
3617 /*                         General processing*/
3618 /* **********************************************************************
3619 */
3620 /* --------------------- Calculation of Factorial(IDERIV) ------------------
3621 */
3622
3623     k = *ideriv;
3624     if (*ideriv <= 21 && *ideriv > 0) {
3625         mfactk = mmfack[k - 1];
3626     } else {
3627         mfactk = 1.;
3628         i__1 = k;
3629         for (i__ = 2; i__ <= i__1; ++i__) {
3630             mfactk *= i__;
3631 /* L200: */
3632         }
3633     }
3634
3635 /* ------- Calculation of derivative of order IDERIV of CURVE in TPARAM -----
3636 */
3637 /* ---> Attention : binomial coefficient C(n,m) is represented in */
3638 /*                 MCCNP by CNP(N,M). */
3639
3640     i__1 = *ndimen;
3641     for (nd = 1; nd <= i__1; ++nd) {
3642         pntcrb[nd] = courbe[nd + *ncoeff * courbe_dim1] * mmcmcnp_.cnp[*
3643                 ncoeff - 1 + k * 61] * mfactk;
3644 /* L300: */
3645     }
3646
3647     i__1 = k + 1;
3648     for (j = *ncoeff - 1; j >= i__1; --j) {
3649         bid = mmcmcnp_.cnp[j - 1 + k * 61] * mfactk;
3650         i__2 = *ndimen;
3651         for (nd = 1; nd <= i__2; ++nd) {
3652             pntcrb[nd] = pntcrb[nd] * *tparam + courbe[nd + j * courbe_dim1] *
3653                      bid;
3654 /* L500: */
3655         }
3656 /* L400: */
3657     }
3658
3659 /* -------------------------------- The end -----------------------------
3660 */
3661
3662 L9999:
3663
3664  return 0   ;
3665
3666 } /* mmdrvck_ */
3667 //=======================================================================
3668 //function : AdvApp2Var_MathBase::mmeps1_
3669 //purpose  :
3670 //=======================================================================
3671 int AdvApp2Var_MathBase::mmeps1_(doublereal *epsilo)
3672
3673 {
3674 /* ***********************************************************************
3675  */
3676
3677 /*     FUNCTION : */
3678 /*     ---------- */
3679 /*        Extraction of EPS1 from COMMON MPRCSN. EPS1 is spatial zero  */
3680 /*     equal to 1.D-9 */
3681
3682 /*     KEYWORDS : */
3683 /*     ----------- */
3684 /*        MPRCSN,PRECISON,EPS1. */
3685
3686 /*     INPUT ARGUMENTS : */
3687 /*     ------------------ */
3688 /*        None */
3689
3690 /*     OUTPUT ARGUMENTS : */
3691 /*     ------------------- */
3692 /*        EPSILO : Value of EPS1 (spatial zero (10**-9)) */
3693
3694 /*     COMMONS USED   : */
3695 /*     ---------------- */
3696
3697 /*     REFERENCES CALLED   : */
3698 /*     ----------------------- */
3699
3700 /*     DESCRIPTION/NOTES/LIMITATIONS : */
3701 /*     ----------------------------------- */
3702 /*     EPS1 is ABSOLUTE spatial zero, so it is necessary */
3703 /*     to use it whenever it is necessary to test if a variable */
3704 /*     is null. For example, if the norm of a vector is lower than */
3705 /*     EPS1, this vector is NULL ! (when one works in */
3706 /*     REAL*8) It is absolutely not advised to test arguments  */
3707 /*     compared to EPS1**2. Taking into account the rounding errors inevitable */
3708 /*     during calculations, this causes testing compared to 0.D0. */
3709 /* > */
3710 /* ***********************************************************************
3711  */
3712
3713
3714
3715 /* ***********************************************************************
3716  */
3717
3718 /*     FUNCTION : */
3719 /*     ---------- */
3720 /*          Gives tolerances of invalidity in stream */
3721 /*          as well as limits of iterative processes */
3722
3723 /*          general context, modifiable by the user */
3724
3725 /*     KEYWORDS : */
3726 /*     ----------- */
3727 /*          PARAMETER , TOLERANCE */
3728
3729 /*     DEMSCRIPTION/NOTES/LIMITATIONS : */
3730 /*     ----------------------------------- */
3731 /*       INITIALISATION   :  profile , **VIA MPRFTX** at input in stream */
3732 /*       loading of default values of the profile in MPRFTX at input */
3733 /*       in stream. They are preserved in local variables of MPRFTX */
3734
3735 /*        Reset of default values                  : MDFINT */
3736 /*        Interactive modification by the user   : MDBINT */
3737
3738 /*        ACCESS FUNCTION  :  MMEPS1   ...  EPS1 */
3739 /*                            MEPSPB  ...  EPS3,EPS4 */
3740 /*                            MEPSLN  ...  EPS2, NITERM , NITERR */
3741 /*                            MEPSNR  ...  EPS2 , NITERM */
3742 /*                            MITERR  ...  NITERR */
3743 /* > */
3744 /* ***********************************************************************
3745  */
3746
3747 /*     NITERM : max nb of iterations */
3748 /*     NITERR : nb of rapid iterations */
3749 /*     EPS1   : tolerance of 3D null distance */
3750 /*     EPS2   : tolerance of parametric null distance */
3751 /*     EPS3   : tolerance to avoid division by 0.. */
3752 /*     EPS4   : angular tolerance */
3753
3754
3755
3756 /* ***********************************************************************
3757  */
3758     *epsilo = mmprcsn_.eps1;
3759
3760  return 0 ;
3761 } /* mmeps1_ */
3762
3763 //=======================================================================
3764 //function : mmexthi_
3765 //purpose  :
3766 //=======================================================================
3767 int mmexthi_(integer *ndegre,
3768              NCollection_Array1<doublereal>& hwgaus)
3769
3770 {
3771   /* System generated locals */
3772   integer i__1;
3773
3774   /* Local variables */
3775   integer iadd, ideb, ndeg2, nmod2, ii, ibb;
3776   integer kpt;
3777
3778 /* **********************************************************************
3779 */
3780
3781 /*     FONCTION : */
3782 /*     ---------- */
3783 /*  Extract of common LDGRTL the weight of formulas of  */
3784 /*  Gauss quadrature on all roots of Legendre polynoms of degree */
3785 /*  NDEGRE defined on [-1,1]. */
3786
3787 /*     KEYWORDS : */
3788 /*     ----------- */
3789 /*     ALL, AB_SPECIFI::COMMON&, EXTRACTION, &WEIGHT, &GAUSS. */
3790
3791 /*     INPUT ARGUMENTS : */
3792 /*     ------------------ */
3793 /*   NDEGRE : Mathematic degree of Legendre polynom. It should have */
3794 /*            2 <= NDEGRE <= 61. */
3795
3796 /*     OUTPUT ARGUMENTS : */
3797 /*     ------------------- */
3798 /*   HWGAUS : The table of weights of Gauss quadrature formulas */
3799 /*            relative to NDEGRE roots of a polynome de Legendre de */
3800 /*            degre NDEGRE. */
3801
3802 /*     COMMONS UTILISES   : */
3803 /*     ---------------- */
3804 /*     MLGDRTL */
3805
3806 /*     REFERENCES CALLED   : */
3807 /*     ----------------------- */
3808
3809 /*     DESCRIPTION/NOTES/LIMITATIONS : */
3810 /*     ----------------------------------- */
3811 /*     ATTENTION: The condition on NDEGRE ( 2 <= NDEGRE <= 61) is not  */
3812 /*     tested. The caller should make the test. */
3813
3814 /*   Name of the routine */
3815
3816
3817 /*   Common MLGDRTL: */
3818 /*   This common includes POSITIVE roots of Legendre polynims */
3819 /*   AND weights of Gauss quadrature formulas on all */
3820 /*   POSITIVE roots of Legendre polynoms. */
3821
3822
3823
3824 /* ***********************************************************************
3825  */
3826
3827 /*     FUNCTION : */
3828 /*     ---------- */
3829 /*   The common of Legendre roots. */
3830
3831 /*     KEYWORDS : */
3832 /*     ----------- */
3833 /*        BASE LEGENDRE */
3834
3835 /*     DESCRIPTION/NOTES/LIMITATIONS : */
3836 /*     ----------------------------------- */
3837 /* > */
3838 /* ***********************************************************************
3839  */
3840
3841
3842
3843
3844 /*   ROOTAB : Table of all roots of Legendre polynoms */
3845 /*   within the interval [0,1]. They are ranked for the degrees increasing from */
3846 /*   2 to 61. */
3847 /*   HILTAB : Table of Legendre interpolators concerning ROOTAB. */
3848 /*   The adressing is the same. */
3849 /*   HI0TAB : Table of Legendre interpolators for root x=0 */
3850 /*   of polynoms of UNEVEN degree. */
3851 /*   RTLTB0 : Table of Li(uk) where uk are the roots of */
3852 /*  Legendre polynom of EVEN degree. */
3853 /*   RTLTB1 : Table of Li(uk) where uk are the roots of */
3854 /*  Legendre polynom of UNEVEN degree. */
3855
3856
3857 /************************************************************************
3858 *****/
3859
3860     /* Function Body */
3861     ibb = AdvApp2Var_SysBase::mnfndeb_();
3862     if (ibb >= 3) {
3863         AdvApp2Var_SysBase::mgenmsg_("MMEXTHI", 7L);
3864     }
3865
3866     ndeg2 = *ndegre / 2;
3867     nmod2 = *ndegre % 2;
3868
3869 /*   Address of Gauss weight associated to the 1st strictly */
3870 /*   positive root of Legendre polynom of degree NDEGRE in MLGDRTL. */
3871
3872     iadd = ndeg2 * (ndeg2 - 1) / 2 + 1;
3873
3874 /*   Index of the 1st HWGAUS element associated to the 1st strictly  */
3875 /*   positive root of Legendre polynom of degree NDEGRE. */
3876
3877     ideb = (*ndegre + 1) / 2 + 1;
3878
3879 /*   Reading of weights associated to strictly positive roots. */
3880
3881     i__1 = *ndegre;
3882     for (ii = ideb; ii <= i__1; ++ii) {
3883         kpt = iadd + ii - ideb;
3884         hwgaus(ii) = mlgdrtl_.hiltab[kpt + nmod2 * 465 - 1];
3885 /* L100: */
3886     }
3887
3888 /*   For strictly negative roots, the weight is the same. */
3889 /*   i.e HW(1) = HW(NDEGRE), HW(2) = HW(NDEGRE-1), etc... */
3890
3891     i__1 = ndeg2;
3892     for (ii = 1; ii <= i__1; ++ii) {
3893         hwgaus(ii) = hwgaus(*ndegre + 1 - ii);
3894 /* L200: */
3895     }
3896
3897 /*   Case of uneven NDEGRE, 0 is root of Legendre polynom, */
3898 /*   associated Gauss weights are loaded. */
3899
3900     if (nmod2 == 1) {
3901         hwgaus(ndeg2 + 1) = mlgdrtl_.hi0tab[ndeg2];
3902     }
3903
3904 /* --------------------------- The end ----------------------------------
3905 */
3906
3907     if (ibb >= 3) {
3908         AdvApp2Var_SysBase::mgsomsg_("MMEXTHI", 7L);
3909     }
3910     return 0;
3911 } /* mmexthi_ */
3912
3913 //=======================================================================
3914 //function : mmextrl_
3915 //purpose  :
3916 //=======================================================================
3917 int mmextrl_(integer *ndegre,
3918              NCollection_Array1<doublereal>& rootlg)
3919 {
3920   /* System generated locals */
3921   integer i__1;
3922
3923   /* Local variables */
3924   integer iadd, ideb, ndeg2, nmod2, ii, ibb;
3925   integer kpt;
3926
3927
3928 /* **********************************************************************
3929 */
3930
3931 /*     FUNCTION : */
3932 /*     ---------- */
3933 /* Extract of the Common LDGRTL of Legendre polynom roots */
3934 /* of degree NDEGRE defined on [-1,1]. */
3935
3936 /*     KEYWORDS : */
3937 /*     ----------- */
3938 /*     ALL, AB_SPECIFI::COMMON&, EXTRACTION, &ROOT, &LEGENDRE. */
3939
3940 /*     INPUT ARGUMENTS : */
3941 /*     ------------------ */
3942 /*   NDEGRE : Mathematic degree of Legendre polynom.  */
3943 /*            It is required to have 2 <= NDEGRE <= 61. */
3944
3945 /*     OUTPUT ARGUMENTS : */
3946 /*     ------------------- */
3947 /*   ROOTLG : The table of roots of Legendre polynom of degree */
3948 /*            NDEGRE defined on [-1,1]. */
3949
3950 /*     COMMONS USED   : */
3951 /*     ---------------- */
3952 /*     MLGDRTL */
3953
3954 /*     REFERENCES CALLED   : */
3955 /*     ----------------------- */
3956
3957 /*     DESCRIPTION/NOTES/LIMITATIONS : */
3958 /*     ----------------------------------- */
3959 /*     ATTENTION: Condition of NDEGRE ( 2 <= NDEGRE <= 61) is not */
3960 /*     tested. The caller should make the test. */
3961 /* > */
3962 /* **********************************************************************
3963 */
3964
3965
3966 /*   Name of the routine */
3967
3968
3969 /*   Common MLGDRTL: */
3970 /*   This common includes POSITIVE roots of Legendre polynoms */
3971 /*   AND the weight of Gauss quadrature formulas on all */
3972 /*   POSITIVE roots of Legendre polynoms. */
3973
3974 /* ***********************************************************************
3975  */
3976
3977 /*     FUNCTION : */
3978 /*     ---------- */
3979 /*   The common of Legendre roots. */
3980
3981 /*     KEYWORDS : */
3982 /*     ----------- */
3983 /*        BASE LEGENDRE */
3984
3985
3986 /* ***********************************************************************
3987  */
3988
3989 /*   ROOTAB : Table of all roots of Legendre polynoms */
3990 /*   within the interval [0,1]. They are ranked for the degrees increasing from */
3991 /*   2 to 61. */
3992 /*   HILTAB : Table of Legendre interpolators concerning ROOTAB. */
3993 /*   The adressing is the same. */
3994 /*   HI0TAB : Table of Legendre interpolators for root x=0 */
3995 /*   of polynoms of UNEVEN degree. */
3996 /*   RTLTB0 : Table of Li(uk) where uk are the roots of */
3997 /*  Legendre polynom of EVEN degree. */
3998 /*   RTLTB1 : Table of Li(uk) where uk are the roots of */
3999 /*  Legendre polynom of UNEVEN degree. */
4000
4001
4002 /************************************************************************
4003 *****/
4004
4005     /* Function Body */
4006     ibb = AdvApp2Var_SysBase::mnfndeb_();
4007     if (ibb >= 3) {
4008         AdvApp2Var_SysBase::mgenmsg_("MMEXTRL", 7L);
4009     }
4010
4011     ndeg2 = *ndegre / 2;
4012     nmod2 = *ndegre % 2;
4013
4014 /*   Address of the 1st strictly positive root of Legendre polynom */
4015 /*   of degree NDEGRE in MLGDRTL. */
4016
4017     iadd = ndeg2 * (ndeg2 - 1) / 2 + 1;
4018
4019 /*   Indice, in ROOTLG, of the 1st strictly positive root */
4020 /*   of Legendre polynom of degree NDEGRE. */
4021
4022     ideb = (*ndegre + 1) / 2 + 1;
4023
4024 /*   Reading of strictly positive roots. */
4025
4026     i__1 = *ndegre;
4027     for (ii = ideb; ii <= i__1; ++ii) {
4028         kpt = iadd + ii - ideb;
4029         rootlg(ii) = mlgdrtl_.rootab[kpt + nmod2 * 465 - 1];
4030 /* L100: */
4031     }
4032
4033 /*   Strictly negative roots are equal to positive roots
4034 */
4035 /*   to the sign i.e RT(1) = -RT(NDEGRE), RT(2) = -RT(NDEGRE-1), etc...
4036 */
4037
4038     i__1 = ndeg2;
4039     for (ii = 1; ii <= i__1; ++ii) {
4040         rootlg(ii) = -rootlg(*ndegre + 1 - ii);
4041 /* L200: */
4042     }
4043
4044 /*   Case NDEGRE uneven, 0 is root of Legendre polynom. */
4045
4046     if (nmod2 == 1) {
4047         rootlg(ndeg2 + 1) = 0.;
4048     }
4049
4050 /* -------------------------------- THE END -----------------------------
4051 */
4052
4053     if (ibb >= 3) {
4054         AdvApp2Var_SysBase::mgenmsg_("MMEXTRL", 7L);
4055     }
4056     return 0;
4057 } /* mmextrl_ */
4058
4059 //=======================================================================
4060 //function : AdvApp2Var_MathBase::mmfmca8_
4061 //purpose  :
4062 //=======================================================================
4063 int AdvApp2Var_MathBase::mmfmca8_(const integer *ndimen,
4064                                   const integer *ncoefu,
4065                                   const integer *ncoefv,
4066                                   const integer *ndimax,
4067                                   const integer *ncfumx,
4068                                   const integer *,//ncfvmx,
4069                                   doublereal *tabini,
4070                                   doublereal *tabres)
4071
4072 {
4073   /* System generated locals */
4074   integer tabini_dim1, tabini_dim2, tabini_offset, tabres_dim1, tabres_dim2,
4075   tabres_offset;
4076
4077   /* Local variables */
4078   integer i__, j, k, ilong;
4079
4080
4081
4082 /* **********************************************************************
4083 */
4084
4085 /*     FUNCTION : */
4086 /*     ---------- */
4087 /*        Expansion of a table containing only most important things into a  */
4088 /*        greater data table. */
4089
4090 /*     KEYWORDS : */
4091 /*     ----------- */
4092 /*     ALL, MATH_ACCES:: CARREAU&, DECOMPRESSION, &CARREAU */
4093
4094 /*     INPUT ARGUMENTS : */
4095 /*     ------------------ */
4096 /*        NDIMEN: Dimension of the workspace. */
4097 /*        NCOEFU: Degree +1 of the table by u. */
4098 /*        NCOEFV: Degree +1 of the table by v. */
4099 /*        NDIMAX: Max dimension of the space. */
4100 /*        NCFUMX: Max Degree +1 of the table by u. */
4101 /*        NCFVMX: Max Degree +1 of the table by v. */
4102 /*        TABINI: The table to be decompressed. */
4103
4104 /*     OUTPUT ARGUMENTS : */
4105 /*     ------------------- */
4106 /*        TABRES: Decompressed table. */
4107
4108 /*     COMMONS USED   : */
4109 /*     ---------------- */
4110
4111 /*     REFERENCES CALLED   : */
4112 /*     ----------------------- */
4113
4114 /*     DESCRIPTION/NOTES/LIMITATIONS : */
4115 /*     ----------------------------------- */
4116 /*     The following call : */
4117
4118 /*  CALL MMFMCA8(NDIMEN,NCOEFU,NCOEFV,NDIMAX,NCFUMX,NCFVMX,TABINI,TABINI)
4119 */
4120
4121 /*     where TABINI is input/output argument, is possible provided */
4122 /*     that the caller has declared TABINI in (NDIMAX,NCFUMX,NCFVMX) */
4123
4124 /*     ATTENTION : it is not checked that NDIMAX >= NDIMEN, */
4125 /*                 NCOEFU >= NCFMXU and NCOEFV >= NCFMXV. */
4126 /* > */
4127 /* **********************************************************************
4128 */
4129
4130
4131     /* Parameter adjustments */
4132     tabini_dim1 = *ndimen;
4133     tabini_dim2 = *ncoefu;
4134     tabini_offset = tabini_dim1 * (tabini_dim2 + 1) + 1;
4135     tabini -= tabini_offset;
4136     tabres_dim1 = *ndimax;
4137     tabres_dim2 = *ncfumx;
4138     tabres_offset = tabres_dim1 * (tabres_dim2 + 1) + 1;
4139     tabres -= tabres_offset;
4140
4141     /* Function Body */
4142     if (*ndimax == *ndimen) {
4143         goto L1000;
4144     }
4145
4146 /* ----------------------- decompression NDIMAX<>NDIMEN -----------------
4147 */
4148
4149     for (k = *ncoefv; k >= 1; --k) {
4150         for (j = *ncoefu; j >= 1; --j) {
4151             for (i__ = *ndimen; i__ >= 1; --i__) {
4152                 tabres[i__ + (j + k * tabres_dim2) * tabres_dim1] = tabini[
4153                         i__ + (j + k * tabini_dim2) * tabini_dim1];
4154 /* L300: */
4155             }
4156 /* L200: */
4157         }
4158 /* L100: */
4159     }
4160     goto L9999;
4161
4162 /* ----------------------- decompression NDIMAX=NDIMEN ------------------
4163 */
4164
4165 L1000:
4166     if (*ncoefu == *ncfumx) {
4167         goto L2000;
4168     }
4169     ilong = (*ndimen << 3) * *ncoefu;
4170     for (k = *ncoefv; k >= 1; --k) {
4171         AdvApp2Var_SysBase::mcrfill_(&ilong,
4172                  &tabini[(k * tabini_dim2 + 1) * tabini_dim1 + 1],
4173                  &tabres[(k * tabres_dim2 + 1) * tabres_dim1 + 1]);
4174 /* L500: */
4175     }
4176     goto L9999;
4177
4178 /* ----------------- decompression NDIMAX=NDIMEN,NCOEFU=NCFUMX ----------
4179 */
4180
4181 L2000:
4182     ilong = (*ndimen << 3) * *ncoefu * *ncoefv;
4183     AdvApp2Var_SysBase::mcrfill_(&ilong,
4184              &tabini[tabini_offset],
4185              &tabres[tabres_offset]);
4186     goto L9999;
4187
4188 /* ---------------------------- The end ---------------------------------
4189 */
4190
4191 L9999:
4192     return 0;
4193 } /* mmfmca8_ */
4194
4195 //=======================================================================
4196 //function : AdvApp2Var_MathBase::mmfmca9_
4197 //purpose  :
4198 //=======================================================================
4199  int AdvApp2Var_MathBase::mmfmca9_(integer *ndimax,
4200                                    integer *ncfumx,
4201                                    integer *,//ncfvmx,
4202                                    integer *ndimen,
4203                                    integer *ncoefu,
4204                                    integer *ncoefv,
4205                                    doublereal *tabini,
4206                                    doublereal *tabres)
4207
4208 {
4209   /* System generated locals */
4210   integer tabini_dim1, tabini_dim2, tabini_offset, tabres_dim1, tabres_dim2,
4211   tabres_offset, i__1, i__2, i__3;
4212
4213     /* Local variables */
4214   integer i__, j, k, ilong;
4215
4216
4217
4218 /* **********************************************************************
4219 */
4220
4221 /*     FUNCTION : */
4222 /*     ---------- */
4223 /*        Compression of a data table in a table */
4224 /*        containing only the main data (the input table is not removed). */
4225
4226 /*     KEYWORDS: */
4227 /*     ----------- */
4228 /*     ALL, MATH_ACCES:: CARREAU&, COMPRESSION, &CARREAU */
4229
4230 /*     INPUT ARGUMENTS : */
4231 /*     ------------------ */
4232 /*        NDIMAX: Max dimension of the space. */
4233 /*        NCFUMX: Max degree +1 of the table by u. */
4234 /*        NCFVMX: Max degree +1 of the table by v. */
4235 /*        NDIMEN: Dimension of the workspace. */
4236 /*        NCOEFU: Degree +1 of the table by u. */
4237 /*        NCOEFV: Degree +1 of the table by v. */
4238 /*        TABINI: The table to compress. */
4239
4240 /*     OUTPUT ARGUMENTS : */
4241 /*     ------------------- */
4242 /*        TABRES: The compressed table. */
4243
4244 /*     COMMONS USED   : */
4245 /*     ---------------- */
4246
4247 /*     REFERENCES CALLED   : */
4248 /*     ----------------------- */
4249
4250 /*     DESCRIPTION/NOTES/LIMITATIONS : */
4251 /*     ----------------------------------- */
4252 /*     The following call : */
4253
4254 /* CALL MMFMCA9(NDIMAX,NCFUMX,NCFVMX,NDIMEN,NCOEFU,NCOEFV,TABINI,TABINI)
4255 */
4256
4257 /*     where TABINI is input/output argument, is possible provided */
4258 /*     that the caller has checked that : */
4259
4260 /*            NDIMAX > NDIMEN, */
4261 /*         or NDIMAX = NDIMEN and NCFUMX > NCOEFU */
4262 /*         or  NDIMAX = NDIMEN, NCFUMX = NCOEFU and NCFVMX > NCOEFV */
4263
4264 /*     These conditions are not tested in the program. */
4265
4266 /* > */
4267 /* **********************************************************************
4268 */
4269
4270
4271     /* Parameter adjustments */
4272     tabini_dim1 = *ndimax;
4273     tabini_dim2 = *ncfumx;
4274     tabini_offset = tabini_dim1 * (tabini_dim2 + 1) + 1;
4275     tabini -= tabini_offset;
4276     tabres_dim1 = *ndimen;
4277     tabres_dim2 = *ncoefu;
4278     tabres_offset = tabres_dim1 * (tabres_dim2 + 1) + 1;
4279     tabres -= tabres_offset;
4280
4281     /* Function Body */
4282     if (*ndimen == *ndimax) {
4283         goto L1000;
4284     }
4285
4286 /* ----------------------- Compression NDIMEN<>NDIMAX -------------------
4287 */
4288
4289     i__1 = *ncoefv;
4290     for (k = 1; k <= i__1; ++k) {
4291         i__2 = *ncoefu;
4292         for (j = 1; j <= i__2; ++j) {
4293             i__3 = *ndimen;
4294             for (i__ = 1; i__ <= i__3; ++i__) {
4295                 tabres[i__ + (j + k * tabres_dim2) * tabres_dim1] = tabini[
4296                         i__ + (j + k * tabini_dim2) * tabini_dim1];
4297 /* L300: */
4298             }
4299 /* L200: */
4300         }
4301 /* L100: */
4302     }
4303     goto L9999;
4304
4305 /* ----------------------- Compression NDIMEN=NDIMAX --------------------
4306 */
4307
4308 L1000:
4309     if (*ncoefu == *ncfumx) {
4310         goto L2000;
4311     }
4312     ilong = (*ndimen << 3) * *ncoefu;
4313     i__1 = *ncoefv;
4314     for (k = 1; k <= i__1; ++k) {
4315         AdvApp2Var_SysBase::mcrfill_(&ilong,
4316                  &tabini[(k * tabini_dim2 + 1) * tabini_dim1 + 1],
4317                  &tabres[(k * tabres_dim2 + 1) * tabres_dim1 + 1]);
4318 /* L500: */
4319     }
4320     goto L9999;
4321
4322 /* ----------------- Compression NDIMEN=NDIMAX,NCOEFU=NCFUMX ------------
4323 */
4324
4325 L2000:
4326     ilong = (*ndimen << 3) * *ncoefu * *ncoefv;
4327     AdvApp2Var_SysBase::mcrfill_(&ilong,
4328              &tabini[tabini_offset],
4329              &tabres[tabres_offset]);
4330     goto L9999;
4331
4332 /* ---------------------------- The end ---------------------------------
4333 */
4334
4335 L9999:
4336     return 0;
4337 } /* mmfmca9_ */
4338
4339 //=======================================================================
4340 //function : AdvApp2Var_MathBase::mmfmcar_
4341 //purpose  :
4342 //=======================================================================
4343 int AdvApp2Var_MathBase::mmfmcar_(integer *ndimen,
4344                                   integer *ncofmx,
4345                                   integer *ncoefu,
4346                                   integer *ncoefv,
4347                                   doublereal *patold,
4348                                   doublereal *upara1,
4349                                   doublereal *upara2,
4350                                   doublereal *vpara1,
4351                                   doublereal *vpara2,
4352                                   doublereal *patnew,
4353                                   integer *iercod)
4354
4355 {
4356   integer c__8 = 8;
4357   /* System generated locals */
4358     integer patold_dim1, patold_dim2, patnew_dim1, patnew_dim2,
4359             i__1, patold_offset,patnew_offset;
4360
4361     /* Local variables */
4362     doublereal* tbaux = 0;
4363     integer ksize, numax, kk;
4364     intptr_t iofst;
4365     integer ibb, ier;
4366
4367 /* ***********************************************************************
4368  */
4369
4370 /*     FUNCTION : */
4371 /*     ---------- */
4372 /*       LIMITATION OF A SQUARE DEFINED ON (0,1)*(0,1) BETWEEN ISOS */
4373 /*       UPARA1 AND UPARA2 (BY U) AND VPARA1 AND VPARA2 BY V. */
4374
4375 /*     KEYWORDS : */
4376 /*     ----------- */
4377 /*       LIMITATION , SQUARE , PARAMETER */
4378
4379 /*     INPUT ARGUMENTS : */
4380 /*     ------------------ */
4381 /*     NCOFMX: MAX NUMBER OF COEFF OF THE SQUARE BY U */
4382 /*     NCOEFU: NUMBER OF COEFF OF THE SQUARE BY U */
4383 /*     NCOEFV: NUMBER OF COEFF OF THE SQUARE BY V */
4384 /*     PATOLD : THE SQUARE IS LIMITED BY UPARA1,UPARA2 AND VPARA1,VPARA2
4385 .*/
4386 /*     UPARA1    : LOWER LIMIT OF U */
4387 /*     UPARA2    : UPPER LIMIT OF U */
4388 /*     VPARA1    : LOWER LIMIT OF V */
4389 /*     VPARA2    : UPPER LIMIT OF V */
4390
4391 /*     OUTPUT ARGUMENTS : */
4392 /*     ------------------- */
4393 /*     PATNEW : RELIMITED SQUARE, DEFINED ON (0,1)**2 */
4394 /*     IERCOD : =10 COEFF NB TOO GREAT OR NULL */
4395 /*              =13 PB IN THE DYNAMIC ALLOCATION */
4396 /*              = 0 OK. */
4397
4398 /*     COMMONS USED   : */
4399 /*     ---------------- */
4400
4401 /*     DESCRIPTION/NOTES/LIMITATIONS : */
4402 /*     ----------------------------------- */
4403 /* --->    The following call : */
4404 /*   CALL MMFMCAR(NCOFMX,NCOEFU,NCOEFV,PATOLD,UPARA1,UPARA2,VPARA1,VPARA2
4405 */
4406 /*              ,PATOLD), */
4407 /*        where PATOLD is input/output argument is absolutely legal. */
4408
4409 /* --->    The max number of coeff by u and v of PATOLD is 61 */
4410
4411 /* --->    If NCOEFU < NCOFMX, the data is compressed by MMFMCA9 before */
4412 /*        limitation by v to get time during the execution */
4413 /*        of MMARC41 that follows (the square is processed as a curve of
4414 */
4415 /*        dimension NDIMEN*NCOEFU possessing NCOEFV coefficients). */
4416 /* > */
4417 /* ***********************************************************************
4418  */
4419
4420 /*   Name of the routine */
4421
4422
4423     /* Parameter adjustments */
4424     patnew_dim1 = *ndimen;
4425     patnew_dim2 = *ncofmx;
4426     patnew_offset = patnew_dim1 * (patnew_dim2 + 1) + 1;
4427     patnew -= patnew_offset;
4428     patold_dim1 = *ndimen;
4429     patold_dim2 = *ncofmx;
4430     patold_offset = patold_dim1 * (patold_dim2 + 1) + 1;
4431     patold -= patold_offset;
4432
4433     /* Function Body */
4434     ibb = AdvApp2Var_SysBase::mnfndeb_();
4435     if (ibb >= 2) {
4436         AdvApp2Var_SysBase::mgenmsg_("MMFMCAR", 7L);
4437     }
4438     *iercod = 0;
4439     iofst = 0;
4440     AdvApp2Var_SysBase anAdvApp2Var_SysBase;
4441
4442 /* **********************************************************************
4443 */
4444 /*                  TEST OF COEFFICIENT NUMBERS */
4445 /* **********************************************************************
4446 */
4447
4448     if (*ncofmx < *ncoefu) {
4449         *iercod = 10;
4450         goto L9999;
4451     }
4452     if (*ncoefu < 1 || *ncoefu > 61 || *ncoefv < 1 || *ncoefv > 61) {
4453         *iercod = 10;
4454         goto L9999;
4455     }
4456
4457 /* **********************************************************************
4458 */
4459 /*                  CASE WHEN UPARA1=VPARA1=0 AND UPARA2=VPARA2=1 */
4460 /* **********************************************************************
4461 */
4462
4463     if (*upara1 == 0. && *upara2 == 1. && *vpara1 == 0. && *vpara2 == 1.) {
4464         ksize = (*ndimen << 3) * *ncofmx * *ncoefv;
4465         AdvApp2Var_SysBase::mcrfill_(&ksize,
4466                  &patold[patold_offset],
4467                  &patnew[patnew_offset]);
4468         goto L9999;
4469     }
4470
4471 /* **********************************************************************
4472 */
4473 /*                        LIMITATION BY U */
4474 /* **********************************************************************
4475 */
4476
4477     if (*upara1 == 0. && *upara2 == 1.) {
4478         goto L2000;
4479     }
4480     i__1 = *ncoefv;
4481     for (kk = 1; kk <= i__1; ++kk) {
4482         mmarc41_(ndimen, ndimen, ncoefu, &patold[(kk * patold_dim2 + 1) *
4483                 patold_dim1 + 1], upara1, upara2, &patnew[(kk * patnew_dim2 +
4484                 1) * patnew_dim1 + 1], iercod);
4485 /* L100: */
4486     }
4487
4488 /* **********************************************************************
4489 */
4490 /*                         LIMITATION BY V */
4491 /* **********************************************************************
4492 */
4493
4494 L2000:
4495     if (*vpara1 == 0. && *vpara2 == 1.) {
4496         goto L9999;
4497     }
4498
4499 /* ----------- LIMITATION BY V (WITH COMPRESSION I.E. NCOEFU<NCOFMX) ----
4500 */
4501
4502     numax = *ndimen * *ncoefu;
4503     if (*ncofmx != *ncoefu) {
4504 /* ------------------------- Dynamic allocation -------------------
4505 ---- */
4506         ksize = *ndimen * *ncoefu * *ncoefv;
4507         anAdvApp2Var_SysBase.mcrrqst_(&c__8, &ksize, tbaux, &iofst, &ier);
4508         if (ier > 0) {
4509             *iercod = 13;
4510             goto L9900;
4511         }
4512 /* --------------- Compression by (NDIMEN,NCOEFU,NCOEFV) ------------
4513 ---- */
4514         if (*upara1 == 0. && *upara2 == 1.) {
4515           AdvApp2Var_MathBase::mmfmca9_(ndimen,
4516                                         ncofmx,
4517                                         ncoefv,
4518                                         ndimen,
4519                                         ncoefu,
4520                                         ncoefv,
4521                                         &patold[patold_offset],
4522                                         &tbaux[iofst]);
4523         } else {
4524           AdvApp2Var_MathBase::mmfmca9_(ndimen,
4525                                         ncofmx,
4526                                         ncoefv,
4527                                         ndimen,
4528                                         ncoefu,
4529                                         ncoefv,
4530                                         &patnew[patnew_offset],
4531                                         &tbaux[iofst]);
4532         }
4533 /* ------------------------- Limitation by v ------------------------
4534 ---- */
4535         mmarc41_(&numax, &numax, ncoefv, &tbaux[iofst], vpara1, vpara2, &
4536                 tbaux[iofst], iercod);
4537 /* --------------------- Expansion of TBAUX into PATNEW -------------
4538 --- */
4539         AdvApp2Var_MathBase::mmfmca8_(ndimen, ncoefu, ncoefv, ndimen, ncofmx, ncoefv, &tbaux[iofst]
4540                 , &patnew[patnew_offset]);
4541         goto L9900;
4542
4543 /* -------- LIMITATION BY V (WITHOUT COMPRESSION I.E. NCOEFU=NCOFMX) ---
4544 ---- */
4545
4546     } else {
4547         if (*upara1 == 0. && *upara2 == 1.) {
4548             mmarc41_(&numax, &numax, ncoefv, &patold[patold_offset], vpara1,
4549                     vpara2, &patnew[patnew_offset], iercod);
4550         } else {
4551             mmarc41_(&numax, &numax, ncoefv, &patnew[patnew_offset], vpara1,
4552                     vpara2, &patnew[patnew_offset], iercod);
4553         }
4554         goto L9999;
4555     }
4556
4557 /* **********************************************************************
4558 */
4559 /*                             DESALLOCATION */
4560 /* **********************************************************************
4561 */
4562
4563 L9900:
4564     if (iofst != 0) {
4565         anAdvApp2Var_SysBase.mcrdelt_(&c__8, &ksize, tbaux, &iofst, &ier);
4566     }
4567     if (ier > 0) {
4568         *iercod = 13;
4569     }
4570
4571 /* ------------------------------ The end -------------------------------
4572 */
4573
4574 L9999:
4575     if (*iercod > 0) {
4576         AdvApp2Var_SysBase::maermsg_("MMFMCAR", iercod, 7L);
4577     }
4578     if (ibb >= 2) {
4579         AdvApp2Var_SysBase::mgsomsg_("MMFMCAR", 7L);
4580     }
4581     return 0;
4582 } /* mmfmcar_ */
4583
4584
4585 //=======================================================================
4586 //function : AdvApp2Var_MathBase::mmfmcb5_
4587 //purpose  :
4588 //=======================================================================
4589 int AdvApp2Var_MathBase::mmfmcb5_(integer *isenmsc,
4590                                   integer *ndimax,
4591                                   integer *ncf1mx,
4592                                   doublereal *courb1,
4593                                   integer *ncoeff,
4594                                   integer *ncf2mx,
4595                                   integer *ndimen,
4596                                   doublereal *courb2,
4597                                   integer *iercod)
4598
4599 {
4600   /* System generated locals */
4601   integer courb1_dim1, courb1_offset, courb2_dim1, courb2_offset, i__1,
4602   i__2;
4603
4604   /* Local variables */
4605   integer i__, nboct, nd;
4606
4607
4608 /* **********************************************************************
4609 */
4610
4611 /*     FUNCTION : */
4612 /*     ---------- */
4613 /*       Reformating (and  eventual compression/decompression) of curve */
4614 /*       (ndim,.) by (.,ndim) and vice versa. */
4615
4616 /*     KEYWORDS : */
4617 /*     ----------- */
4618 /*      ALL , MATH_ACCES :: */
4619 /*      COURBE&, REORGANISATION,COMPRESSION,INVERSION , &COURBE */
4620
4621 /*     INPUT ARGUMENTS : */
4622 /*     -------------------- */
4623 /*        ISENMSC : required direction of the transfer : */
4624 /*           1   :  passage of (NDIMEN,.) ---> (.,NDIMEN)  direction to AB
4625 */
4626 /*          -1   :  passage of (.,NDIMEN) ---> (NDIMEN,.)  direction to TS,T
4627 V*/
4628 /*        NDIMAX : format / dimension */
4629 /*        NCF1MX : format by t of COURB1 */
4630 /*   if ISENMSC= 1 : COURB1: The curve to be processed (NDIMAX,.) */
4631 /*        NCOEFF : number of coeff of the curve */
4632 /*        NCF2MX : format by t of COURB2 */
4633 /*        NDIMEN : dimension of the curve and format of COURB2 */
4634 /*   if ISENMSC=-1 : COURB2: The curve to be processed (.,NDIMEN) */
4635
4636 /*     OUTPUT ARGUMENTS : */
4637 /*     --------------------- */
4638 /*   if ISENMSC= 1 : COURB2: The resulting curve (.,NDIMEN) */
4639 /*   if ISENMSC=-1 : COURB1: The resulting curve (NDIMAX,.) */
4640
4641 /*     COMMONS USED : */
4642 /*     ------------------ */
4643
4644 /*     REFERENCES CALLED : */
4645 /*     --------------------- */
4646
4647 /*     DESCRIPTION/NOTES/LIMITATIONS : */
4648 /*     ----------------------------------- */
4649 /*     allow to process the usual transfers as follows : */
4650 /*     | ---- ISENMSC = 1 ---- |      | ---- ISENMSC =-1 ----- | */
4651 /*    TS  (3,21) --> (21,3)  AB  ;  AB  (21,3) --> (3,21)  TS */
4652 /*    TS  (3,21) --> (NU,3)  AB  ;  AB  (NU,3) --> (3,21)  TS */
4653 /*        (3,NU) --> (21,3)  AB  ;  AB  (21,3) --> (3,NU) */
4654 /*        (3,NU) --> (NU,3)  AB  ;  AB  (NU,3) --> (3,NU) */
4655 /* > */
4656 /* ***********************************************************************
4657  */
4658
4659
4660     /* Parameter adjustments */
4661     courb1_dim1 = *ndimax;
4662     courb1_offset = courb1_dim1 + 1;
4663     courb1 -= courb1_offset;
4664     courb2_dim1 = *ncf2mx;
4665     courb2_offset = courb2_dim1 + 1;
4666     courb2 -= courb2_offset;
4667
4668     /* Function Body */
4669     if (*ndimen > *ndimax || *ncoeff > *ncf1mx || *ncoeff > *ncf2mx) {
4670         goto L9119;
4671     }
4672
4673     if (*ndimen == 1 && *ncf1mx == *ncf2mx) {
4674         nboct = *ncf2mx << 3;
4675         if (*isenmsc == 1) {
4676             AdvApp2Var_SysBase::mcrfill_(&nboct,
4677                      &courb1[courb1_offset],
4678                      &courb2[courb2_offset]);
4679         }
4680         if (*isenmsc == -1) {
4681             AdvApp2Var_SysBase::mcrfill_(&nboct,
4682                      &courb2[courb2_offset],
4683                      &courb1[courb1_offset]);
4684         }
4685         *iercod = -3136;
4686         goto L9999;
4687     }
4688
4689     *iercod = 0;
4690     if (*isenmsc == 1) {
4691         i__1 = *ndimen;
4692         for (nd = 1; nd <= i__1; ++nd) {
4693             i__2 = *ncoeff;
4694             for (i__ = 1; i__ <= i__2; ++i__) {
4695                 courb2[i__ + nd * courb2_dim1] = courb1[nd + i__ *
4696                         courb1_dim1];
4697 /* L400: */
4698             }
4699 /* L500: */
4700         }
4701     } else if (*isenmsc == -1) {
4702         i__1 = *ndimen;
4703         for (nd = 1; nd <= i__1; ++nd) {
4704             i__2 = *ncoeff;
4705             for (i__ = 1; i__ <= i__2; ++i__) {
4706                 courb1[nd + i__ * courb1_dim1] = courb2[i__ + nd *
4707                         courb2_dim1];
4708 /* L1400: */
4709             }
4710 /* L1500: */
4711         }
4712     } else {
4713         *iercod = 3164;
4714     }
4715
4716     goto L9999;
4717
4718 /* ***********************************************************************
4719  */
4720
4721 L9119:
4722     *iercod = 3119;
4723
4724 L9999:
4725     if (*iercod != 0) {
4726         AdvApp2Var_SysBase::maermsg_("MMFMCB5", iercod, 7L);
4727     }
4728     return 0;
4729 } /* mmfmcb5_ */
4730
4731 //=======================================================================
4732 //function : AdvApp2Var_MathBase::mmfmtb1_
4733 //purpose  :
4734 //=======================================================================
4735 int AdvApp2Var_MathBase::mmfmtb1_(integer *maxsz1,
4736                                   doublereal *table1,
4737                                   integer *isize1,
4738                                   integer *jsize1,
4739                                   integer *maxsz2,
4740                                   doublereal *table2,
4741                                   integer *isize2,
4742                                   integer *jsize2,
4743                                   integer *iercod)
4744 {
4745   integer c__8 = 8;
4746
4747    /* System generated locals */
4748     integer table1_dim1, table1_offset, table2_dim1, table2_offset, i__1,
4749             i__2;
4750
4751     /* Local variables */
4752     doublereal* work = 0;
4753     integer ilong, isize, ii, jj, ier = 0;
4754     intptr_t iofst = 0,iipt, jjpt;
4755
4756
4757 /************************************************************************
4758 *******/
4759
4760 /*     FUNCTION : */
4761 /*     ---------- */
4762 /*     Inversion of elements of a rectangular table (T1(i,j) */
4763 /*     loaded in T2(j,i)) */
4764
4765 /*     KEYWORDS : */
4766 /*     ----------- */
4767 /*      ALL, MATH_ACCES :: TABLEAU&, INVERSION, &TABLEAU */
4768
4769 /*     INPUT ARGUMENTS : */
4770 /*     ------------------ */
4771 /*     MAXSZ1: Max Nb of elements by the 1st dimension of TABLE1. */
4772 /*     TABLE1: Table of reals by two dimensions. */
4773 /*     ISIZE1: Nb of useful elements of TABLE1 on the 1st dimension */
4774 /*     JSIZE1: Nb of useful elements of TABLE1 on the 2nd dimension */
4775 /*     MAXSZ2: Nb max of elements by the 1st dimension of TABLE2. */
4776
4777 /*     OUTPUT ARGUMENTS : */
4778 /*     ------------------- */
4779 /*     TABLE2: Table of reals by two dimensions, containing the transposition */
4780 /*             of the rectangular table TABLE1. */
4781 /*     ISIZE2: Nb of useful elements of TABLE2 on the 1st dimension */
4782 /*     JSIZE2: Nb of useful elements of TABLE2 on the 2nd dimension */
4783 /*     IERCOD: Erroe coder. */
4784 /*             = 0, ok. */
4785 /*             = 1, error in the dimension of tables */
4786 /*                  ether MAXSZ1 < ISIZE1 (table TABLE1 too small). */
4787 /*                  or MAXSZ2 < JSIZE1 (table TABLE2 too small). */
4788
4789 /*     COMMONS USED   : */
4790 /*     ---------------- */
4791
4792 /*     REFERENCES CALLED   : */
4793 /*     ---------------------- */
4794
4795 /*     DESCRIPTION/NOTES/LIMITATIONS : */
4796 /*     ----------------------------------- */
4797 /*    It is possible to use TABLE1 as input and output table i.e. */
4798 /*    call: */
4799 /*    CALL MMFMTB1(MAXSZ1,TABLE1,ISIZE1,JSIZE1,MAXSZ2,TABLE1 */
4800 /*               ,ISIZE2,JSIZE2,IERCOD) */
4801 /*    is valuable. */
4802 /* > */
4803 /* **********************************************************************
4804 */
4805
4806
4807     /* Parameter adjustments */
4808     table1_dim1 = *maxsz1;
4809     table1_offset = table1_dim1 + 1;
4810     table1 -= table1_offset;
4811     table2_dim1 = *maxsz2;
4812     table2_offset = table2_dim1 + 1;
4813     table2 -= table2_offset;
4814     AdvApp2Var_SysBase anAdvApp2Var_SysBase;
4815
4816     /* Function Body */
4817     *iercod = 0;
4818     if (*isize1 > *maxsz1 || *jsize1 > *maxsz2) {
4819         goto L9100;
4820     }
4821
4822     iofst = 0;
4823     isize = *maxsz2 * *isize1;
4824     anAdvApp2Var_SysBase.mcrrqst_(&c__8, &isize, work, &iofst, &ier);
4825     if (ier > 0) {
4826         goto L9200;
4827     }
4828
4829 /*             DO NOT BE AFRAID OF CRUSHING. */
4830
4831     i__1 = *isize1;
4832     for (ii = 1; ii <= i__1; ++ii) {
4833         iipt = (ii - 1) * *maxsz2 + iofst;
4834         i__2 = *jsize1;
4835         for (jj = 1; jj <= i__2; ++jj) {
4836             jjpt = iipt + (jj - 1);
4837             work[jjpt] = table1[ii + jj * table1_dim1];
4838 /* L200: */
4839         }
4840 /* L100: */
4841     }
4842     ilong = isize << 3;
4843     AdvApp2Var_SysBase::mcrfill_(&ilong,
4844              &work[iofst],
4845              &table2[table2_offset]);
4846
4847 /* -------------- The number of elements of TABLE2 is returned ------------
4848 */
4849
4850     ii = *isize1;
4851     *isize2 = *jsize1;
4852     *jsize2 = ii;
4853
4854     goto L9999;
4855
4856 /* ------------------------------- THE END ------------------------------
4857 */
4858 /* --> Invalid input. */
4859 L9100:
4860     *iercod = 1;
4861     goto L9999;
4862 /* --> Pb of allocation. */
4863 L9200:
4864     *iercod = 2;
4865     goto L9999;
4866
4867 L9999:
4868     if (iofst != 0) {
4869         anAdvApp2Var_SysBase.mcrdelt_(&c__8, &isize, work, &iofst, &ier);
4870     }
4871     if (ier > 0) {
4872         *iercod = 2;
4873     }
4874     return 0;
4875 } /* mmfmtb1_ */
4876
4877 //=======================================================================
4878 //function : AdvApp2Var_MathBase::mmgaus1_
4879 //purpose  :
4880 //=======================================================================
4881 int AdvApp2Var_MathBase::mmgaus1_(integer *ndimf,
4882                                   int (*bfunx) (
4883                                                 integer *ninteg,
4884                                                 doublereal *parame,
4885                                                 doublereal *vfunj1,
4886                                                 integer *iercod
4887                                                 ),
4888
4889                                   integer *k,
4890                                   doublereal *xd,
4891                                   doublereal *xf,
4892                                   doublereal *saux1,
4893                                   doublereal *saux2,
4894                                   doublereal *somme,
4895                                   integer *niter,
4896                                   integer *iercod)
4897 {
4898   /* System generated locals */
4899   integer i__1, i__2;
4900
4901   /* Local variables */
4902   integer ndeg;
4903   doublereal h__[20];
4904   integer j;
4905   doublereal t, u[20], x;
4906   integer idimf;
4907   doublereal c1x, c2x;
4908 /* **********************************************************************
4909 */
4910
4911 /*      FUNCTION : */
4912 /*      -------- */
4913
4914 /*      Calculate the integral of  function BFUNX passed in parameter */
4915 /*      between limits XD and XF . */
4916 /*      The function should be calculated for any value */
4917 /*      of the variable in the given interval.. */
4918 /*      The method GAUSS-LEGENDRE is used. */
4919 /*      For explications refer to the book : */
4920 /*          Complements de mathematiques a l'usage des Ingenieurs de */
4921 /*          l'electrotechnique et des telecommunications. */
4922 /*          Par Andre ANGOT - Collection technique et scientifique du CNET
4923  */
4924 /*          page 772 .... */
4925 /*      The degree of LEGENDRE polynoms used is passed in parameter.
4926  */
4927 /*      KEYWORDS : */
4928 /*      --------- */
4929 /*         INTEGRATION,LEGENDRE,GAUSS */
4930
4931 /*      INPUT ARGUMENTS : */
4932 /*      ------------------ */
4933
4934 /*      NDIMF : Dimension of the function */
4935 /*      BFUNX : Function to integrate passed as argument */
4936 /*              Should be declared as EXTERNAL in the call routine. */
4937 /*                   SUBROUTINE BFUNX(NDIMF,X,VAL,IER) */
4938 /*                   REAL *8 X,VAL */
4939 /*     K      : Parameter determining the degree of the LEGENDRE polynom that
4940 */
4941 /*               can take a value between 0 and 10. */
4942 /*               The degree of the polynom is equal to 4 k, that is 4, 8,
4943 */
4944 /*               12, 16, 20, 24, 28, 32, 36 and 40. */
4945 /*               If K is not correct, the degree is set to 40 directly.
4946 */
4947 /*      XD     : Lower limit of the interval of integration. */
4948 /*      XF     : Upper limit of the interval of integration. */
4949 /*      SAUX1  : Auxiliary table */
4950 /*      SAUX2  : Auxiliary table */
4951
4952 /*      OUTPUT ARGUMENTS : */
4953 /*      ------------------- */
4954
4955 /*      SOMME : Value of the integral */
4956 /*      NITER : Number of iterations to be carried out. */
4957 /*              It is equal to the degree of the polynom. */
4958
4959 /*      IER   : Error code : */
4960 /*              < 0 ==> Attention - Warning */
4961 /*              = 0 ==> Everything is OK */
4962 /*              > 0 ==> Critical error - Apply special processing */
4963 /*                  ==> Error in the calculation of BFUNX (return code */
4964 /*                      of this routine */
4965
4966 /*              If error => SUM = 0 */
4967
4968 /*      COMMONS USED : */
4969 /*      ----------------- */
4970
4971
4972
4973 /*     REFERENCES CALLED   : */
4974 /*     ---------------------- */
4975
4976 /*     Type  Name */
4977 /*    @      BFUNX               MVGAUS0 */
4978
4979 /*      DESCRIPTION/NOTES/LIMITATIONS : */
4980 /*      --------------------------------- */
4981
4982 /*      See the explanations detailed in the listing */
4983 /*      Use of the GAUSS method (orthogonal polynoms) */
4984 /*      The symmetry of roots of these polynomes is used */
4985 /*      Depending on K, the degree of the interpolated polynom grows.
4986 */
4987 /*      If you wish to calculate the integral with a given precision, */
4988 /*      loop on k varying from 1 to 10 and test the difference of 2
4989 */
4990 /*      consecutive iterations. Stop the loop if this difference is less that */
4991 /*      an epsilon value set to 10E-6 for example. */
4992 /*      If S1 and S2 are 2 successive iterations, test following this example :
4993  */
4994
4995 /*            AF=DABS(S1-S2) */
4996 /*            AS=DABS(S2) */
4997 /*            If AS < 1 test if FS < eps otherwise test if AF/AS < eps
4998 */
4999 /*            --        -----                    ----- */
5000 /* > */
5001 /************************************************************************
5002 ******/
5003 /*     DECLARATIONS */
5004 /************************************************************************
5005 ******/
5006
5007
5008
5009 /* ****** General Initialization */
5010
5011     /* Parameter adjustments */
5012     --somme;
5013     --saux2;
5014     --saux1;
5015
5016     /* Function Body */
5017     AdvApp2Var_SysBase::mvriraz_(ndimf,
5018              &somme[1]);
5019     *iercod = 0;
5020
5021 /* ****** Loading of coefficients U and H ** */
5022 /* -------------------------------------------- */
5023
5024     mvgaus0_(k, u, h__, &ndeg, iercod);
5025     if (*iercod > 0) {
5026         goto L9999;
5027     }
5028
5029 /* ****** C1X => Medium interval point  [XD,XF] */
5030 /* ****** C2X => 1/2 amplitude interval [XD,XF] */
5031
5032     c1x = (*xf + *xd) * .5;
5033     c2x = (*xf - *xd) * .5;
5034
5035 /* ---------------------------------------- */
5036 /* ****** Integration for degree NDEG ** */
5037 /* ---------------------------------------- */
5038
5039     i__1 = ndeg;
5040     for (j = 1; j <= i__1; ++j) {
5041         t = c2x * u[j - 1];
5042
5043         x = c1x + t;
5044         (*bfunx)(ndimf, &x, &saux1[1], iercod);
5045         if (*iercod != 0) {
5046             goto L9999;
5047         }
5048
5049         x = c1x - t;
5050         (*bfunx)(ndimf, &x, &saux2[1], iercod);
5051         if (*iercod != 0) {
5052             goto L9999;
5053         }
5054
5055         i__2 = *ndimf;
5056         for (idimf = 1; idimf <= i__2; ++idimf) {
5057             somme[idimf] += h__[j - 1] * (saux1[idimf] + saux2[idimf]);
5058         }
5059
5060     }
5061
5062     *niter = ndeg << 1;
5063     i__1 = *ndimf;
5064     for (idimf = 1; idimf <= i__1; ++idimf) {
5065         somme[idimf] *= c2x;
5066     }
5067
5068 /* ****** End of sub-program ** */
5069
5070 L9999:
5071
5072  return 0   ;
5073 } /* mmgaus1_ */
5074 //=======================================================================
5075 //function : mmherm0_
5076 //purpose  :
5077 //=======================================================================
5078 int mmherm0_(doublereal *debfin,
5079              integer *iercod)
5080 {
5081   integer c__576 = 576;
5082   integer c__6 = 6;
5083
5084
5085    /* System generated locals */
5086     integer i__1, i__2;
5087     doublereal d__1;
5088
5089     /* Local variables */
5090     doublereal amat[36] /* was [6][6] */;
5091     integer iord[2];
5092     doublereal prod;
5093     integer iord1, iord2;
5094     doublereal miden[36]        /* was [6][6] */;
5095     integer ncmat;
5096     doublereal epspi, d1, d2;
5097     integer ii, jj, pp, ncf;
5098     doublereal cof[6];
5099     integer iof[2], ier;
5100     doublereal mat[36]  /* was [6][6] */;
5101     integer cot;
5102     doublereal abid[72] /* was [12][6] */;
5103 /* ***********************************************************************
5104  */
5105
5106 /*     FUNCTION : */
5107 /*     ---------- */
5108 /*      INIT OF COEFFS. OF POLYNOMS OF HERMIT INTERPOLATION */
5109
5110 /*     KEYWORDS : */
5111 /*     ----------- */
5112 /*      MATH_ACCES :: HERMITE */
5113
5114 /*     INPUT ARGUMENTS */
5115 /*     -------------------- */
5116 /*       DEBFIN : PARAMETERS DEFINING THE CONSTRAINTS */
5117 /*                 DEBFIN(1) : FIRST PARAMETER */
5118 /*                 DEBFIN(2) : SECOND PARAMETER */
5119
5120 /*      ONE SHOULD HAVE: */
5121 /*                 ABS (DEBFIN(I)) < 100 */
5122 /*                 and */
5123 /*                 (ABS(DEBFIN(1)+ABS(DEBFIN(2))) > 1/100 */
5124 /*           (for overflows) */
5125
5126 /*      ABS(DEBFIN(2)-DEBFIN(1)) / (ABS(DEBFIN(1)+ABS(DEBFIN(2))) > 1/100
5127 */
5128 /*           (for the conditioning) */
5129
5130
5131 /*     OUTPUT ARGUMENTS : */
5132 /*     --------------------- */
5133
5134 /*       IERCOD : Error code : 0 : O.K. */
5135 /*                                1 : value of DEBFIN */
5136 /*                                are unreasonable */
5137 /*                                -1 : init was already done */
5138 /*                                   (OK but no processing) */
5139
5140 /*     COMMONS USED : */
5141 /*     ------------------ */
5142
5143 /*     REFERENCES CALLED : */
5144 /*     ---------------------- */
5145 /*     Type  Name */
5146
5147 /*     DESCRIPTION/NOTES/LIMITATIONS : */
5148 /*     ----------------------------------- */
5149
5150 /*        This program initializes the coefficients of Hermit polynoms */
5151 /*     that are read later by MMHERM1 */
5152 /* ***********************************************************************
5153  */
5154
5155
5156
5157 /* **********************************************************************
5158 */
5159
5160 /*     FUNCTION : */
5161 /*     ---------- */
5162 /*      Used to STORE  coefficients of Hermit interpolation polynoms */
5163
5164 /*     KEYWORDS : */
5165 /*     ----------- */
5166 /*      HERMITE */
5167
5168 /*     DEMSCRIPTION/NOTES/LIMITATIONS : */
5169 /*     ----------------------------------- */
5170
5171 /*     The coefficients of hermit polynoms are calculated by */
5172 /*     the routine MMHERM0 and read by the routine MMHERM1 */
5173 /* > */
5174 /* **********************************************************************
5175 */
5176
5177
5178
5179
5180
5181 /*     NBCOEF is the size of CMHERM (see below) */
5182 /* ***********************************************************************
5183  */
5184
5185
5186
5187
5188
5189
5190
5191 /* ***********************************************************************
5192  */
5193 /*     Data checking */
5194 /* ***********************************************************************
5195  */
5196
5197
5198     /* Parameter adjustments */
5199     --debfin;
5200
5201     /* Function Body */
5202     d1 = advapp_abs(debfin[1]);
5203     if (d1 > (float)100.) {
5204         goto L9101;
5205     }
5206
5207     d2 = advapp_abs(debfin[2]);
5208     if (d2 > (float)100.) {
5209         goto L9101;
5210     }
5211
5212     d2 = d1 + d2;
5213     if (d2 < (float).01) {
5214         goto L9101;
5215     }
5216
5217     d1 = (d__1 = debfin[2] - debfin[1], advapp_abs(d__1));
5218     if (d1 / d2 < (float).01) {
5219         goto L9101;
5220     }
5221
5222
5223 /* ***********************************************************************
5224  */
5225 /*     Initialization */
5226 /* ***********************************************************************
5227  */
5228
5229     *iercod = 0;
5230
5231     epspi = 1e-10;
5232
5233
5234 /* ***********************************************************************
5235  */
5236
5237 /*     IS IT ALREADY INITIALIZED ? */
5238
5239     d1 = advapp_abs(debfin[1]) + advapp_abs(debfin[2]);
5240     d1 *= 16111959;
5241
5242     if (debfin[1] != mmcmher_.tdebut) {
5243         goto L100;
5244     }
5245     if (debfin[2] != mmcmher_.tfinal) {
5246         goto L100;
5247     }
5248     if (d1 != mmcmher_.verifi) {
5249         goto L100;
5250     }
5251
5252
5253     goto L9001;
5254
5255
5256 /* ***********************************************************************
5257  */
5258 /*     CALCULATION */
5259 /* ***********************************************************************
5260  */
5261
5262
5263 L100:
5264
5265 /*     Init. matrix identity : */
5266
5267     ncmat = 36;
5268     AdvApp2Var_SysBase::mvriraz_(&ncmat,
5269              miden);
5270
5271     for (ii = 1; ii <= 6; ++ii) {
5272         miden[ii + ii * 6 - 7] = 1.;
5273 /* L110: */
5274     }
5275
5276
5277
5278 /*     Init to 0 of table CMHERM */
5279
5280     AdvApp2Var_SysBase::mvriraz_(&c__576, mmcmher_.cmherm);
5281
5282 /*     Calculation by solution of linear systems */
5283
5284     for (iord1 = -1; iord1 <= 2; ++iord1) {
5285         for (iord2 = -1; iord2 <= 2; ++iord2) {
5286
5287             iord[0] = iord1;
5288             iord[1] = iord2;
5289
5290
5291             iof[0] = 0;
5292             iof[1] = iord[0] + 1;
5293
5294
5295             ncf = iord[0] + iord[1] + 2;
5296
5297 /*        Calculate matrix MAT to invert: */
5298
5299             for (cot = 1; cot <= 2; ++cot) {
5300
5301
5302                 if (iord[cot - 1] > -1) {
5303                     prod = 1.;
5304                     i__1 = ncf;
5305                     for (jj = 1; jj <= i__1; ++jj) {
5306                         cof[jj - 1] = 1.;
5307 /* L200: */
5308                     }
5309                 }
5310
5311                 i__1 = iord[cot - 1] + 1;
5312                 for (pp = 1; pp <= i__1; ++pp) {
5313
5314                     ii = pp + iof[cot - 1];
5315
5316                     prod = 1.;
5317
5318                     i__2 = pp - 1;
5319                     for (jj = 1; jj <= i__2; ++jj) {
5320                         mat[ii + jj * 6 - 7] = (float)0.;
5321 /* L300: */
5322                     }
5323
5324                     i__2 = ncf;
5325                     for (jj = pp; jj <= i__2; ++jj) {
5326
5327 /*        everything is done in these 3 lines
5328  */
5329
5330                         mat[ii + jj * 6 - 7] = cof[jj - 1] * prod;
5331                         cof[jj - 1] *= jj - pp;
5332                         prod *= debfin[cot];
5333
5334 /* L400: */
5335                     }
5336 /* L500: */
5337                 }
5338
5339 /* L1000: */
5340             }
5341
5342 /*     Inversion */
5343
5344             if (ncf >= 1) {
5345                 AdvApp2Var_MathBase::mmmrslwd_(&c__6, &ncf, &ncf, mat, miden, &epspi, abid, amat, &
5346                         ier);
5347                 if (ier > 0) {
5348                     goto L9101;
5349                 }
5350             }
5351
5352             for (cot = 1; cot <= 2; ++cot) {
5353                 i__1 = iord[cot - 1] + 1;
5354                 for (pp = 1; pp <= i__1; ++pp) {
5355                     i__2 = ncf;
5356                     for (ii = 1; ii <= i__2; ++ii) {
5357                         mmcmher_.cmherm[ii + (pp + (cot + ((iord1 + (iord2 <<
5358                                 2)) << 1)) * 3) * 6 + 155] = amat[ii + (pp +
5359                                 iof[cot - 1]) * 6 - 7];
5360 /* L1300: */
5361                     }
5362 /* L1400: */
5363                 }
5364 /* L1500: */
5365             }
5366
5367 /* L2000: */
5368         }
5369 /* L2010: */
5370     }
5371
5372 /* ***********************************************************************
5373  */
5374
5375 /*     The initialized flag is located: */
5376
5377     mmcmher_.tdebut = debfin[1];
5378     mmcmher_.tfinal = debfin[2];
5379
5380     d1 = advapp_abs(debfin[1]) + advapp_abs(debfin[2]);
5381     mmcmher_.verifi = d1 * 16111959;
5382
5383
5384 /* ***********************************************************************
5385  */
5386
5387     goto L9999;
5388
5389 /* ***********************************************************************
5390  */
5391
5392 L9101:
5393     *iercod = 1;
5394     goto L9999;
5395
5396 L9001:
5397     *iercod = -1;
5398     goto L9999;
5399
5400 /* ***********************************************************************
5401  */
5402
5403 L9999:
5404
5405     AdvApp2Var_SysBase::maermsg_("MMHERM0", iercod, 7L);
5406
5407 /* ***********************************************************************
5408  */
5409  return 0 ;
5410 } /* mmherm0_ */
5411
5412 //=======================================================================
5413 //function : mmherm1_
5414 //purpose  :
5415 //=======================================================================
5416 int mmherm1_(doublereal *debfin,
5417              integer *ordrmx,
5418              integer *iordre,
5419              doublereal *hermit,
5420              integer *iercod)
5421 {
5422   /* System generated locals */
5423   integer hermit_dim1, hermit_dim2, hermit_offset;
5424
5425   /* Local variables */
5426   integer nbval;
5427   doublereal d1;
5428   integer cot;
5429
5430 /* ***********************************************************************
5431  */
5432
5433 /*     FUNCTION : */
5434 /*     ---------- */
5435 /*      reading of coeffs. of HERMIT interpolation polynoms */
5436
5437 /*     KEYWORDS : */
5438 /*     ----------- */
5439 /*      MATH_ACCES :: HERMIT */
5440
5441 /*     INPUT ARGUMENTS : */
5442 /*     -------------------- */
5443 /*       DEBFIN : PARAMETES DEFINING THE CONSTRAINTS */
5444 /*                 DEBFIN(1) : FIRST PARAMETER */
5445 /*                 DEBFIN(2) : SECOND PARAMETER */
5446
5447 /*           Should be equal to the corresponding arguments during the */
5448 /*           last call to MMHERM0 for the initialization of coeffs. */
5449
5450 /*       ORDRMX : indicates the dimensioning of HERMIT: */
5451 /*              there is no choice : ORDRMX should be equal to the value */
5452 /*              of PARAMETER IORDMX of INCLUDE MMCMHER, or 2 for the moment */
5453
5454 /*       IORDRE (2) : Orders of constraints in each corresponding parameter DEBFIN(I) */
5455 /*              should be between -1 (no constraints) and ORDRMX. */
5456
5457
5458 /*     OUTPUT ARGUMENTS : */
5459 /*     --------------------- */
5460
5461 /*       HERMIT : HERMIT(1:IORDRE(1)+IORDRE(2)+2, j, cote) are the  */
5462 /*       coefficients in the canonic base of Hermit polynom */
5463 /*       corresponding to orders IORDRE with parameters DEBFIN for */
5464 /*       the constraint of order j on DEBFIN(cote). j is between 0 and IORDRE(cote). */
5465
5466
5467 /*       IERCOD : Error code : */
5468 /*          -1: O.K but necessary to reinitialize the coefficients */
5469 /*                 (info for optimization) */
5470 /*          0 : O.K. */
5471 /*          1 : Error in MMHERM0 */
5472 /*          2 : arguments invalid */
5473
5474 /*     COMMONS USED : */
5475 /*     ------------------ */
5476
5477 /*     REFERENCES CALLED   : */
5478 /*     ---------------------- */
5479 /*     Type  Name */
5480
5481 /*     DESCRIPTION/NOTES/LIMITATIONS : */
5482 /*     ----------------------------------- */
5483
5484 /*     This program reads coefficients of Hermit polynoms */
5485 /*     that were earlier initialized by MMHERM0 */
5486
5487 /* PMN : initialisation is no more done by the caller. */
5488
5489
5490 /* ***********************************************************************
5491  */
5492
5493
5494
5495 /* **********************************************************************
5496 */
5497
5498 /*     FUNCTION : */
5499 /*     ---------- */
5500 /*      Serves to STORE the coefficients of Hermit interpolation polynoms */
5501
5502 /*     KEYWORDS : */
5503 /*     ----------- */
5504 /*      HERMITE */
5505
5506 /*     DEMSCRIPTION/NOTES/LIMITATIONS : */
5507 /*     ----------------------------------- */
5508
5509 /*     the coefficients of Hetmit polynoms are calculated by */
5510 /*     routine MMHERM0 and read by routine MMHERM1 */
5511
5512 /* > */
5513 /* **********************************************************************
5514 */
5515
5516
5517
5518
5519
5520 /*     NBCOEF is the size of CMHERM (see lower) */
5521
5522
5523
5524 /* ***********************************************************************
5525  */
5526
5527
5528
5529
5530
5531 /* ***********************************************************************
5532  */
5533 /*     Initializations */
5534 /* ***********************************************************************
5535  */
5536
5537     /* Parameter adjustments */
5538     --debfin;
5539     hermit_dim1 = (*ordrmx << 1) + 2;
5540     hermit_dim2 = *ordrmx + 1;
5541     hermit_offset = hermit_dim1 * hermit_dim2 + 1;
5542     hermit -= hermit_offset;
5543     --iordre;
5544
5545     /* Function Body */
5546     *iercod = 0;
5547
5548
5549 /* ***********************************************************************
5550  */
5551 /*     Data Checking */
5552 /* ***********************************************************************
5553  */
5554
5555
5556     if (*ordrmx != 2) {
5557         goto L9102;
5558     }
5559
5560     for (cot = 1; cot <= 2; ++cot) {
5561         if (iordre[cot] < -1) {
5562             goto L9102;
5563         }
5564         if (iordre[cot] > *ordrmx) {
5565             goto L9102;
5566         }
5567 /* L100: */
5568     }
5569
5570
5571 /*     IS-IT CORRECTLY INITIALIZED ? */
5572
5573     d1 = advapp_abs(debfin[1]) + advapp_abs(debfin[2]);
5574     d1 *= 16111959;
5575
5576 /*     OTHERWISE IT IS INITIALIZED */
5577
5578     if (debfin[1] != mmcmher_.tdebut || debfin[2] != mmcmher_.tfinal || d1
5579             != mmcmher_.verifi) {
5580         *iercod = -1;
5581         mmherm0_(&debfin[1], iercod);
5582         if (*iercod > 0) {
5583             goto L9101;
5584         }
5585     }
5586
5587
5588 /* ***********************************************************************
5589  */
5590 /*        READING */
5591 /* ***********************************************************************
5592  */
5593
5594     nbval = 36;
5595
5596     AdvApp2Var_SysBase::msrfill_(&nbval, &mmcmher_.cmherm[((((iordre[1] + (iordre[2] << 2)) << 1)
5597             + 1) * 3 + 1) * 6 + 156], &hermit[hermit_offset]);
5598
5599 /* ***********************************************************************
5600  */
5601
5602     goto L9999;
5603
5604 /* ***********************************************************************
5605  */
5606
5607 L9101:
5608     *iercod = 1;
5609     goto L9999;
5610
5611 L9102:
5612     *iercod = 2;
5613     goto L9999;
5614
5615 /* ***********************************************************************
5616  */
5617
5618 L9999:
5619
5620     AdvApp2Var_SysBase::maermsg_("MMHERM1", iercod, 7L);
5621
5622 /* ***********************************************************************
5623  */
5624  return 0 ;
5625 } /* mmherm1_ */
5626
5627 //=======================================================================
5628 //function : AdvApp2Var_MathBase::mmhjcan_
5629 //purpose  :
5630 //=======================================================================
5631 int AdvApp2Var_MathBase::mmhjcan_(integer *ndimen,
5632                             integer *ncourb,
5633                             integer *ncftab,
5634                             integer *orcont,
5635                             integer *ncflim,
5636                             doublereal *tcbold,
5637                             doublereal *tdecop,
5638                             doublereal *tcbnew,
5639                             integer *iercod)
5640
5641 {
5642   integer c__2 = 2;
5643   integer c__21 = 21;
5644   /* System generated locals */
5645     integer tcbold_dim1, tcbold_dim2, tcbold_offset, tcbnew_dim1, tcbnew_dim2,
5646              tcbnew_offset, i__1, i__2, i__3, i__4, i__5;
5647
5648
5649     /* Local variables */
5650     logical ldbg;
5651     integer ndeg;
5652     doublereal taux1[21];
5653     integer d__, e, i__, k;
5654     doublereal mfact;
5655     integer ncoeff;
5656     doublereal tjacap[21];
5657     integer iordre[2];
5658     doublereal hermit[36]/* was [6][3][2] */, ctenor, bornes[2];
5659     integer ier;
5660     integer aux1, aux2;
5661
5662 /* ***********************************************************************
5663  */
5664
5665 /*     FUNCTION : */
5666 /*     ---------- */
5667 /*       CONVERSION OF TABLE TCBOLD OF POLYNOMIAL CURVE COEFFICIENTS */
5668 /*       EXPRESSED IN HERMIT JACOBI BASE, INTO A */
5669 /*       TABLE OF COEFFICIENTS TCBNEW OF COURVES EXPRESSED IN THE CANONIC BASE */
5670
5671 /*     KEYWORDS : */
5672 /*     ----------- */
5673 /*      CANNONIC, HERMIT, JACCOBI */
5674
5675 /*     INPUT ARGUMENTS : */
5676 /*     -------------------- */
5677 /*       ORDHER : ORDER OF HERMIT POLYNOMS OR ORDER OF CONTINUITY */
5678 /*       NCOEFS : NUMBER OF COEFFICIENTS OF A POLYNOMIAL CURVE */
5679 /*                FOR ONE OF ITS NDIM COMPONENTS;(DEGREE+1 OF THE CURVE)
5680 */
5681 /*       NDIM   : DIMENSION OF THE CURVE */
5682 /*       CBHEJA : TABLE OF COEFFICIENTS OF THE CURVE IN THE BASE */
5683 /*                HERMIT JACOBI */
5684 /*                (H(0,-1),..,H(ORDHER,-1),H(0,1),..,H(ORDHER,1), */
5685 /*                 JA(ORDHER+1,2*ORDHER+2),....,JA(ORDHER+1,NCOEFS-1) */
5686
5687 /*     OUTPUT ARGUMENTS  : */
5688 /*     --------------------- */
5689 /*       CBRCAN : TABLE OF COEFFICIENTS OF THE CURVE IN THE CANONIC BASE */
5690 /*                (1, t, ...) */
5691
5692 /*     COMMONS USED : */
5693 /*     ------------------ */
5694
5695
5696 /*     REFERENCES CALLED : */
5697 /*     --------------------- */
5698
5699
5700 /* ***********************************************************************
5701  */
5702
5703
5704 /* ***********************************************************************
5705  */
5706
5707 /*     FUNCTION : */
5708 /*     ---------- */
5709 /*        Providesinteger constants from 0 to 1000 */
5710
5711 /*     KEYWORDS : */
5712 /*     ----------- */
5713 /*        ALL, INTEGER */
5714
5715 /*     DEMSCRIPTION/NOTES/LIMITATIONS : */
5716 /*     ----------------------------------- */
5717 /* > */
5718 /* ***********************************************************************
5719  */
5720
5721
5722 /* ***********************************************************************
5723  */
5724
5725
5726
5727
5728 /* ***********************************************************************
5729  */
5730 /*                      INITIALIZATION */
5731 /* ***********************************************************************
5732  */
5733
5734     /* Parameter adjustments */
5735     --ncftab;
5736     tcbnew_dim1 = *ndimen;
5737     tcbnew_dim2 = *ncflim;
5738     tcbnew_offset = tcbnew_dim1 * (tcbnew_dim2 + 1) + 1;
5739     tcbnew -= tcbnew_offset;
5740     tcbold_dim1 = *ndimen;
5741     tcbold_dim2 = *ncflim;
5742     tcbold_offset = tcbold_dim1 * (tcbold_dim2 + 1) + 1;
5743     tcbold -= tcbold_offset;
5744
5745     /* Function Body */
5746     ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 2;
5747     if (ldbg) {
5748         AdvApp2Var_SysBase::mgenmsg_("MMHJCAN", 7L);
5749     }
5750     *iercod = 0;
5751
5752     bornes[0] = -1.;
5753     bornes[1] = 1.;
5754
5755 /* ***********************************************************************
5756  */
5757 /*                     PROCESSING */
5758 /* ***********************************************************************
5759  */
5760
5761     if (*orcont > 2) {
5762         goto L9101;
5763     }
5764     if (*ncflim > 21) {
5765         goto L9101;
5766     }
5767
5768 /*     CALCULATION OF HERMIT POLYNOMS IN THE CANONIC BASE ON (-1,1) */
5769
5770
5771     iordre[0] = *orcont;
5772     iordre[1] = *orcont;
5773     mmherm1_(bornes, &c__2, iordre, hermit, &ier);
5774     if (ier > 0) {
5775         goto L9102;
5776     }
5777
5778
5779     aux1 = *orcont + 1;
5780     aux2 = aux1 << 1;
5781
5782     i__1 = *ncourb;
5783     for (e = 1; e <= i__1; ++e) {
5784
5785         ctenor = (tdecop[e] - tdecop[e - 1]) / 2;
5786         ncoeff = ncftab[e];
5787         ndeg = ncoeff - 1;
5788         if (ncoeff > 21) {
5789             goto L9101;
5790         }
5791
5792         i__2 = *ndimen;
5793         for (d__ = 1; d__ <= i__2; ++d__) {
5794
5795 /*     CONVERSION OF THE COEFFICIENTS OF THE PART OF THE CURVE EXPRESSED */
5796 /*     IN HERMIT BASE, INTO THE CANONIC BASE */
5797
5798             AdvApp2Var_SysBase::mvriraz_(&ncoeff, taux1);
5799
5800             i__3 = aux2;
5801             for (k = 1; k <= i__3; ++k) {
5802                 i__4 = aux1;
5803                 for (i__ = 1; i__ <= i__4; ++i__) {
5804                     i__5 = i__ - 1;
5805                     mfact = AdvApp2Var_MathBase::pow__di(&ctenor, &i__5);
5806                     taux1[k - 1] += (tcbold[d__ + (i__ + e * tcbold_dim2) *
5807                             tcbold_dim1] * hermit[k + (i__ + 2) * 6 - 19] +
5808                             tcbold[d__ + (i__ + aux1 + e * tcbold_dim2) *
5809                             tcbold_dim1] * hermit[k + (i__ + 5) * 6 - 19]) *
5810                             mfact;
5811                 }
5812             }
5813
5814
5815             i__3 = ncoeff;
5816             for (i__ = aux2 + 1; i__ <= i__3; ++i__) {
5817                 taux1[i__ - 1] = tcbold[d__ + (i__ + e * tcbold_dim2) *
5818                         tcbold_dim1];
5819             }
5820
5821 /*     CONVERSION OF THE COEFFICIENTS OF THE PART OF THE CURVE EXPRESSED */
5822 /*     IN CANONIC-JACOBI BASE, INTO THE CANONIC BASE */
5823
5824
5825
5826             AdvApp2Var_MathBase::mmapcmp_(&minombr_.nbr[1], &c__21, &ncoeff, taux1, tjacap);
5827             AdvApp2Var_MathBase::mmjacan_(orcont, &ndeg, tjacap, taux1);
5828
5829 /*        RECOPY THE COEFS RESULTING FROM THE CONVERSION IN THE TABLE */
5830 /*        OF RESULTS */
5831
5832             i__3 = ncoeff;
5833             for (i__ = 1; i__ <= i__3; ++i__) {
5834                 tcbnew[d__ + (i__ + e * tcbnew_dim2) * tcbnew_dim1] = taux1[
5835                         i__ - 1];
5836             }
5837
5838         }
5839     }
5840
5841     goto L9999;
5842
5843 /* ***********************************************************************
5844  */
5845 /*                   PROCESSING OF ERRORS */
5846 /* ***********************************************************************
5847  */
5848
5849 L9101:
5850     *iercod = 1;
5851     goto L9999;
5852 L9102:
5853     *iercod = 2;
5854     goto L9999;
5855
5856 /* ***********************************************************************
5857  */
5858 /*                   RETURN CALLING PROGRAM */
5859 /* ***********************************************************************
5860  */
5861
5862 L9999:
5863
5864     AdvApp2Var_SysBase::maermsg_("MMHJCAN", iercod, 7L);
5865     if (ldbg) {
5866         AdvApp2Var_SysBase::mgsomsg_("MMHJCAN", 7L);
5867     }
5868  return 0 ;
5869 } /* mmhjcan_ */
5870
5871 //=======================================================================
5872 //function : AdvApp2Var_MathBase::mminltt_
5873 //purpose  :
5874 //=======================================================================
5875  int AdvApp2Var_MathBase::mminltt_(integer *ncolmx,
5876                             integer *nlgnmx,
5877                             doublereal *tabtri,
5878                             integer *nbrcol,
5879                             integer *nbrlgn,
5880                             doublereal *ajoute,
5881                             doublereal *,//epseg,
5882                             integer *iercod)
5883 {
5884   /* System generated locals */
5885   integer tabtri_dim1, tabtri_offset, i__1, i__2;
5886
5887   /* Local variables */
5888   logical idbg;
5889   integer icol, ilgn, nlgn, noct, inser;
5890   doublereal epsega = 0.;
5891   integer ibb;
5892
5893 /* ***********************************************************************
5894  */
5895
5896 /*     FUNCTION : */
5897 /*     ---------- */
5898 /*        . Insert a line in a table parsed without redundance */
5899
5900 /*     KEYWORDS : */
5901 /*     ----------- */
5902 /*      TOUS,MATH_ACCES :: TABLEAU&,INSERTION,&TABLEAU */
5903
5904 /*     INPUT ARGUMENTS : */
5905 /*     -------------------- */
5906 /*        . NCOLMX : Number of columns in the table */
5907 /*        . NLGNMX : Number of lines in the table */
5908 /*        . TABTRI : Table parsed by lines without redundances */
5909 /*        . NBRCOL : Number of columns used */
5910 /*        . NBRLGN : Number of lines used */
5911 /*        . AJOUTE : Line to be added */
5912 /*        . EPSEGA : Epsilon to test the redundance */
5913
5914 /*     OUTPUT ARGUMENTS : */
5915 /*     --------------------- */
5916 /*        . TABTRI : Table parsed by lines without redundances */
5917 /*        . NBRLGN : Number of lines used */
5918 /*        . IERCOD : 0 -> No problem */
5919 /*                   1 -> The table is full */
5920
5921 /*     COMMONS USED : */
5922 /*     ------------------ */
5923
5924 /*     REFERENCES CALLED : */
5925 /*     --------------------- */
5926
5927 /*     DESCRIPTION/NOTES/LIMITATIONS : */
5928 /*     ----------------------------------- */
5929 /*        . The line is inserted only if there is no line with all
5930 */
5931 /*     elements equl to those which are planned to be insered, to epsilon. */
5932
5933 /*        . Level of de debug = 3 */
5934
5935
5936 /**/
5937 /*     DECLARATIONS , CONTROL OF INPUT ARGUMENTS , INITIALIZATION */
5938 /* ***********************************************************************
5939  */
5940
5941 /* --- Parameters */
5942
5943
5944 /* --- Functions */
5945
5946
5947 /* --- Local variables */
5948
5949
5950 /* --- Messages */
5951
5952     /* Parameter adjustments */
5953     tabtri_dim1 = *ncolmx;
5954     tabtri_offset = tabtri_dim1 + 1;
5955     tabtri -= tabtri_offset;
5956     --ajoute;
5957
5958     /* Function Body */
5959     ibb = AdvApp2Var_SysBase::mnfndeb_();
5960     idbg = ibb >= 3;
5961     if (idbg) {
5962         AdvApp2Var_SysBase::mgenmsg_("MMINLTT", 7L);
5963     }
5964
5965 /* --- Control arguments */
5966
5967     if (*nbrlgn >= *nlgnmx) {
5968         goto L9001;
5969     }
5970
5971 /* -------------------- */
5972 /* *** INITIALIZATION */
5973 /* -------------------- */
5974
5975     *iercod = 0;
5976
5977 /* ---------------------------- */
5978 /* *** SEARCH OF REDUNDANCE */
5979 /* ---------------------------- */
5980
5981     i__1 = *nbrlgn;
5982     for (ilgn = 1; ilgn <= i__1; ++ilgn) {
5983         if (tabtri[ilgn * tabtri_dim1 + 1] >= ajoute[1] - epsega) {
5984             if (tabtri[ilgn * tabtri_dim1 + 1] <= ajoute[1] + epsega) {
5985                 i__2 = *nbrcol;
5986                 for (icol = 1; icol <= i__2; ++icol) {
5987                     if (tabtri[icol + ilgn * tabtri_dim1] < ajoute[icol] -
5988                             epsega || tabtri[icol + ilgn * tabtri_dim1] >
5989                             ajoute[icol] + epsega) {
5990                         goto L20;
5991                     }
5992 /* L10: */
5993                 }
5994                 goto L9999;
5995             } else {
5996                 goto L30;
5997             }
5998         }
5999 L20:
6000         ;
6001     }
6002
6003 /* ----------------------------------- */
6004 /* *** SEARCH OF THE INSERTION POINT */
6005 /* ----------------------------------- */
6006
6007 L30:
6008
6009     i__1 = *nbrlgn;
6010     for (ilgn = 1; ilgn <= i__1; ++ilgn) {
6011         i__2 = *nbrcol;
6012         for (icol = 1; icol <= i__2; ++icol) {
6013             if (tabtri[icol + ilgn * tabtri_dim1] < ajoute[icol]) {
6014                 goto L50;
6015             }
6016             if (tabtri[icol + ilgn * tabtri_dim1] > ajoute[icol]) {
6017                 goto L70;
6018             }
6019 /* L60: */
6020         }
6021 L50:
6022         ;
6023     }
6024
6025     ilgn = *nbrlgn + 1;
6026
6027 /* -------------- */
6028 /* *** INSERTION */
6029 /* -------------- */
6030
6031 L70:
6032
6033     inser = ilgn;
6034     ++(*nbrlgn);
6035
6036 /* --- Shift lower */
6037
6038     nlgn = *nbrlgn - inser;
6039     if (nlgn > 0) {
6040         noct = (*ncolmx << 3) * nlgn;
6041         AdvApp2Var_SysBase::mcrfill_(&noct,
6042                  &tabtri[inser * tabtri_dim1 + 1],
6043                  &tabtri[(inser + 1)* tabtri_dim1 + 1]);
6044     }
6045
6046 /* --- Copy line */
6047
6048     noct = *nbrcol << 3;
6049     AdvApp2Var_SysBase::mcrfill_(&noct,
6050              &ajoute[1],
6051              &tabtri[inser * tabtri_dim1 + 1]);
6052
6053     goto L9999;
6054
6055 /* ******************************************************************** */
6056 /*       OUTPUT ERROR , RETURN CALLING PROGRAM , MESSAGES */
6057 /* ******************************************************************** */
6058
6059 /* --- The table is already full */
6060
6061 L9001:
6062     *iercod = 1;
6063
6064 /* --- End */
6065
6066 L9999:
6067     if (*iercod != 0) {
6068         AdvApp2Var_SysBase::maermsg_("MMINLTT", iercod, 7L);
6069     }
6070     if (idbg) {
6071         AdvApp2Var_SysBase::mgsomsg_("MMINLTT", 7L);
6072     }
6073  return 0 ;
6074 } /* mminltt_ */
6075
6076 //=======================================================================
6077 //function : AdvApp2Var_MathBase::mmjacan_
6078 //purpose  :
6079 //=======================================================================
6080  int AdvApp2Var_MathBase::mmjacan_(const integer *ideriv,
6081                             integer *ndeg,
6082                             doublereal *poljac,
6083                             doublereal *polcan)
6084 {
6085     /* System generated locals */
6086   integer poljac_dim1, i__1, i__2;
6087
6088   /* Local variables */
6089   integer iptt, i__, j, ibb;
6090   doublereal bid;
6091
6092 /* ***********************************************************************
6093  */
6094
6095 /*     FUNCTION : */
6096 /*     ---------- */
6097 /*     Routine of transfer of Jacobi normalized to canonic [-1,1], */
6098 /*     the tables are ranked by even, then by uneven degree. */
6099
6100 /*     KEYWORDS : */
6101 /*     ----------- */
6102 /*        LEGENDRE,JACOBI,PASSAGE. */
6103
6104 /*     INPUT ARGUMENTS  : */
6105 /*     ------------------ */
6106 /*        IDERIV : Order of Jacobi between -1 and 2. */
6107 /*        NDEG :   The true degree of the polynom. */
6108 /*        POLJAC : The polynom in the Jacobi base. */
6109
6110 /*     OUTPUT ARGUMENTS : */
6111 /*     ------------------- */
6112 /*        POLCAN : The curve expressed in the canonic base [-1,1]. */
6113
6114 /*     COMMONS USED   : */
6115 /*     ---------------- */
6116
6117 /*     REFERENCES CALLED   : */
6118 /*     ----------------------- */
6119
6120 /*     DESCRIPTION/NOTES/LIMITATIONS : */
6121 /*     ----------------------------------- */
6122
6123 /* > */
6124 /* ***********************************************************************
6125  */
6126
6127 /*   Name of the routine */
6128
6129 /*   Matrices of conversion */
6130
6131
6132 /* ***********************************************************************
6133  */
6134
6135 /*     FUNCTION : */
6136 /*     ---------- */
6137 /*        MATRIX OF TRANSFORMATION OF LEGENDRE BASE */
6138
6139 /*     KEYWORDS : */
6140 /*     ----------- */
6141 /*        MATH */
6142
6143 /*     DEMSCRIPTION/NOTES/LIMITATIONS : */
6144 /*     ----------------------------------- */
6145
6146 /* > */
6147 /* ***********************************************************************
6148  */
6149
6150
6151
6152 /*  Legendre common / Restricted Casteljau. */
6153
6154 /*   0:1      0 Concerns the even terms, 1 the uneven terms. */
6155 /*   CANPLG : Matrix of passage to canonic from Jacobi with calculated parities */
6156 /*   PLGCAN : Matrix of passage from Jacobi to canonic with calculated parities */
6157
6158
6159 /* ***********************************************************************
6160  */
6161
6162     /* Parameter adjustments */
6163     poljac_dim1 = *ndeg / 2 + 1;
6164
6165     /* Function Body */
6166     ibb = AdvApp2Var_SysBase::mnfndeb_();
6167     if (ibb >= 5) {
6168         AdvApp2Var_SysBase::mgenmsg_("MMJACAN", 7L);
6169     }
6170
6171 /* ----------------- Expression of terms of even degree ----------------
6172 */
6173
6174     i__1 = *ndeg / 2;
6175     for (i__ = 0; i__ <= i__1; ++i__) {
6176         bid = 0.;
6177         iptt = i__ * 31 - (i__ + 1) * i__ / 2 + 1;
6178         i__2 = *ndeg / 2;
6179         for (j = i__; j <= i__2; ++j) {
6180             bid += mmjcobi_.plgcan[iptt + j + *ideriv * 992 + 991] * poljac[
6181                     j];
6182 /* L310: */
6183         }
6184         polcan[i__ * 2] = bid;
6185 /* L300: */
6186     }
6187
6188 /* --------------- Expression of terms of uneven degree ----------------
6189 */
6190
6191     if (*ndeg == 0) {
6192         goto L9999;
6193     }
6194
6195     i__1 = (*ndeg - 1) / 2;
6196     for (i__ = 0; i__ <= i__1; ++i__) {
6197         bid = 0.;
6198         iptt = i__ * 31 - (i__ + 1) * i__ / 2 + 1;
6199         i__2 = (*ndeg - 1) / 2;
6200         for (j = i__; j <= i__2; ++j) {
6201             bid += mmjcobi_.plgcan[iptt + j + ((*ideriv << 1) + 1) * 496 +
6202                     991] * poljac[j + poljac_dim1];
6203 /* L410: */
6204         }
6205         polcan[(i__ << 1) + 1] = bid;
6206 /* L400: */
6207     }
6208
6209 /* -------------------------------- The end -----------------------------
6210 */
6211
6212 L9999:
6213     if (ibb >= 5) {
6214         AdvApp2Var_SysBase::mgsomsg_("MMJACAN", 7L);
6215     }
6216     return 0;
6217 } /* mmjacan_ */
6218
6219 //=======================================================================
6220 //function : AdvApp2Var_MathBase::mmjaccv_
6221 //purpose  :
6222 //=======================================================================
6223  int AdvApp2Var_MathBase::mmjaccv_(const integer *ncoef,
6224                             const integer *ndim,
6225                             const integer *ider,
6226                             const doublereal *crvlgd,
6227                             doublereal *polaux,
6228                             doublereal *crvcan)
6229
6230 {
6231   /* Initialized data */
6232
6233   static char nomprg[8+1] = "MMJACCV ";
6234
6235   /* System generated locals */
6236   integer crvlgd_dim1, crvlgd_offset, crvcan_dim1, crvcan_offset,
6237   polaux_dim1, i__1, i__2;
6238
6239   /* Local variables */
6240   integer ndeg, i__, nd, ii, ibb;
6241
6242 /* ***********************************************************************
6243  */
6244
6245 /*     FUNCTION : */
6246 /*     ---------- */
6247 /*        Passage from the normalized Jacobi base to the canonic base. */
6248
6249 /*     KEYWORDS : */
6250 /*     ----------- */
6251 /*        SMOOTHING, BASE, LEGENDRE */
6252
6253
6254 /*     INPUT ARGUMENTS : */
6255 /*     ------------------ */
6256 /*        NDIM: Space Dimension. */
6257 /*        NCOEF: Degree +1 of the polynom. */
6258 /*        IDER: Order of Jacobi polynoms. */
6259 /*        CRVLGD : Curve in the base of Jacobi. */
6260
6261 /*     OUTPUT ARGUMENTS : */
6262 /*     ------------------- */
6263 /*        POLAUX : Auxilliary space. */
6264 /*        CRVCAN : The curve in the canonic base [-1,1] */
6265
6266 /*     COMMONS USED   : */
6267 /*     ---------------- */
6268
6269 /*     REFERENCES CALLED   : */
6270 /*     ----------------------- */
6271
6272 /*     DESCRIPTION/NOTES/LIMITATIONS : */
6273 /*     ----------------------------------- */
6274
6275 /* > */
6276 /* *********************************************************************
6277 */
6278
6279 /*   Name of the routine */
6280     /* Parameter adjustments */
6281     polaux_dim1 = (*ncoef - 1) / 2 + 1;
6282     crvcan_dim1 = *ncoef - 1 + 1;
6283     crvcan_offset = crvcan_dim1;
6284     crvcan -= crvcan_offset;
6285     crvlgd_dim1 = *ncoef - 1 + 1;
6286     crvlgd_offset = crvlgd_dim1;
6287     crvlgd -= crvlgd_offset;
6288
6289     /* Function Body */
6290
6291     ibb = AdvApp2Var_SysBase::mnfndeb_();
6292     if (ibb >= 3) {
6293         AdvApp2Var_SysBase::mgenmsg_(nomprg, 6L);
6294     }
6295
6296     ndeg = *ncoef - 1;
6297
6298     i__1 = *ndim;
6299     for (nd = 1; nd <= i__1; ++nd) {
6300 /*  Loading of the auxilliary table. */
6301         ii = 0;
6302         i__2 = ndeg / 2;
6303         for (i__ = 0; i__ <= i__2; ++i__) {
6304             polaux[i__] = crvlgd[ii + nd * crvlgd_dim1];
6305             ii += 2;
6306 /* L310: */
6307         }
6308
6309         ii = 1;
6310         if (ndeg >= 1) {
6311             i__2 = (ndeg - 1) / 2;
6312             for (i__ = 0; i__ <= i__2; ++i__) {
6313                 polaux[i__ + polaux_dim1] = crvlgd[ii + nd * crvlgd_dim1];
6314                 ii += 2;
6315 /* L320: */
6316             }
6317         }
6318 /*   Call the routine of base change. */
6319         AdvApp2Var_MathBase::mmjacan_(ider, &ndeg, polaux, &crvcan[nd * crvcan_dim1]);
6320 /* L300: */
6321     }
6322
6323
6324 /* L9999: */
6325     return 0;
6326 } /* mmjaccv_ */
6327
6328 //=======================================================================
6329 //function : mmloncv_
6330 //purpose  :
6331 //=======================================================================
6332 int mmloncv_(integer *ndimax,
6333              integer *ndimen,
6334              integer *ncoeff,
6335              doublereal *courbe,
6336              doublereal *tdebut,
6337              doublereal *tfinal,
6338              doublereal *xlongc,
6339              integer *iercod)
6340
6341 {
6342   /* Initialized data */
6343
6344   integer kgar = 0;
6345
6346   /* System generated locals */
6347   integer courbe_dim1, courbe_offset, i__1, i__2;
6348
6349   /* Local variables */
6350   doublereal tran;
6351   integer ngaus = 0;
6352   doublereal c1, c2, d1, d2,
6353     wgaus[20] = {0.}, uroot[20] = {0.}, x1, x2, dd;
6354   integer ii, jj, kk;
6355   doublereal som;
6356   doublereal der1, der2;
6357
6358
6359
6360
6361 /* **********************************************************************
6362 */
6363
6364 /*     FUNCTION : Length of an arc of curve on a given interval */
6365 /*     ---------- for a function the mathematic representation  */
6366 /*                which of is a multidimensional polynom. */
6367 /*      The polynom is a set of polynoms the coefficients which of are ranked */
6368 /*  in a table with 2 indices, each line relative to 1 polynom. */
6369 /*      The polynom is defined by its coefficients ordered by increasing
6370 *       power of the variable. */
6371 /*      All polynoms have the same number of coefficients (and the same degree). */
6372
6373 /*     KEYWORDS : LENGTH, CURVE */
6374 /*     ----------- */
6375
6376 /*     INPUT ARGUMENTS : */
6377 /*     -------------------- */
6378
6379 /*      NDIMAX : Max number of lines of tables (max number of polynoms). */
6380 /*      NDIMEN : Dimension of the polynom (Nomber of polynoms). */
6381 /*      NCOEFF : Number of coefficients of the polynom (no limitation) */
6382 /*               This is degree + 1 */
6383 /*      COURBE : Coefficients of the polynom ordered by increasing power */
6384 /*               Dimension to (NDIMAX,NCOEFF). */
6385 /*      TDEBUT : Lower limit of integration for length calculation. */
6386 /*      TFINAL : Upper limit of integration for length calculation.  */
6387
6388 /*     OUTPUT ARGUMENTS : */
6389 /*     --------------------- */
6390 /*      XLONGC : Length of arc of curve */
6391
6392 /*      IERCOD : Error code : */
6393 /*             = 0 ==> All is OK */
6394 /*             = 1 ==> NDIMEN or NCOEFF negative or null */
6395 /*             = 2 ==> Pb loading Legendre roots and Gauss weight */
6396 /*                     by MVGAUS0. */
6397
6398 /*     If error => XLONGC = 0 */
6399
6400 /*     COMMONS USED : */
6401 /*     ------------------ */
6402
6403 /*      .Neant. */
6404
6405 /*     REFERENCES CALLED   : */
6406 /*     ---------------------- */
6407 /*     Type  Name */
6408 /*           MAERMSG         R*8  DSQRT          I*4  MIN */
6409 /*           MVGAUS0 */
6410
6411 /*     DESCRIPTION/NOTES/LIMITATIONS : */
6412 /*     ----------------------------------- */
6413
6414 /*      See VGAUSS to understand well the technique. */
6415 /*      Actually SQRT (dpi^2) is integrated for i=1,nbdime */
6416 /*      Calculation of the derivative is included in the code to avoid an additional */
6417 /*      call of the routine. */
6418
6419 /*      The integrated function is strictly increasing, it */
6420 /*      is not necessary to use a high degree for the GAUSS method GAUSS. */
6421
6422 /*      The degree of LEGENDRE polynom results from the degree of the */
6423 /*      polynom to be integrated. It can vary from 4 to 40 (with step of 4). */
6424
6425 /*      The precision (relative) of integration is of order 1.D-8. */
6426
6427 /*      ATTENTION : if TDEBUT > TFINAL, the length is NEGATIVE. */
6428
6429 /*      Attention : the precision of the result is not controlled. */
6430 /*      If you wish to control it, use  MMCGLC1, taking into account that  */
6431 /*      the performance (in time) will be worse. */
6432
6433 /* >=====================================================================
6434 */
6435
6436 /*      ATTENTION : SAVE KGAR WGAUS and UROOT EVENTUALLY */
6437 /*     ,IERXV */
6438 /*      INTEGER I1,I20 */
6439 /*      PARAMETER (I1=1,I20=20) */
6440
6441     /* Parameter adjustments */
6442     courbe_dim1 = *ndimax;
6443     courbe_offset = courbe_dim1 + 1;
6444     courbe -= courbe_offset;
6445
6446     /* Function Body */
6447
6448 /* ****** General initialization ** */
6449
6450     *iercod = 999999;
6451     *xlongc = 0.;
6452
6453 /* ****** Initialization of UROOT, WGAUS, NGAUS and KGAR ** */
6454
6455 /*      CALL MXVINIT(IERXV,'INTEGER',I1,KGAR,'INTEGER',I1,NGAUS */
6456 /*     1    ,'DOUBLE PRECISION',I20,UROOT,'DOUBLE PRECISION',I20,WGAUS) */
6457 /*      IF (IERXV.GT.0) KGAR=0 */
6458
6459 /* ****** Test the equity of limits ** */
6460
6461     if (*tdebut == *tfinal) {
6462         *iercod = 0;
6463         goto L9900;
6464     }
6465
6466 /* ****** Test the dimension and the number of coefficients ** */
6467
6468     if (*ndimen <= 0 || *ncoeff <= 0) {
6469         *iercod = 1;
6470         goto L9900;
6471     }
6472
6473 /* ****** Calculate the optimal degree ** */
6474
6475     kk = *ncoeff / 4 + 1;
6476     kk = advapp_min(kk,10);
6477
6478 /* ****** Return the coefficients for the integral (DEGRE=4*KK) */
6479 /*       if KK <> KGAR. */
6480
6481     if (kk != kgar) {
6482         mvgaus0_(&kk, uroot, wgaus, &ngaus, iercod);
6483         if (*iercod > 0) {
6484             kgar = 0;
6485             *iercod = 2;
6486             goto L9900;
6487         }
6488         kgar = kk;
6489     }
6490
6491 /*      C1 => Point medium interval */
6492 /*      C2 => 1/2 amplitude interval */
6493
6494     c1 = (*tfinal + *tdebut) * .5;
6495     c2 = (*tfinal - *tdebut) * .5;
6496
6497 /* ----------------------------------------------------------- */
6498 /* ****** Integration - Loop on GAUSS intervals ** */
6499 /* ----------------------------------------------------------- */
6500
6501     som = 0.;
6502
6503     i__1 = ngaus;
6504     for (jj = 1; jj <= i__1; ++jj) {
6505
6506 /* ****** Integration taking the symmetry into account ** */
6507
6508         tran = c2 * uroot[jj - 1];
6509         x1 = c1 + tran;
6510         x2 = c1 - tran;
6511
6512 /* ****** Derivation on the dimension of the space ** */
6513
6514         der1 = 0.;
6515         der2 = 0.;
6516         i__2 = *ndimen;
6517         for (kk = 1; kk <= i__2; ++kk) {
6518             d1 = (*ncoeff - 1) * courbe[kk + *ncoeff * courbe_dim1];
6519             d2 = d1;
6520             for (ii = *ncoeff - 1; ii >= 2; --ii) {
6521                 dd = (ii - 1) * courbe[kk + ii * courbe_dim1];
6522                 d1 = d1 * x1 + dd;
6523                 d2 = d2 * x2 + dd;
6524 /* L100: */
6525             }
6526             der1 += d1 * d1;
6527             der2 += d2 * d2;
6528 /* L200: */
6529         }
6530
6531 /* ****** Integration ** */
6532
6533         som += wgaus[jj - 1] * c2 * (sqrt(der1) + sqrt(der2));
6534
6535 /* ****** End of loop on GAUSS intervals ** */
6536
6537 /* L300: */
6538     }
6539
6540 /* ****** Work ended ** */
6541
6542     *xlongc = som;
6543
6544 /* ****** It is forced IERCOD  =  0 ** */
6545
6546     *iercod = 0;
6547
6548 /* ****** Final processing ** */
6549
6550 L9900:
6551
6552 /* ****** Save UROOT, WGAUS, NGAUS and KGAR ** */
6553
6554 /*      CALL MXVSAVE(IERXV,'INTEGER',I1,KGAR,'INTEGER',I1,NGAUS */
6555 /*     1    ,'DOUBLE PRECISION',I20,UROOT,'DOUBLE PRECISION',I20,WGAUS) */
6556 /*      IF (IERXV.GT.0) KGAR=0 */
6557
6558 /* ****** End of sub-program ** */
6559
6560     if (*iercod != 0) {
6561         AdvApp2Var_SysBase::maermsg_("MMLONCV", iercod, 7L);
6562     }
6563  return 0 ;
6564 } /* mmloncv_ */
6565
6566 //=======================================================================
6567 //function : AdvApp2Var_MathBase::mmpobas_
6568 //purpose  :
6569 //=======================================================================
6570  int AdvApp2Var_MathBase::mmpobas_(doublereal *tparam,
6571                             integer *iordre,
6572                             integer *ncoeff,
6573                             integer *nderiv,
6574                             doublereal *valbas,
6575                             integer *iercod)
6576
6577 {
6578   integer c__2 = 2;
6579   integer c__1 = 1;
6580
6581
6582    /* Initialized data */
6583
6584     doublereal moin11[2] = { -1.,1. };
6585
6586     /* System generated locals */
6587     integer valbas_dim1, i__1;
6588
6589     /* Local variables */
6590     doublereal vjacc[80], herm[24];
6591     NCollection_Array1<doublereal> vjac (vjacc[0], 1, 80);
6592     integer iord[2];
6593     doublereal wval[4];
6594     integer nwcof, iunit;
6595     doublereal wpoly[7];
6596     integer ii, jj, iorjac;
6597     doublereal hermit[36]       /* was [6][3][2] */;
6598     integer kk1, kk2, kk3;
6599     integer khe, ier;
6600
6601
6602 /* ***********************************************************************
6603  */
6604
6605 /*     FUNCTION : */
6606 /*     ---------- */
6607 /*       Position on the polynoms of base hermit-Jacobi */
6608 /*       and their succesive derivatives */
6609
6610 /*     KEYWORDS : */
6611 /*     ----------- */
6612 /*      PUBLIC, POSITION, HERMIT, JACOBI */
6613
6614 /*     INPUT ARGUMENTS : */
6615 /*     -------------------- */
6616 /*       TPARAM : Parameter for which the position is found. */
6617 /*       IORDRE : Orderof hermit-Jacobi (-1,0,1, ou 2) */
6618 /*       NCOEFF : Number of coefficients of polynoms (Nb of value to calculate) */
6619 /*       NDERIV : Number of derivative to calculate (0<= N <=3) */
6620 /*              0 -> Position simple on base functions */
6621 /*              N -> Position on base functions and derivative */
6622 /*              of order 1 to N */
6623
6624 /*     OUTPUT ARGUMENTS : */
6625 /*     --------------------- */
6626 /*     VALBAS (NCOEFF, 0:NDERIV) : calculated value */
6627 /*           i */
6628 /*          d    vj(t)  = VALBAS(J, I) */
6629 /*          -- i */
6630 /*          dt */
6631
6632 /*    IERCOD : Error code */
6633 /*      0 : Ok */
6634 /*      1 : Incoherence of input arguments */
6635
6636 /*     COMMONS USED : */
6637 /*     -------------- */
6638
6639
6640 /*     REFERENCES CALLED : */
6641 /*     ------------------- */
6642
6643
6644 /*     DESCRIPTION/NOTES/LIMITATIONS : */
6645 /*     ----------------------------------- */
6646
6647 /* > */
6648 /* ***********************************************************************
6649  */
6650 /*                            DECLARATIONS */
6651 /* ***********************************************************************
6652  */
6653
6654
6655
6656     /* Parameter adjustments */
6657     valbas_dim1 = *ncoeff;
6658     --valbas;
6659
6660     /* Function Body */
6661
6662 /* ***********************************************************************
6663  */
6664 /*                      INITIALIZATIONS */
6665 /* ***********************************************************************
6666  */
6667
6668     *iercod = 0;
6669
6670 /* ***********************************************************************
6671  */
6672 /*                     PROCESSING */
6673 /* ***********************************************************************
6674  */
6675
6676     if (*nderiv > 3) {
6677         goto L9101;
6678     }
6679     if (*ncoeff > 20) {
6680         goto L9101;
6681     }
6682     if (*iordre > 2) {
6683         goto L9101;
6684     }
6685
6686     iord[0] = *iordre;
6687     iord[1] = *iordre;
6688     iorjac = (*iordre + 1) << 1;
6689
6690 /*  (1) Generic Calculations .... */
6691
6692 /*  (1.a) Calculation of hermit polynoms */
6693
6694     if (*iordre >= 0) {
6695         mmherm1_(moin11, &c__2, iord, hermit, &ier);
6696         if (ier > 0) {
6697             goto L9102;
6698         }
6699     }
6700
6701 /*  (1.b) Evaluation of hermit polynoms */
6702
6703     jj = 1;
6704     iunit = *nderiv + 1;
6705     khe = (*iordre + 1) * iunit;
6706
6707     if (*nderiv > 0) {
6708
6709         i__1 = *iordre;
6710         for (ii = 0; ii <= i__1; ++ii) {
6711             mmdrvcb_(nderiv, &c__1, &iorjac, &hermit[(ii + 3) * 6 - 18],
6712                     tparam, &herm[jj - 1], &ier);
6713             if (ier > 0) {
6714                 goto L9102;
6715             }
6716
6717             mmdrvcb_(nderiv, &c__1, &iorjac, &hermit[(ii + 6) * 6 - 18],
6718                     tparam, &herm[jj + khe - 1], &ier);
6719             if (ier > 0) {
6720                 goto L9102;
6721             }
6722             jj += iunit;
6723         }
6724
6725     } else {
6726
6727         i__1 = *iordre;
6728         for (ii = 0; ii <= i__1; ++ii) {
6729             AdvApp2Var_MathBase::mmpocrb_(&c__1, &iorjac, &hermit[(ii + 3) * 6 - 18], &c__1,
6730                     tparam, &herm[jj - 1]);
6731
6732             AdvApp2Var_MathBase::mmpocrb_(&c__1, &iorjac, &hermit[(ii + 6) * 6 - 18], &c__1,
6733                     tparam, &herm[jj + khe - 1]);
6734             jj += iunit;
6735         }
6736     }
6737
6738 /*  (1.c) Evaluation of Jacobi polynoms */
6739
6740     ii = *ncoeff - iorjac;
6741
6742     mmpojac_(tparam, &iorjac, &ii, nderiv, vjac, &ier);
6743     if (ier > 0) {
6744         goto L9102;
6745     }
6746
6747 /*  (1.d) Evaluation of W(t) */
6748
6749 /* Computing MAX */
6750     i__1 = iorjac + 1;
6751     nwcof = advapp_max(i__1,1);
6752     AdvApp2Var_SysBase::mvriraz_(&nwcof,
6753              wpoly);
6754     wpoly[0] = 1.;
6755     if (*iordre == 2) {
6756         wpoly[2] = -3.;
6757         wpoly[4] = 3.;
6758         wpoly[6] = -1.;
6759     } else if (*iordre == 1) {
6760         wpoly[2] = -2.;
6761         wpoly[4] = 1.;
6762     } else if (*iordre == 0) {
6763         wpoly[2] = -1.;
6764     }
6765
6766     mmdrvcb_(nderiv, &c__1, &nwcof, wpoly, tparam, wval, &ier);
6767     if (ier > 0) {
6768         goto L9102;
6769     }
6770
6771     kk1 = *ncoeff - iorjac;
6772     kk2 = kk1 << 1;
6773     kk3 = kk1 * 3;
6774
6775 /*  (2) Evaluation of order 0 */
6776
6777     jj = 1;
6778     i__1 = iorjac;
6779     for (ii = 1; ii <= i__1; ++ii) {
6780         valbas[ii] = herm[jj - 1];
6781         jj += iunit;
6782     }
6783
6784     i__1 = kk1;
6785     for (ii = 1; ii <= i__1; ++ii) {
6786         valbas[ii + iorjac] = wval[0] * vjac(ii);
6787     }
6788
6789 /*  (3) Evaluation of order 1 */
6790
6791     if (*nderiv >= 1) {
6792         jj = 2;
6793         i__1 = iorjac;
6794         for (ii = 1; ii <= i__1; ++ii) {
6795             valbas[ii + valbas_dim1] = herm[jj - 1];
6796             jj += iunit;
6797         }
6798
6799
6800         i__1 = kk1;
6801         for (ii = 1; ii <= i__1; ++ii) {
6802             valbas[ii + iorjac + valbas_dim1] = wval[0] * vjac(ii + kk1)
6803                     + wval[1] * vjac(ii);
6804         }
6805     }
6806
6807 /*  (4)  Evaluation of order 2 */
6808
6809     if (*nderiv >= 2) {
6810         jj = 3;
6811         i__1 = iorjac;
6812         for (ii = 1; ii <= i__1; ++ii) {
6813             valbas[ii + (valbas_dim1 << 1)] = herm[jj - 1];
6814             jj += iunit;
6815         }
6816
6817         i__1 = kk1;
6818         for (ii = 1; ii <= i__1; ++ii) {
6819             valbas[ii + iorjac + (valbas_dim1 << 1)] = wval[0] * vjac(ii +
6820                     kk2) + wval[1] * 2 * vjac(ii + kk1) + wval[2] *
6821                     vjac(ii);
6822         }
6823     }
6824
6825 /*  (5) Evaluation of order 3 */
6826
6827     if (*nderiv >= 3) {
6828         jj = 4;
6829         i__1 = iorjac;
6830         for (ii = 1; ii <= i__1; ++ii) {
6831             valbas[ii + valbas_dim1 * 3] = herm[jj - 1];
6832             jj += iunit;
6833         }
6834
6835         i__1 = kk1;
6836         for (ii = 1; ii <= i__1; ++ii) {
6837             valbas[ii + iorjac + valbas_dim1 * 3] = wval[0] * vjac(ii + kk3)
6838                   + wval[1] * 3 * vjac(ii + kk2) + wval[2] * 3 *
6839                     vjac(ii + kk1) + wval[3] * vjac(ii);
6840         }
6841     }
6842
6843     goto L9999;
6844
6845 /* ***********************************************************************
6846  */
6847 /*                   ERROR PROCESSING */
6848 /* ***********************************************************************
6849  */
6850
6851 L9101:
6852     *iercod = 1;
6853     goto L9999;
6854
6855 L9102:
6856     *iercod = 2;
6857
6858 /* ***********************************************************************
6859  */
6860 /*                   RETURN CALLING PROGRAM */
6861 /* ***********************************************************************
6862  */
6863
6864 L9999:
6865
6866     if (*iercod > 0) {
6867         AdvApp2Var_SysBase::maermsg_("MMPOBAS", iercod, 7L);
6868     }
6869  return 0 ;
6870 } /* mmpobas_ */
6871
6872 //=======================================================================
6873 //function : AdvApp2Var_MathBase::mmpocrb_
6874 //purpose  :
6875 //=======================================================================
6876  int AdvApp2Var_MathBase::mmpocrb_(integer *ndimax,
6877                             integer *ncoeff,
6878                             doublereal *courbe,
6879                             integer *ndim,
6880                             doublereal *tparam,
6881                             doublereal *pntcrb)
6882
6883 {
6884   /* System generated locals */
6885   integer courbe_dim1, courbe_offset, i__1, i__2;
6886
6887   /* Local variables */
6888   integer ncof2;
6889   integer isize, nd, kcf, ncf;
6890
6891
6892 /* ***********************************************************************
6893  */
6894
6895 /*     FUNCTION : */
6896 /*     ---------- */
6897 /*        CALCULATE THE COORDINATES OF A POINT OF A CURVE OF GIVEN PARAMETER */
6898 /*        TPARAM ( IN 2D, 3D OR MORE) */
6899
6900 /*     KEYWORDS : */
6901 /*     ----------- */
6902 /*       TOUS , MATH_ACCES :: COURBE&,PARAMETRE& , POSITIONNEMENT , &POINT
6903  */
6904
6905 /*     INPUT ARGUMENTS  : */
6906 /*     ------------------ */
6907 /*        NDIMAX : format / dimension of the curve */
6908 /*        NCOEFF : Nb of coefficients of the curve */
6909 /*        COURBE : Matrix of coefficients of the curve */
6910 /*        NDIM   : Dimension useful of the workspace  */
6911 /*        TPARAM : Value of the parameter where the point is calculated */
6912
6913 /*     OUTPUT ARGUMENTS : */
6914 /*     ------------------- */
6915 /*        PNTCRB : Coordinates of the calculated point */
6916
6917 /*     COMMONS USED   : */
6918 /*     ---------------- */
6919
6920 /*      .Neant. */
6921
6922 /*     REFERENCES CALLED   : */
6923 /*     ---------------------- */
6924 /*     Type  Name */
6925 /*           MIRAZ                MVPSCR2              MVPSCR3 */
6926
6927 /*     DESCRIPTION/NOTES/LIMITATIONS : */
6928 /*     ----------------------------------- */
6929
6930 /* > */
6931 /* ***********************************************************************
6932  */
6933
6934
6935 /* ***********************************************************************
6936  */
6937
6938     /* Parameter adjustments */
6939     courbe_dim1 = *ndimax;
6940     courbe_offset = courbe_dim1 + 1;
6941     courbe -= courbe_offset;
6942     --pntcrb;
6943
6944     /* Function Body */
6945     isize = *ndim << 3;
6946     AdvApp2Var_SysBase::miraz_(&isize,
6947            &pntcrb[1]);
6948
6949     if (*ncoeff <= 0) {
6950         goto L9999;
6951     }
6952
6953 /*   optimal processing 3d */
6954
6955     if (*ndim == 3 && *ndimax == 3) {
6956         mvpscr3_(ncoeff, &courbe[courbe_offset], tparam, &pntcrb[1]);
6957
6958 /*   optimal processing 2d */
6959
6960     } else if (*ndim == 2 && *ndimax == 2) {
6961         mvpscr2_(ncoeff, &courbe[courbe_offset], tparam, &pntcrb[1]);
6962
6963 /*   Any dimension - scheme of HORNER */
6964
6965     } else if (*tparam == 0.) {
6966         i__1 = *ndim;
6967         for (nd = 1; nd <= i__1; ++nd) {
6968             pntcrb[nd] = courbe[nd + courbe_dim1];
6969 /* L100: */
6970         }
6971     } else if (*tparam == 1.) {
6972         i__1 = *ncoeff;
6973         for (ncf = 1; ncf <= i__1; ++ncf) {
6974             i__2 = *ndim;
6975             for (nd = 1; nd <= i__2; ++nd) {
6976                 pntcrb[nd] += courbe[nd + ncf * courbe_dim1];
6977 /* L300: */
6978             }
6979 /* L200: */
6980         }
6981     } else {
6982         ncof2 = *ncoeff + 2;
6983         i__1 = *ndim;
6984         for (nd = 1; nd <= i__1; ++nd) {
6985             i__2 = *ncoeff;
6986             for (ncf = 2; ncf <= i__2; ++ncf) {
6987                 kcf = ncof2 - ncf;
6988                 pntcrb[nd] = (pntcrb[nd] + courbe[nd + kcf * courbe_dim1]) * *
6989                         tparam;
6990 /* L500: */
6991             }
6992             pntcrb[nd] += courbe[nd + courbe_dim1];
6993 /* L400: */
6994         }
6995     }
6996
6997 L9999:
6998  return 0   ;
6999 } /* mmpocrb_ */
7000
7001 //=======================================================================
7002 //function : AdvApp2Var_MathBase::mmmpocur_
7003 //purpose  :
7004 //=======================================================================
7005  int AdvApp2Var_MathBase::mmmpocur_(integer *ncofmx,
7006                              integer *ndim,
7007                              integer *ndeg,
7008                              doublereal *courbe,
7009                              doublereal *tparam,
7010                              doublereal *tabval)
7011
7012 {
7013   /* System generated locals */
7014   integer courbe_dim1, courbe_offset, i__1;
7015
7016   /* Local variables */
7017   integer i__, nd;
7018   doublereal fu;
7019
7020
7021 /* ***********************************************************************
7022  */
7023
7024 /*     FUNCTION : */
7025 /*     ---------- */
7026 /*        Position of a point on curve (ncofmx,ndim). */
7027
7028 /*     KEYWORDS : */
7029 /*     ----------- */
7030 /*        TOUS , AB_SPECIFI :: COURBE&,POLYNOME&,POSITIONNEMENT,&POINT */
7031
7032 /*     INPUT ARGUMENTS  : */
7033 /*     ------------------ */
7034 /*        NCOFMX: Format / degree of the CURVE. */
7035 /*        NDIM  : Dimension of the space. */
7036 /*        NDEG  : Degree of the polynom. */
7037 /*        COURBE: Coefficients of the curve. */
7038 /*        TPARAM: Parameter on the curve */
7039
7040 /*     OUTPUT ARGUMENTS  : */
7041 /*     ------------------- */
7042 /*        TABVAL(NDIM): The resulting point (or table of values) */
7043
7044 /*     COMMONS USED   : */
7045 /*     ---------------- */
7046
7047 /*     REFERENCES CALLED : */
7048 /*     ----------------------- */
7049
7050 /*     DESCRIPTION/NOTES/LIMITATIONS : */
7051 /*     ----------------------------------- */
7052
7053 /* > */
7054 /* ***********************************************************************
7055  */
7056
7057     /* Parameter adjustments */
7058     --tabval;
7059     courbe_dim1 = *ncofmx;
7060     courbe_offset = courbe_dim1 + 1;
7061     courbe -= courbe_offset;
7062
7063     /* Function Body */
7064     if (*ndeg < 1) {
7065         i__1 = *ndim;
7066         for (nd = 1; nd <= i__1; ++nd) {
7067             tabval[nd] = 0.;
7068 /* L290: */
7069         }
7070     } else {
7071         i__1 = *ndim;
7072         for (nd = 1; nd <= i__1; ++nd) {
7073             fu = courbe[*ndeg + nd * courbe_dim1];
7074             for (i__ = *ndeg - 1; i__ >= 1; --i__) {
7075                 fu = fu * *tparam + courbe[i__ + nd * courbe_dim1];
7076 /* L120: */
7077             }
7078             tabval[nd] = fu;
7079 /* L300: */
7080         }
7081     }
7082  return 0 ;
7083 } /* mmmpocur_ */
7084
7085 //=======================================================================
7086 //function : mmpojac_
7087 //purpose  :
7088 //=======================================================================
7089 int mmpojac_(doublereal *tparam,
7090              integer *iordre,
7091              integer *ncoeff,
7092              integer *nderiv,
7093              NCollection_Array1<doublereal>& valjac,
7094              integer *iercod)
7095
7096 {
7097   integer c__2 = 2;
7098
7099     /* System generated locals */
7100     integer valjac_dim1, i__1, i__2;
7101
7102     /* Local variables */
7103     doublereal cofa, cofb, denom, tnorm[100];
7104     integer ii, jj, kk1, kk2;
7105     doublereal aux1, aux2;
7106
7107
7108 /* ***********************************************************************
7109  */
7110
7111 /*     FUNCTION : */
7112 /*     ---------- */
7113 /*       Positioning on Jacobi polynoms and their derivatives */
7114 /*       successive by a recurrent algorithm */
7115
7116 /*     KEYWORDS : */
7117 /*     ----------- */
7118 /*      RESERVE, POSITIONING, JACOBI */
7119
7120 /*     INPUT ARGUMENTS : */
7121 /*     -------------------- */
7122 /*       TPARAM : Parameter for which positioning is done. */
7123 /*       IORDRE : Order of hermit-?? (-1,0,1, or 2) */
7124 /*       NCOEFF : Number of coeeficients of polynoms (Nb of value to */
7125 /*                calculate) */
7126 /*       NDERIV : Number of derivative to calculate (0<= N <=3) */
7127 /*              0 -> Position simple on jacobi functions */
7128 /*              N -> Position on jacobi functions and their */
7129 /*              derivatives of order 1 to N. */
7130
7131 /*     OUTPUT ARGUMENTS : */
7132 /*     --------------------- */
7133 /*     VALJAC (NCOEFF, 0:NDERIV) : the calculated values */
7134 /*           i */
7135 /*          d    vj(t)  = VALJAC(J, I) */
7136 /*          -- i */
7137 /*          dt */
7138
7139 /*    IERCOD : Error Code */
7140 /*      0 : Ok */
7141 /*      1 : Incoherence of input arguments */
7142
7143 /*     COMMONS USED : */
7144 /*     ------------------ */
7145
7146
7147 /*     REFERENCES CALLED : */
7148 /*     --------------------- */
7149
7150
7151 /*     DESCRIPTION/NOTES/LIMITATIONS : */
7152 /*     ----------------------------------- */
7153
7154 /* > */
7155 /* ***********************************************************************
7156  */
7157 /*                            DECLARATIONS */
7158 /* ***********************************************************************
7159  */
7160
7161
7162 /*     static varaibles */
7163
7164
7165
7166     /* Parameter adjustments */
7167     valjac_dim1 = *ncoeff;
7168
7169     /* Function Body */
7170
7171 /* ***********************************************************************
7172  */
7173 /*                      INITIALISATIONS */
7174 /* ***********************************************************************
7175  */
7176
7177     *iercod = 0;
7178
7179 /* ***********************************************************************
7180  */
7181 /*                     Processing */
7182 /* ***********************************************************************
7183  */
7184
7185     if (*nderiv > 3) {
7186         goto L9101;
7187     }
7188     if (*ncoeff > 100) {
7189         goto L9101;
7190     }
7191
7192 /*  --- Calculation of norms */
7193
7194 /*      IF (NCOEFF.GT.NBCOF) THEN */
7195     i__1 = *ncoeff;
7196     for (ii = 1; ii <= i__1; ++ii) {
7197         kk1 = ii - 1;
7198         aux2 = 1.;
7199         i__2 = *iordre;
7200         for (jj = 1; jj <= i__2; ++jj) {
7201             aux2 = aux2 * (doublereal) (kk1 + *iordre + jj) / (doublereal) (
7202                     kk1 + jj);
7203         }
7204         i__2 = (*iordre << 1) + 1;
7205         tnorm[ii - 1] = sqrt(aux2 * (kk1 * 2. + (*iordre << 1) + 1) / pow__ii(&
7206                 c__2, &i__2));
7207     }
7208
7209 /*      END IF */
7210
7211 /*  --- Trivial Positions ----- */
7212
7213     valjac(1) = 1.;
7214     aux1 = (doublereal) (*iordre + 1);
7215     valjac(2) = aux1 * *tparam;
7216
7217     if (*nderiv >= 1) {
7218         valjac(valjac_dim1 + 1) = 0.;
7219         valjac(valjac_dim1 + 2) = aux1;
7220
7221         if (*nderiv >= 2) {
7222             valjac((valjac_dim1 << 1) + 1) = 0.;
7223             valjac((valjac_dim1 << 1) + 2) = 0.;
7224
7225             if (*nderiv >= 3) {
7226                 valjac(valjac_dim1 * 3 + 1) = 0.;
7227                 valjac(valjac_dim1 * 3 + 2) = 0.;
7228             }
7229         }
7230     }
7231
7232 /*  --- Positioning by recurrence */
7233
7234     i__1 = *ncoeff;
7235     for (ii = 3; ii <= i__1; ++ii) {
7236
7237         kk1 = ii - 1;
7238         kk2 = ii - 2;
7239         aux1 = (doublereal) (*iordre + kk2);
7240         aux2 = aux1 * 2;
7241         cofa = aux2 * (aux2 + 1) * (aux2 + 2);
7242         cofb = (aux2 + 2) * -2. * aux1 * aux1;
7243         denom = kk1 * 2. * (kk2 + (*iordre << 1) + 1) * aux2;
7244         denom = 1. / denom;
7245
7246 /*        --> Pi(t) */
7247         valjac(ii) = (cofa * *tparam * valjac(kk1) + cofb * valjac(kk2)) *
7248                 denom;
7249 /*        --> P'i(t) */
7250         if (*nderiv >= 1) {
7251             valjac(ii + valjac_dim1) = (cofa * *tparam * valjac(kk1 +
7252                     valjac_dim1) + cofa * valjac(kk1) + cofb * valjac(kk2 +
7253                     valjac_dim1)) * denom;
7254 /*        --> P''i(t) */
7255             if (*nderiv >= 2) {
7256                 valjac(ii + (valjac_dim1 << 1)) = (cofa * *tparam * valjac(
7257                         kk1 + (valjac_dim1 << 1)) + cofa * 2 * valjac(kk1 +
7258                         valjac_dim1) + cofb * valjac(kk2 + (valjac_dim1 << 1))
7259                         ) * denom;
7260             }
7261 /*        --> P'i(t) */
7262             if (*nderiv >= 3) {
7263                 valjac(ii + valjac_dim1 * 3) = (cofa * *tparam * valjac(kk1 +
7264                         valjac_dim1 * 3) + cofa * 3 * valjac(kk1 + (
7265                         valjac_dim1 << 1)) + cofb * valjac(kk2 + valjac_dim1 *
7266                          3)) * denom;
7267             }
7268         }
7269     }
7270
7271 /*    ---> Normalization */
7272
7273     i__1 = *ncoeff;
7274     for (ii = 1; ii <= i__1; ++ii) {
7275         i__2 = *nderiv;
7276         for (jj = 0; jj <= i__2; ++jj) {
7277             valjac(ii + jj * valjac_dim1) = tnorm[ii - 1] * valjac(ii + jj *
7278                     valjac_dim1);
7279         }
7280     }
7281
7282     goto L9999;
7283
7284 /* ***********************************************************************
7285  */
7286 /*                   PROCESSING OF ERRORS */
7287 /* ***********************************************************************
7288  */
7289
7290 L9101:
7291     *iercod = 1;
7292     goto L9999;
7293
7294
7295 /* ***********************************************************************
7296  */
7297 /*                   RETURN CALLING PROGRAM */
7298 /* ***********************************************************************
7299  */
7300
7301 L9999:
7302
7303     if (*iercod > 0) {
7304         AdvApp2Var_SysBase::maermsg_("MMPOJAC", iercod, 7L);
7305     }
7306  return 0 ;
7307 } /* mmpojac_ */
7308
7309 //=======================================================================
7310 //function : AdvApp2Var_MathBase::mmposui_
7311 //purpose  :
7312 //=======================================================================
7313  int AdvApp2Var_MathBase::mmposui_(integer *dimmat,
7314                             integer *,//nistoc,
7315                             integer *aposit,
7316                             integer *posuiv,
7317                             integer *iercod)
7318
7319 {
7320   /* System generated locals */
7321   integer i__1, i__2;
7322
7323   /* Local variables */
7324   logical ldbg;
7325   integer imin, jmin, i__, j, k;
7326   logical trouve;
7327
7328 /* ***********************************************************************
7329  */
7330
7331 /*     FUNCTION : */
7332 /*     ---------- */
7333 /*       FILL THE TABLE OF POSITIONING POSUIV WHICH ALLOWS TO */
7334 /*       PARSE BY COLUMN THE INFERIOR TRIANGULAR PART OF THE */
7335 /*       MATRIX  IN FORM OF PROFILE */
7336
7337
7338 /*     KEYWORDS : */
7339 /*     ----------- */
7340 /*      RESERVE, MATRIX, PROFILE */
7341
7342 /*     INPUT ARGUMENTS : */
7343 /*     -------------------- */
7344
7345 /*       NISTOC: NUMBER OF COEFFICIENTS IN THE PROFILE */
7346 /*       DIMMAT: NUMBER OF LINE OF THE SYMMETRIC SQUARE MATRIX */
7347 /*       APOSIT: TABLE OF POSITIONING OF STORAGE TERMS */
7348 /*               APOSIT(1,I) CONTAINS THE NUMBER OF TERMES-1 ON LINE */
7349 /*               I IN THE PROFILE OF THE MATRIX */
7350 /*               APOSIT(2,I) CONTAINS THE INDEX OF STORAGE OF DIAGONAL TERM */
7351 /*               OF LINE I */
7352
7353
7354 /*     OUTPUT ARGUMENTS : */
7355 /*     --------------------- */
7356 /*       POSUIV: POSUIV(K) (WHERE K IS THE INDEX OF STORAGE OF MAT(I,J)) */
7357 /*               CONTAINS THE SMALLEST NUMBER IMIN>I OF THE  LINE THAT */
7358 /*               POSSESSES A TERM MAT(IMIN,J) THAT IS IN THE PROFILE. */
7359 /*               IF THERE IS NO TERM MAT(IMIN,J) IN THE PROFILE THEN POSUIV(K)=-1 */
7360
7361
7362 /*     COMMONS USED : */
7363 /*     ------------------ */
7364
7365
7366 /*     REFERENCES CALLED : */
7367 /*     --------------------- */
7368
7369
7370 /*     DESCRIPTION/NOTES/LIMITATIONS : */
7371 /*     ----------------------------------- */
7372
7373
7374 /* ***********************************************************************
7375  */
7376 /*                            DECLARATIONS */
7377 /* ***********************************************************************
7378  */
7379
7380
7381
7382 /* ***********************************************************************
7383  */
7384 /*                      INITIALIZATIONS */
7385 /* ***********************************************************************
7386  */
7387
7388     /* Parameter adjustments */
7389     aposit -= 3;
7390     --posuiv;
7391
7392     /* Function Body */
7393     ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 2;
7394     if (ldbg) {
7395         AdvApp2Var_SysBase::mgenmsg_("MMPOSUI", 7L);
7396     }
7397     *iercod = 0;
7398
7399
7400 /* ***********************************************************************
7401  */
7402 /*                     PROCESSING */
7403 /* ***********************************************************************
7404  */
7405
7406
7407
7408     i__1 = *dimmat;
7409     for (i__ = 1; i__ <= i__1; ++i__) {
7410         jmin = i__ - aposit[(i__ << 1) + 1];
7411         i__2 = i__;
7412         for (j = jmin; j <= i__2; ++j) {
7413             imin = i__ + 1;
7414             trouve = FALSE_;
7415             while(! trouve && imin <= *dimmat) {
7416                 if (imin - aposit[(imin << 1) + 1] <= j) {
7417                     trouve = TRUE_;
7418                 } else {
7419                     ++imin;
7420                 }
7421             }
7422             k = aposit[(i__ << 1) + 2] - i__ + j;
7423             if (trouve) {
7424                 posuiv[k] = imin;
7425             } else {
7426                 posuiv[k] = -1;
7427             }
7428         }
7429     }
7430
7431
7432
7433
7434
7435     goto L9999;
7436
7437 /* ***********************************************************************
7438  */
7439 /*                   ERROR PROCESSING */
7440 /* ***********************************************************************
7441  */
7442
7443
7444
7445
7446 /* ***********************************************************************
7447  */
7448 /*                   RETURN CALLING PROGRAM */
7449 /* ***********************************************************************
7450  */
7451
7452 L9999:
7453
7454 /* ___ DESALLOCATION, ... */
7455
7456     AdvApp2Var_SysBase::maermsg_("MMPOSUI", iercod, 7L);
7457     if (ldbg) {
7458         AdvApp2Var_SysBase::mgsomsg_("MMPOSUI", 7L);
7459     }
7460  return 0 ;
7461 } /* mmposui_ */
7462
7463 //=======================================================================
7464 //function : AdvApp2Var_MathBase::mmresol_
7465 //purpose  :
7466 //=======================================================================
7467  int AdvApp2Var_MathBase::mmresol_(integer *hdimen,
7468                             integer *gdimen,
7469                             integer *hnstoc,
7470                             integer *gnstoc,
7471                             integer *mnstoc,
7472                             doublereal *matsyh,
7473                             doublereal *matsyg,
7474                             doublereal *vecsyh,
7475                             doublereal *vecsyg,
7476                             integer *hposit,
7477                             integer *hposui,
7478                             integer *gposit,
7479                             integer *mmposui,
7480                             integer *mposit,
7481                             doublereal *vecsol,
7482                             integer *iercod)
7483
7484 {
7485   integer c__100 = 100;
7486
7487    /* System generated locals */
7488     integer i__1, i__2;
7489
7490     /* Local variables */
7491     logical ldbg;
7492     doublereal* mcho = 0;
7493     integer jmin, jmax, i__, j, k, l;
7494     intptr_t iofv1, iofv2, iofv3, iofv4;
7495     doublereal *v1 = 0, *v2 = 0, *v3 = 0, *v4 = 0;
7496     integer deblig, dimhch;
7497     doublereal* hchole = 0;
7498     intptr_t iofmch, iofmam, iofhch;
7499     doublereal* matsym = 0;
7500     integer ier;
7501     integer aux;
7502
7503
7504
7505 /* ***********************************************************************
7506  */
7507
7508 /*     FUNCTION : */
7509 /*     ---------- */
7510 /*       SOLUTION OF THE SYSTEM */
7511 /*       H  t(G)   V     B */
7512 /*                    = */
7513 /*       G    0    L     C */
7514
7515 /*     KEYWORDS : */
7516 /*     ----------- */
7517 /*      RESERVE, SOLUTION, SYSTEM, LAGRANGIAN */
7518
7519 /*     INPUT ARGUMENTS : */
7520 /*     -------------------- */
7521 /*      HDIMEN: NOMBER OF LINE (OR COLUMN) OF THE HESSIAN MATRIX */
7522 /*      GDIMEN: NOMBER OF LINE OF THE MATRIX OF CONSTRAINTS */
7523 /*      HNSTOC: NOMBErS OF TERMS IN THE PROFILE OF HESSIAN MATRIX
7524 */
7525 /*      GNSTOC: NOMBERS OF TERMS IN THE PROFILE OF THE MATRIX OF CONSTRAINTS */
7526 /*      MNSTOC: NOMBERS OF TERMS IN THE PROFILE OF THE MATRIX M= G H t(G) */
7527 /*              where H IS THE HESSIAN MATRIX AND G IS THE MATRIX OF CONSTRAINTS */
7528 /*      MATSYH: TRIANGULAR INFERIOR PART OF THE HESSIAN MATRIX */
7529 /*              IN FORM OF PROFILE */
7530 /*      MATSYG: MATRIX OF CONSTRAINTS IN FORM OF PROFILE */
7531 /*      VECSYH: VECTOR OF THE SECOND MEMBER ASSOCIATED TO MATSYH */
7532 /*      VECSYG: VECTOR OF THE SECOND MEMBER ASSOCIATED TO MATSYG */
7533 /*      HPOSIT: TABLE OF POSITIONING OF THE HESSIAN MATRIX */
7534 /*              HPOSIT(1,I) CONTAINS THE NUMBER OF TERMS -1 */
7535 /*              WHICH ARE IN THE PROFILE AT LINE I */
7536 /*              HPOSIT(2,I) CONTAINS THE INDEX OF STORAGE OF TERM */
7537 /*              DIAGONAL OF THE MATRIX AT LINE I */
7538 /*      HPOSUI: TABLE ALLOWING TO PARSE THE HESSIAN MATRIX BY COLUMN */
7539 /*              IN FORM OF PROFILE */
7540 /*             HPOSUI(K) CONTAINS THE NUMBER OF LINE IMIN FOLLOWING THE CURRENT LINE*/
7541 /*              I WHERE H(I,J)=MATSYH(K) AS IT EXISTS IN THE */
7542 /*              SAME COLUMN J A TERM IN THE PROFILE OF LINE IMIN */
7543 /*              IF SUCH TERM DOES NOT EXIST IMIN=-1 */
7544 /*      GPOSIT: TABLE OF POSITIONING OF THE MATRIX OF CONSTRAINTS */
7545 /*              GPOSIT(1,I) CONTAINS THE NUMBER OF TERMS OF LINE I */
7546 /*                          WHICH ARE IN THE PROFILE */
7547 /*              GPOSIT(2,I) CONTAINS THE INDEX OF STORAGE OF THE LAST TERM */
7548 /*                          OF LINE I WHICH IS IN THE PROFILE */
7549 /*              GPOSIT(3,I) CONTAINS THE NUMBER OF COLUMN CORRESPONDING */
7550 /*                          TO THE FIRST TERM OF LINE I WHICH IS IN THE PROFILE */
7551 /*      MMPOSUI, MPOSIT: SAME STRUCTURE AS HPOSUI, BUT FOR MATRIX */
7552 /*              M=G H t(G) */
7553
7554
7555 /*     OUTPUT ARGUMENTS : */
7556 /*     --------------------- */
7557 /*       VECSOL: VECTOR SOLUTION V OF THE SYSTEM */
7558 /*       IERCOD: ERROR CODE */
7559
7560 /*     COMMONS USED : */
7561 /*     ------------------ */
7562
7563
7564 /*     REFERENCES CALLED : */
7565 /*     --------------------- */
7566
7567
7568 /*     DESCRIPTION/NOTES/LIMITATIONS : */
7569 /*     ----------------------------------- */
7570 /* > */
7571 /* ***********************************************************************
7572  */
7573 /*                            DECLARATIONS */
7574 /* ***********************************************************************
7575  */
7576
7577 /* ***********************************************************************
7578  */
7579 /*                      INITIALISATIONS */
7580 /* ***********************************************************************
7581  */
7582
7583     /* Parameter adjustments */
7584     --vecsol;
7585     hposit -= 3;
7586     --vecsyh;
7587     --hposui;
7588     --matsyh;
7589     --matsyg;
7590     --vecsyg;
7591     gposit -= 4;
7592     --mmposui;
7593     mposit -= 3;
7594
7595     /* Function Body */
7596     ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 2;
7597     if (ldbg) {
7598         AdvApp2Var_SysBase::mgenmsg_("MMRESOL", 7L);
7599     }
7600     *iercod = 0;
7601     iofhch = 0;
7602     iofv1 = 0;
7603     iofv2 = 0;
7604     iofv3 = 0;
7605     iofv4 = 0;
7606     iofmam = 0;
7607     iofmch = 0;
7608
7609 /* ***********************************************************************
7610  */
7611 /*                     PROCESSING */
7612 /* ***********************************************************************
7613  */
7614
7615 /*    Dynamic allocation */
7616     AdvApp2Var_SysBase anAdvApp2Var_SysBase;
7617     anAdvApp2Var_SysBase.macrar8_(hdimen, &c__100, v1, &iofv1, &ier);
7618     if (ier > 0) {
7619         goto L9102;
7620     }
7621     dimhch = hposit[(*hdimen << 1) + 2];
7622     anAdvApp2Var_SysBase.macrar8_(&dimhch, &c__100, hchole, &iofhch, &ier);
7623     if (ier > 0) {
7624         goto L9102;
7625     }
7626
7627 /*   solution of system 1     H V1 = b */
7628 /*   where H=MATSYH  and b=VECSYH */
7629
7630     mmchole_(hnstoc, hdimen, &matsyh[1], &hposit[3], &hposui[1], &hchole[
7631             iofhch], &ier);
7632     if (ier > 0) {
7633         goto L9101;
7634     }
7635     mmrslss_(hnstoc, hdimen, &hchole[iofhch], &hposit[3], &hposui[1], &vecsyh[
7636             1], &v1[iofv1], &ier);
7637     if (ier > 0) {
7638         goto L9102;
7639     }
7640
7641 /*    Case when there are constraints */
7642
7643     if (*gdimen > 0) {
7644
7645 /*    Calculate the vector of the second member V2=G H(-1) b -c = G v1-c */
7646 /*    of system of unknown Lagrangian vector MULTIP */
7647 /*    where G=MATSYG */
7648 /*          c=VECSYG */
7649
7650         anAdvApp2Var_SysBase.macrar8_(gdimen, &c__100, v2, &iofv2, &ier);
7651         if (ier > 0) {
7652             goto L9102;
7653         }
7654         anAdvApp2Var_SysBase.macrar8_(hdimen, &c__100, v3, &iofv3, &ier);
7655         if (ier > 0) {
7656             goto L9102;
7657         }
7658         anAdvApp2Var_SysBase.macrar8_(gdimen, &c__100, v4, &iofv4, &ier);
7659         if (ier > 0) {
7660             goto L9102;
7661         }
7662         anAdvApp2Var_SysBase.macrar8_(mnstoc, &c__100, matsym, &iofmam, &ier);
7663         if (ier > 0) {
7664             goto L9102;
7665         }
7666
7667         deblig = 1;
7668         mmatvec_(gdimen, hdimen, &gposit[4], gnstoc, &matsyg[1], &v1[iofv1], &
7669                 deblig, &v2[iofv2], &ier);
7670         if (ier > 0) {
7671             goto L9101;
7672         }
7673         i__1 = *gdimen;
7674         for (i__ = 1; i__ <= i__1; ++i__) {
7675             v2[i__ + iofv2 - 1] -= vecsyg[i__];
7676         }
7677
7678 /*     Calculate the matrix M= G H(-1) t(G) */
7679 /*     RESOL DU SYST 2 : H qi = gi */
7680 /*            where is a vector column of t(G) */
7681 /*                qi=v3 */
7682 /*            then calculate G qi */
7683 /*            then construct M in form of profile */
7684
7685
7686
7687         i__1 = *gdimen;
7688         for (i__ = 1; i__ <= i__1; ++i__) {
7689             AdvApp2Var_SysBase::mvriraz_(hdimen, &v1[iofv1]);
7690             AdvApp2Var_SysBase::mvriraz_(hdimen, &v3[iofv3]);
7691             AdvApp2Var_SysBase::mvriraz_(gdimen, &v4[iofv4]);
7692             jmin = gposit[i__ * 3 + 3];
7693             jmax = gposit[i__ * 3 + 1] + gposit[i__ * 3 + 3] - 1;
7694             aux = gposit[i__ * 3 + 2] - gposit[i__ * 3 + 1] - jmin + 1;
7695             i__2 = jmax;
7696             for (j = jmin; j <= i__2; ++j) {
7697                 k = j + aux;
7698                 v1[j + iofv1 - 1] = matsyg[k];
7699             }
7700             mmrslss_(hnstoc, hdimen, &hchole[iofhch], &hposit[3], &hposui[1],
7701                     &v1[iofv1], &v3[iofv3], &ier);
7702             if (ier > 0) {
7703                 goto L9101;
7704             }
7705
7706             deblig = i__;
7707             mmatvec_(gdimen, hdimen, &gposit[4], gnstoc, &matsyg[1], &v3[
7708                     iofv3], &deblig, &v4[iofv4], &ier);
7709             if (ier > 0) {
7710                 goto L9101;
7711             }
7712
7713             k = mposit[(i__ << 1) + 2];
7714             matsym[k + iofmam - 1] = v4[i__ + iofv4 - 1];
7715             while(mmposui[k] > 0) {
7716                 l = mmposui[k];
7717                 k = mposit[(l << 1) + 2] - l + i__;
7718                 matsym[k + iofmam - 1] = v4[l + iofv4 - 1];
7719             }
7720         }
7721
7722
7723 /*    SOLVE SYST 3  M L = V2 */
7724 /*     WITH L=V4 */
7725
7726
7727         AdvApp2Var_SysBase::mvriraz_(gdimen, &v4[iofv4]);
7728         anAdvApp2Var_SysBase.macrar8_(mnstoc, &c__100, mcho, &iofmch, &ier);
7729         if (ier > 0) {
7730             goto L9102;
7731         }
7732         mmchole_(mnstoc, gdimen, &matsym[iofmam], &mposit[3], &mmposui[1], &
7733                 mcho[iofmch], &ier);
7734         if (ier > 0) {
7735             goto L9101;
7736         }
7737         mmrslss_(mnstoc, gdimen, &mcho[iofmch], &mposit[3], &mmposui[1], &v2[
7738                 iofv2], &v4[iofv4], &ier);
7739         if (ier > 0) {
7740             goto L9102;
7741         }
7742
7743
7744 /*    CALCULATE THE VECTOR OF THE SECOND MEMBER OF THE SYSTEM  Hx = b - t(G) L
7745 */
7746 /*                                                      = V1 */
7747
7748         AdvApp2Var_SysBase::mvriraz_(hdimen, &v1[iofv1]);
7749         mmtmave_(gdimen, hdimen, &gposit[4], gnstoc, &matsyg[1], &v4[iofv4], &
7750                 v1[iofv1], &ier);
7751         if (ier > 0) {
7752             goto L9101;
7753         }
7754         i__1 = *hdimen;
7755         for (i__ = 1; i__ <= i__1; ++i__) {
7756             v1[i__ + iofv1 - 1] = vecsyh[i__] - v1[i__ + iofv1 - 1];
7757         }
7758
7759 /*    RESOL SYST 4   Hx = b - t(G) L */
7760
7761
7762         mmrslss_(hnstoc, hdimen, &hchole[iofhch], &hposit[3], &hposui[1], &v1[
7763                 iofv1], &vecsol[1], &ier);
7764         if (ier > 0) {
7765             goto L9102;
7766         }
7767     } else {
7768         i__1 = *hdimen;
7769         for (i__ = 1; i__ <= i__1; ++i__) {
7770             vecsol[i__] = v1[i__ + iofv1 - 1];
7771         }
7772     }
7773
7774     goto L9999;
7775
7776 /* ***********************************************************************
7777  */
7778 /*                   PROCESSING OF ERRORS */
7779 /* ***********************************************************************
7780  */
7781
7782
7783 L9101:
7784     *iercod = 1;
7785     goto L9999;
7786
7787 L9102:
7788     AdvApp2Var_SysBase::mswrdbg_("MMRESOL : PROBLEM WITH DIMMAT", 30L);
7789     *iercod = 2;
7790
7791 /* ***********************************************************************
7792  */
7793 /*                   RETURN CALLING PROGRAM */
7794 /* ***********************************************************************
7795  */
7796
7797 L9999:
7798
7799 /* ___ DESALLOCATION, ... */
7800     anAdvApp2Var_SysBase.macrdr8_(hdimen, &c__100, v1, &iofv1, &ier);
7801     if (*iercod == 0 && ier > 0) {
7802         *iercod = 3;
7803     }
7804     anAdvApp2Var_SysBase.macrdr8_(&dimhch, &c__100, hchole, &iofhch, &ier);
7805     if (*iercod == 0 && ier > 0) {
7806         *iercod = 3;
7807     }
7808     anAdvApp2Var_SysBase.macrdr8_(gdimen, &c__100, v2, &iofv2, &ier);
7809     if (*iercod == 0 && ier > 0) {
7810         *iercod = 3;
7811     }
7812     anAdvApp2Var_SysBase.macrdr8_(hdimen, &c__100, v3, &iofv3, &ier);
7813     if (*iercod == 0 && ier > 0) {
7814         *iercod = 3;
7815     }
7816     anAdvApp2Var_SysBase.macrdr8_(gdimen, &c__100, v4, &iofv4, &ier);
7817     if (*iercod == 0 && ier > 0) {
7818         *iercod = 3;
7819     }
7820     anAdvApp2Var_SysBase.macrdr8_(mnstoc, &c__100, matsym, &iofmam, &ier);
7821     if (*iercod == 0 && ier > 0) {
7822         *iercod = 3;
7823     }
7824     anAdvApp2Var_SysBase.macrdr8_(mnstoc, &c__100, mcho, &iofmch, &ier);
7825     if (*iercod == 0 && ier > 0) {
7826         *iercod = 3;
7827     }
7828
7829     AdvApp2Var_SysBase::maermsg_("MMRESOL", iercod, 7L);
7830     if (ldbg) {
7831         AdvApp2Var_SysBase::mgsomsg_("MMRESOL", 7L);
7832     }
7833  return 0 ;
7834 } /* mmresol_ */
7835
7836 //=======================================================================
7837 //function : mmrslss_
7838 //purpose  :
7839 //=======================================================================
7840 int mmrslss_(integer *,//mxcoef,
7841              integer *dimens,
7842              doublereal *smatri,
7843              integer *sposit,
7844              integer *posuiv,
7845              doublereal *mscnmbr,
7846              doublereal *soluti,
7847              integer *iercod)
7848 {
7849   /* System generated locals */
7850   integer i__1, i__2;
7851
7852   /* Local variables */
7853   logical ldbg;
7854   integer i__, j;
7855   doublereal somme;
7856   integer pointe, ptcour;
7857
7858 /* ***********************************************************************
7859  */
7860
7861 /*     FuNCTION : */
7862 /*     ----------                     T */
7863 /*       Solves linear system SS x = b where S is a  */
7864 /*       triangular lower matrix given in form of profile */
7865
7866 /*     KEYWORDS : */
7867 /*     ----------- */
7868 /*     RESERVE, MATRICE_PROFILE, RESOLUTION, CHOLESKI */
7869
7870 /*     INPUT ARGUMENTS : */
7871 /*     -------------------- */
7872 /*     MXCOEF  : Maximum number of non-null coefficient in the matrix */
7873 /*     DIMENS  : Dimension of the matrix */
7874 /*     SMATRI(MXCOEF) : Values of coefficients of the matrix */
7875 /*     SPOSIT(2,DIMENS): */
7876 /*       SPOSIT(1,*) : Distance diagonal-extremity of the line */
7877 /*       SPOSIT(2,*) : Position of diagonal terms in AMATRI */
7878 /*     POSUIV(MXCOEF): first line inferior not out of profile */
7879 /*     MSCNMBR(DIMENS): Vector second member of the equation */
7880
7881 /*     OUTPUT ARGUMENTS : */
7882 /*     --------------------- */
7883 /*     SOLUTI(NDIMEN) : Result vector */
7884 /*     IERCOD   : Error code 0  : ok */
7885
7886 /*     COMMONS USED : */
7887 /*     ------------------ */
7888
7889
7890 /*     REFERENCES CALLED : */
7891 /*     --------------------- */
7892
7893
7894 /*     DESCRIPTION/NOTES/LIMITATIONS : */
7895 /*     ----------------------------------- */
7896 /*       T */
7897 /*     SS  is the decomposition of choleski of a symmetric matrix */
7898 /*     defined postive, that can result from routine MMCHOLE. */
7899
7900 /*     For a full matrix it is possible to use MRSLMSC */
7901
7902 /*     LEVEL OF DEBUG = 4 */
7903 /* > */
7904 /* ***********************************************************************
7905  */
7906 /*                            DECLARATIONS */
7907 /* ***********************************************************************
7908  */
7909
7910
7911
7912 /* ***********************************************************************
7913  */
7914 /*                      INITIALISATIONS */
7915 /* ***********************************************************************
7916  */
7917
7918     /* Parameter adjustments */
7919     --posuiv;
7920     --smatri;
7921     --soluti;
7922     --mscnmbr;
7923     sposit -= 3;
7924
7925     /* Function Body */
7926     ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 4;
7927     if (ldbg) {
7928         AdvApp2Var_SysBase::mgenmsg_("MMRSLSS", 7L);
7929     }
7930     *iercod = 0;
7931
7932 /* ***********************************************************************
7933  */
7934 /*                     PROCESSING */
7935 /* ***********************************************************************
7936  */
7937
7938 /* ----- Solution of Sw = b */
7939
7940     i__1 = *dimens;
7941     for (i__ = 1; i__ <= i__1; ++i__) {
7942
7943         pointe = sposit[(i__ << 1) + 2];
7944         somme = 0.;
7945         i__2 = i__ - 1;
7946         for (j = i__ - sposit[(i__ << 1) + 1]; j <= i__2; ++j) {
7947             somme += smatri[pointe - (i__ - j)] * soluti[j];
7948         }
7949
7950         soluti[i__] = (mscnmbr[i__] - somme) / smatri[pointe];
7951     }
7952 /*                     T */
7953 /* ----- Solution of S u = w */
7954
7955     for (i__ = *dimens; i__ >= 1; --i__) {
7956
7957         pointe = sposit[(i__ << 1) + 2];
7958         j = posuiv[pointe];
7959         somme = 0.;
7960         while(j > 0) {
7961             ptcour = sposit[(j << 1) + 2] - (j - i__);
7962             somme += smatri[ptcour] * soluti[j];
7963             j = posuiv[ptcour];
7964         }
7965
7966         soluti[i__] = (soluti[i__] - somme) / smatri[pointe];
7967     }
7968
7969     goto L9999;
7970
7971 /* ***********************************************************************
7972  */
7973 /*                   ERROR PROCESSING */
7974 /* ***********************************************************************
7975  */
7976
7977
7978 /* ***********************************************************************
7979  */
7980 /*                   RETURN PROGRAM CALLING */
7981 /* ***********************************************************************
7982  */
7983
7984 L9999:
7985
7986     AdvApp2Var_SysBase::maermsg_("MMRSLSS", iercod, 7L);
7987     if (ldbg) {
7988         AdvApp2Var_SysBase::mgsomsg_("MMRSLSS", 7L);
7989     }
7990  return 0 ;
7991 } /* mmrslss_ */
7992
7993 //=======================================================================
7994 //function : mmrslw_
7995 //purpose  :
7996 //=======================================================================
7997 int mmrslw_(integer *normax,
7998             integer *nordre,
7999             integer *ndimen,
8000             doublereal *epspiv,
8001             doublereal *abmatr,
8002             doublereal *xmatri,
8003             integer *iercod)
8004 {
8005   /* System generated locals */
8006     integer abmatr_dim1, abmatr_offset, xmatri_dim1, xmatri_offset, i__1,
8007             i__2, i__3;
8008     doublereal d__1;
8009
8010     /* Local variables */
8011     integer kpiv;
8012     doublereal pivot;
8013     integer ii, jj, kk;
8014     doublereal akj;
8015
8016
8017 /* **********************************************************************
8018 */
8019
8020 /*     FUNCTION : */
8021 /*     ---------- */
8022 /*  Solution of a linear system A.x = B of N equations to N */
8023 /*  unknown by Gauss method (partial pivot) or : */
8024 /*          A is matrix NORDRE * NORDRE, */
8025 /*          B is matrix NORDRE (lines) * NDIMEN (columns), */
8026 /*          x is matrix NORDRE (lines) * NDIMEN (columns). */
8027 /*  In this program, A and B are stored in matrix ABMATR  */
8028 /*  the lines and columns which of were inverted. ABMATR(k,j) is */
8029 /*  term A(j,k) if k <= NORDRE, B(j,k-NORDRE) otherwise (see example). */
8030
8031 /*     KEYWORDS : */
8032 /*     ----------- */
8033 /* TOUS, MATH_ACCES::EQUATION&, MATRICE&, RESOLUTION, GAUSS, &SOLUTION */
8034
8035 /*     INPUT ARGUMENTS : */
8036 /*     ------------------ */
8037 /*   NORMAX : Max size of the first index of XMATRI. This argument */
8038 /*            serves only for the declaration of dimension of XMATRI and should be */
8039 /*            above or equal to NORDRE. */
8040 /*   NORDRE : Order of the matrix i.e. number of equations and  */
8041 /*            unknown quantities of the linear system to be solved. */
8042 /*   NDIMEN : Number of the second member. */
8043 /*   EPSPIV : Minimal value of a pivot. If during the calculation  */
8044 /*            the absolute value of the pivot is below EPSPIV, the */
8045 /*            system of equations is declared singular. EPSPIV should */
8046 /*            be a "small" real. */
8047
8048 /*   ABMATR(NORDRE+NDIMEN,NORDRE) : Auxiliary matrix containing  */
8049 /*                                  matrix A and matrix B. */
8050
8051 /*     OUTPUT ARGUMENTS : */
8052 /*     ------------------- */
8053 /*   XMATRI : Matrix containing  NORDRE*NDIMEN solutions. */
8054 /*   IERCOD=0 shows that all solutions are calculated. */
8055 /*   IERCOD=1 shows that the matrix is of lower rank than NORDRE */
8056 /*            (the system is singular). */
8057
8058 /*     COMMONS USED   : */
8059 /*     ---------------- */
8060
8061 /*     REFERENCES CALLED   : */
8062 /*     ----------------------- */
8063
8064 /*     DESCRIPTION/NOTES/LIMITATIONS : */
8065 /*     ----------------------------------- */
8066 /*     ATTENTION : the indices of line and column are inverted */
8067 /*                 compared to usual indices. */
8068 /*                 System : */
8069 /*                        a1*x + b1*y = c1 */
8070 /*                        a2*x + b2*y = c2 */
8071 /*                 should be represented by matrix ABMATR : */
8072
8073 /*                 ABMATR(1,1) = a1  ABMATR(1,2) = a2 */
8074 /*                 ABMATR(2,1) = b1  ABMATR(2,2) = b2 */
8075 /*                 ABMATR(3,1) = c1  ABMATR(3,2) = c2 */
8076
8077 /*     To solve this system, it is necessary to set : */
8078
8079 /*                 NORDRE = 2 (there are 2 equations with 2 unknown values), */
8080 /*                 NDIMEN = 1 (there is only one second member), */
8081 /*                 any NORMAX can be taken >= NORDRE. */
8082
8083 /*     To use this routine, it is recommended to use one of */
8084 /*     interfaces : MMRSLWI or MMMRSLWD. */
8085 /* > */
8086 /* **********************************************************************
8087 */
8088
8089 /*   Name of the routine */
8090
8091 /*      INTEGER IBB,MNFNDEB */
8092
8093 /*      IBB=MNFNDEB() */
8094 /*      IF (IBB.GE.2) CALL MGENMSG(NOMPR) */
8095     /* Parameter adjustments */
8096     xmatri_dim1 = *normax;
8097     xmatri_offset = xmatri_dim1 + 1;
8098     xmatri -= xmatri_offset;
8099     abmatr_dim1 = *nordre + *ndimen;
8100     abmatr_offset = abmatr_dim1 + 1;
8101     abmatr -= abmatr_offset;
8102
8103     /* Function Body */
8104     *iercod = 0;
8105
8106 /* *********************************************************************
8107 */
8108 /*                  Triangulation of matrix ABMATR. */
8109 /* *********************************************************************
8110 */
8111
8112     i__1 = *nordre;
8113     for (kk = 1; kk <= i__1; ++kk) {
8114
8115 /* ---------- Find max pivot in column KK. ------------
8116 --- */
8117
8118         pivot = *epspiv;
8119         kpiv = 0;
8120         i__2 = *nordre;
8121         for (jj = kk; jj <= i__2; ++jj) {
8122             akj = (d__1 = abmatr[kk + jj * abmatr_dim1], advapp_abs(d__1));
8123             if (akj > pivot) {
8124                 pivot = akj;
8125                 kpiv = jj;
8126             }
8127 /* L100: */
8128         }
8129         if (kpiv == 0) {
8130             goto L9900;
8131         }
8132
8133 /* --------- Swapping of line KPIV with line KK. ------
8134 --- */
8135
8136         if (kpiv != kk) {
8137             i__2 = *nordre + *ndimen;
8138             for (jj = kk; jj <= i__2; ++jj) {
8139                 akj = abmatr[jj + kk * abmatr_dim1];
8140                 abmatr[jj + kk * abmatr_dim1] = abmatr[jj + kpiv *
8141                         abmatr_dim1];
8142                 abmatr[jj + kpiv * abmatr_dim1] = akj;
8143 /* L200: */
8144             }
8145         }
8146
8147 /* ---------- Removal and triangularization. -----------
8148 --- */
8149
8150         pivot = -abmatr[kk + kk * abmatr_dim1];
8151         i__2 = *nordre;
8152         for (ii = kk + 1; ii <= i__2; ++ii) {
8153             akj = abmatr[kk + ii * abmatr_dim1] / pivot;
8154             i__3 = *nordre + *ndimen;
8155             for (jj = kk + 1; jj <= i__3; ++jj) {
8156                 abmatr[jj + ii * abmatr_dim1] += akj * abmatr[jj + kk *
8157                         abmatr_dim1];
8158 /* L400: */
8159             }
8160 /* L300: */
8161         }
8162
8163
8164 /* L1000: */
8165     }
8166
8167 /* *********************************************************************
8168 */
8169 /*          Solution of the system of triangular equations. */
8170 /*   Matrix ABMATR(NORDRE+JJ,II), contains second members  */
8171 /*             of the system for 1<=j<=NDIMEN and 1<=i<=NORDRE. */
8172 /* *********************************************************************
8173 */
8174
8175
8176 /* ---------------- Calculation of solutions by ascending. -----------------
8177 */
8178
8179     for (kk = *nordre; kk >= 1; --kk) {
8180         pivot = abmatr[kk + kk * abmatr_dim1];
8181         i__1 = *ndimen;
8182         for (ii = 1; ii <= i__1; ++ii) {
8183             akj = abmatr[ii + *nordre + kk * abmatr_dim1];
8184             i__2 = *nordre;
8185             for (jj = kk + 1; jj <= i__2; ++jj) {
8186                 akj -= abmatr[jj + kk * abmatr_dim1] * xmatri[jj + ii *
8187                         xmatri_dim1];
8188 /* L800: */
8189             }
8190             xmatri[kk + ii * xmatri_dim1] = akj / pivot;
8191 /* L700: */
8192         }
8193 /* L600: */
8194     }
8195     goto L9999;
8196
8197 /* ------If the absolute value of a pivot is smaller than -------- */
8198 /* ---------- EPSPIV: return the code of error. ------------
8199 */
8200
8201 L9900:
8202     *iercod = 1;
8203
8204
8205
8206 L9999:
8207     if (*iercod > 0) {
8208         AdvApp2Var_SysBase::maermsg_("MMRSLW ", iercod, 7L);
8209     }
8210 /*      IF (IBB.GE.2) CALL MGSOMSG(NOMPR) */
8211  return 0 ;
8212 } /* mmrslw_ */
8213
8214 //=======================================================================
8215 //function : AdvApp2Var_MathBase::mmmrslwd_
8216 //purpose  :
8217 //=======================================================================
8218  int AdvApp2Var_MathBase::mmmrslwd_(integer *normax,
8219                              integer *nordre,
8220                              integer *ndim,
8221                              doublereal *amat,
8222                              doublereal *bmat,
8223                              doublereal *epspiv,
8224                              doublereal *aaux,
8225                              doublereal *xmat,
8226                              integer *iercod)
8227
8228 {
8229   /* System generated locals */
8230   integer amat_dim1, amat_offset, bmat_dim1, bmat_offset, xmat_dim1,
8231   xmat_offset, aaux_dim1, aaux_offset, i__1, i__2;
8232
8233   /* Local variables */
8234   integer i__, j;
8235   integer ibb;
8236
8237 /*      IMPLICIT DOUBLE PRECISION (A-H,O-Z) */
8238 /*      IMPLICIT INTEGER (I-N) */
8239
8240
8241 /* **********************************************************************
8242 */
8243
8244 /*     FUNCTION : */
8245 /*     ---------- */
8246 /*        Solution of a linear system by Gauss method where */
8247 /*        the second member is a table of vectors. Method of partial pivot. */
8248
8249 /*     KEYWORDS : */
8250 /*     ----------- */
8251 /*        ALL, MATH_ACCES :: */
8252 /*        SYSTEME&,EQUATION&, RESOLUTION,GAUSS ,&VECTEUR */
8253
8254 /*     INPUT ARGUMENTS : */
8255 /*     ------------------ */
8256 /*        NORMAX : Max. Dimension of AMAT. */
8257 /*        NORDRE :  Order of the matrix. */
8258 /*        NDIM : Number of columns of BMAT and XMAT. */
8259 /*        AMAT(NORMAX,NORDRE) : The processed matrix. */
8260 /*        BMAT(NORMAX,NDIM)   : The matrix of second member. */
8261 /*        XMAT(NORMAX,NDIM)   : The matrix of solutions. */
8262 /*        EPSPIV : Min value of a pivot. */
8263
8264 /*     OUTPUT ARGUMENTS : */
8265 /*     ------------------- */
8266 /*        AAUX(NORDRE+NDIM,NORDRE) : Auxiliary matrix. */
8267 /*        XMAT(NORMAX,NDIM) : Matrix of solutions. */
8268 /*        IERCOD=0 shows that solutions in XMAT are valid. */
8269 /*        IERCOD=1 shows that matrix AMAT is of lower rank than NORDRE. */
8270
8271 /*     COMMONS USED   : */
8272 /*     ---------------- */
8273
8274 /*      .Neant. */
8275
8276 /*     REFERENCES CALLED : */
8277 /*     ---------------------- */
8278 /*     Type  Name */
8279 /*           MAERMSG              MGENMSG              MGSOMSG */
8280 /*           MMRSLW          I*4  MNFNDEB */
8281
8282 /*     DESCRIPTION/NOTES/LIMITATIONS : */
8283 /*     ----------------------------------- */
8284 /*    ATTENTION : lines and columns are located in usual order : */
8285 /*               1st index  = index line */
8286 /*               2nd index = index column */
8287 /*    Example, the system : */
8288 /*                 a1*x + b1*y = c1 */
8289 /*                 a2*x + b2*y = c2 */
8290 /*    is represented by matrix AMAT : */
8291
8292 /*                 AMAT(1,1) = a1  AMAT(2,1) = a2 */
8293 /*                 AMAT(1,2) = b1  AMAT(2,2) = b2 */
8294
8295 /*     The first index is the index of line, the second index */
8296 /*     is the index of columns (Compare with MMRSLWI which is faster). */
8297
8298 /* > */
8299 /* **********************************************************************
8300 */
8301
8302 /*   Name of the routine */
8303
8304     /* Parameter adjustments */
8305     amat_dim1 = *normax;
8306     amat_offset = amat_dim1 + 1;
8307     amat -= amat_offset;
8308     xmat_dim1 = *normax;
8309     xmat_offset = xmat_dim1 + 1;
8310     xmat -= xmat_offset;
8311     aaux_dim1 = *nordre + *ndim;
8312     aaux_offset = aaux_dim1 + 1;
8313     aaux -= aaux_offset;
8314     bmat_dim1 = *normax;
8315     bmat_offset = bmat_dim1 + 1;
8316     bmat -= bmat_offset;
8317
8318     /* Function Body */
8319     ibb = AdvApp2Var_SysBase::mnfndeb_();
8320     if (ibb >= 3) {
8321         AdvApp2Var_SysBase::mgenmsg_("MMMRSLW", 7L);
8322     }
8323
8324 /*   Initialization of the auxiliary matrix. */
8325
8326     i__1 = *nordre;
8327     for (i__ = 1; i__ <= i__1; ++i__) {
8328         i__2 = *nordre;
8329         for (j = 1; j <= i__2; ++j) {
8330             aaux[j + i__ * aaux_dim1] = amat[i__ + j * amat_dim1];
8331 /* L200: */
8332         }
8333 /* L100: */
8334     }
8335
8336 /*    Second member. */
8337
8338     i__1 = *nordre;
8339     for (i__ = 1; i__ <= i__1; ++i__) {
8340         i__2 = *ndim;
8341         for (j = 1; j <= i__2; ++j) {
8342             aaux[j + *nordre + i__ * aaux_dim1] = bmat[i__ + j * bmat_dim1];
8343 /* L400: */
8344         }
8345 /* L300: */
8346     }
8347
8348 /*    Solution of the system of equations. */
8349
8350     mmrslw_(normax, nordre, ndim, epspiv, &aaux[aaux_offset], &xmat[
8351             xmat_offset], iercod);
8352
8353
8354     if (*iercod != 0) {
8355         AdvApp2Var_SysBase::maermsg_("MMMRSLW", iercod, 7L);
8356     }
8357     if (ibb >= 3) {
8358         AdvApp2Var_SysBase::mgsomsg_("MMMRSLW", 7L);
8359     }
8360  return 0 ;
8361 } /* mmmrslwd_ */
8362
8363 //=======================================================================
8364 //function : AdvApp2Var_MathBase::mmrtptt_
8365 //purpose  :
8366 //=======================================================================
8367  int AdvApp2Var_MathBase::mmrtptt_(integer *ndglgd,
8368                             doublereal *rtlegd)
8369
8370 {
8371   integer ideb, nmod2, nsur2, ilong, ibb;
8372
8373
8374 /* **********************************************************************
8375 */
8376
8377 /*     FUNCTION : */
8378 /*     ---------- */
8379 /*     Extracts from Common LDGRTL the STRICTLY positive roots of the */
8380 /*     Legendre polynom of degree NDGLGD, for 2 <= NDGLGD <= 61. */
8381
8382 /*     KEYWORDS : */
8383 /*     ----------- */
8384 /*     TOUS, AB_SPECIFI::COMMON&, EXTRACTION, &RACINE, &LEGENDRE. */
8385
8386 /*     INPUT ARGUMENTS : */
8387 /*     ------------------ */
8388 /*        NDGLGD : Mathematic degree of Legendre polynom. */
8389 /*                 This degree should be above or equal to 2 and */
8390 /*                 below or equal to 61. */
8391
8392 /*     OUTPUT ARGUMENTS : */
8393 /*     ------------------- */
8394 /*        RTLEGD : The table of strictly positive roots of */
8395 /*                 Legendre polynom of degree NDGLGD. */
8396
8397 /*     COMMONS USED   : */
8398 /*     ---------------- */
8399
8400 /*     REFERENCES CALLED   : */
8401 /*     ----------------------- */
8402
8403 /*     DESCRIPTION/NOTES/LIMITATIONS : */
8404 /*     ----------------------------------- */
8405 /*     ATTENTION: the condition on NDEGRE ( 2 <= NDEGRE <= 61) is not */
8406 /*     tested. The caller should make the test. */
8407
8408 /* > */
8409 /* **********************************************************************
8410 */
8411 /*   Nome of the routine */
8412
8413
8414 /*   Common MLGDRTL: */
8415 /*   This common includes POSITIVE roots of Legendre polynoms */
8416 /*   AND the weight of Gauss quadrature formulas on all */
8417 /*   POSITIVE roots of Legendre polynoms. */
8418
8419
8420 /* ***********************************************************************
8421  */
8422
8423 /*     FUNCTION : */
8424 /*     ---------- */
8425 /*   The common of Legendre roots. */
8426
8427 /*     KEYWORDS : */
8428 /*     ----------- */
8429 /*        BASE LEGENDRE */
8430
8431 /*     DEMSCRIPTION/NOTES/LIMITATIONS : */
8432 /*     ----------------------------------- */
8433
8434 /* > */
8435 /* ***********************************************************************
8436  */
8437
8438
8439
8440
8441 /*   ROOTAB : Table of all rotts of Legendre polynoms */
8442 /*   between [0,1]. They are ranked for degrees increasing from 2 to 61. */
8443 /*   HILTAB : Table of Legendre interpolators concerning ROOTAB. */
8444 /*   The address is the same. */
8445 /*   HI0TAB : Table of Legendre interpolators for root x=0 */
8446 /*   the polynoms of UNEVEN degree. */
8447 /*   RTLTB0 : Table of Li(uk) where uk are roots of a */
8448 /*   Legendre polynom of EVEN degree. */
8449 /*   RTLTB1 : Table of Li(uk) where uk are roots of a */
8450 /*   Legendre polynom of UNEVEN degree. */
8451
8452
8453 /************************************************************************
8454 *****/
8455     /* Parameter adjustments */
8456     --rtlegd;
8457
8458     /* Function Body */
8459     ibb = AdvApp2Var_SysBase::mnfndeb_();
8460     if (ibb >= 3) {
8461         AdvApp2Var_SysBase::mgenmsg_("MMRTPTT", 7L);
8462     }
8463     if (*ndglgd < 2) {
8464         goto L9999;
8465     }
8466
8467     nsur2 = *ndglgd / 2;
8468     nmod2 = *ndglgd % 2;
8469
8470     ilong = nsur2 << 3;
8471     ideb = nsur2 * (nsur2 - 1) / 2 + 1;
8472     AdvApp2Var_SysBase::mcrfill_(&ilong,
8473              &mlgdrtl_.rootab[ideb + nmod2 * 465 - 1],
8474              &rtlegd[1]);
8475
8476 /* ----------------------------- The end --------------------------------
8477 */
8478
8479 L9999:
8480     if (ibb >= 3) {
8481         AdvApp2Var_SysBase::mgsomsg_("MMRTPTT", 7L);
8482     }
8483     return 0;
8484 } /* mmrtptt_ */
8485
8486 //=======================================================================
8487 //function : AdvApp2Var_MathBase::mmsrre2_
8488 //purpose  :
8489 //=======================================================================
8490  int AdvApp2Var_MathBase::mmsrre2_(doublereal *tparam,
8491                             integer *nbrval,
8492                             doublereal *tablev,
8493                             doublereal *epsil,
8494                             integer *numint,
8495                             integer *itypen,
8496                             integer *iercod)
8497 {
8498   /* System generated locals */
8499   doublereal d__1;
8500
8501   /* Local variables */
8502   integer ideb, ifin, imil, ibb;
8503
8504 /* ***********************************************************************
8505  */
8506
8507 /*     FUNCTION : */
8508 /*     -------- */
8509
8510 /*     Find the interval corresponding to a valueb given in  */
8511 /*     increasing order of real numbers with double precision. */
8512
8513 /*     KEYWORDS : */
8514 /*     --------- */
8515 /*     TOUS,MATH_ACCES::TABLEAU&,POINT&,CORRESPONDANCE,&RANG */
8516
8517 /*     INPUT ARGUMENTS : */
8518 /*     ------------------ */
8519
8520 /*     TPARAM  : Value to be tested. */
8521 /*     NBRVAL  : Size of TABLEV */
8522 /*     TABLEV  : Table of reals. */
8523 /*     EPSIL   : Epsilon of precision */
8524
8525 /*     OUTPUT ARGUMENTS : */
8526 /*     ------------------- */
8527
8528 /*     NUMINT  : Number of the interval (between 1 and NBRVAL-1). */
8529 /*     ITYPEN  : = 0 TPARAM is inside the interval NUMINT */
8530 /*               = 1 : TPARAM corresponds to the lower limit of */
8531 /*               the provided interval. */
8532 /*               = 2 : TPARAM corresponds to the upper limit of */
8533 /*               the provided interval. */
8534
8535 /*     IERCOD : Error code. */
8536 /*                     = 0 : OK */
8537 /*                     = 1 : TABLEV does not contain enough elements. */
8538 /*                     = 2 : TPARAM out of limits of TABLEV. */
8539
8540 /*     COMMONS USED : */
8541 /*     ---------------- */
8542
8543 /*     REFERENCES CALLED : */
8544 /*     ------------------- */
8545
8546 /*     DESCRIPTION/NOTES/LIMITATIONS : */
8547 /*     --------------------------------- */
8548 /*     There are NBRVAL values in TABLEV which stands for NBRVAL-1 intervals. */
8549 /*     One searches the interval containing TPARAM by */
8550 /*     dichotomy. Complexity of the algorithm : Log(n)/Log(2).(RBD). */
8551 /* > */
8552 /* ***********************************************************************
8553  */
8554
8555
8556 /* Initialisations */
8557
8558     /* Parameter adjustments */
8559     --tablev;
8560
8561     /* Function Body */
8562     ibb = AdvApp2Var_SysBase::mnfndeb_();
8563     if (ibb >= 6) {
8564         AdvApp2Var_SysBase::mgenmsg_("MMSRRE2", 7L);
8565     }
8566
8567     *iercod = 0;
8568     *numint = 0;
8569     *itypen = 0;
8570     ideb = 1;
8571     ifin = *nbrval;
8572
8573 /* TABLEV should contain at least two values */
8574
8575     if (*nbrval < 2) {
8576         *iercod = 1;
8577         goto L9999;
8578     }
8579
8580 /* TPARAM should be between extreme limits of TABLEV. */
8581
8582     if (*tparam < tablev[1] || *tparam > tablev[*nbrval]) {
8583         *iercod = 2;
8584         goto L9999;
8585     }
8586
8587 /* ----------------------- SEARCH OF THE INTERVAL --------------------
8588 */
8589
8590 L1000:
8591
8592 /* Test end of loop (found). */
8593
8594     if (ideb + 1 == ifin) {
8595         *numint = ideb;
8596         goto L2000;
8597     }
8598
8599 /* Find by dichotomy on increasing values of TABLEV. */
8600
8601     imil = (ideb + ifin) / 2;
8602     if (*tparam >= tablev[ideb] && *tparam <= tablev[imil]) {
8603         ifin = imil;
8604     } else {
8605         ideb = imil;
8606     }
8607
8608     goto L1000;
8609
8610 /* -------------- TEST IF TPARAM IS NOT A VALUE --------- */
8611 /* ------------------------OF TABLEV UP TO EPSIL ----------------------
8612 */
8613
8614 L2000:
8615     if ((d__1 = *tparam - tablev[ideb], advapp_abs(d__1)) < *epsil) {
8616         *itypen = 1;
8617         goto L9999;
8618     }
8619     if ((d__1 = *tparam - tablev[ifin], advapp_abs(d__1)) < *epsil) {
8620         *itypen = 2;
8621         goto L9999;
8622     }
8623
8624 /* --------------------------- THE END ----------------------------------
8625 */
8626
8627 L9999:
8628     if (*iercod > 0) {
8629         AdvApp2Var_SysBase::maermsg_("MMSRRE2", iercod, 7L);
8630     }
8631     if (ibb >= 6) {
8632         AdvApp2Var_SysBase::mgsomsg_("MMSRRE2", 7L);
8633     }
8634  return 0 ;
8635 } /* mmsrre2_ */
8636
8637 //=======================================================================
8638 //function : mmtmave_
8639 //purpose  :
8640 //=======================================================================
8641 int mmtmave_(integer *nligne,
8642              integer *ncolon,
8643              integer *gposit,
8644              integer *,//gnstoc,
8645              doublereal *gmatri,
8646              doublereal *vecin,
8647              doublereal *vecout,
8648              integer *iercod)
8649
8650 {
8651   /* System generated locals */
8652   integer i__1, i__2;
8653
8654   /* Local variables */
8655   logical ldbg;
8656   integer imin, imax, i__, j, k;
8657   doublereal somme;
8658   integer aux;
8659
8660
8661 /* ***********************************************************************
8662  */
8663
8664 /*     FUNCTION : */
8665 /*     ---------- */
8666 /*                          t */
8667 /*      CREATES PRODUCT   G V */
8668 /*      WHERE THE MATRIX IS IN FORM OF PROFILE */
8669
8670 /*     KEYWORDS : */
8671 /*     ----------- */
8672 /*      RESERVE, PRODUCT, MATRIX, PROFILE, VECTOR */
8673
8674 /*     INPUT ARGUMENTS : */
8675 /*     -------------------- */
8676 /*       NLIGNE : NUMBER OF LINE OF THE MATRIX */
8677 /*       NCOLON : NOMBER OF COLUMN OF THE MATRIX */
8678 /*       GPOSIT: TABLE OF POSITIONING OF TERMS OF STORAGE */
8679 /*               GPOSIT(1,I) CONTAINS THE NUMBER of TERMS-1 ON LINE */
8680 /*               I IN THE PROFILE OF THE MATRIX */
8681 /*              GPOSIT(2,I) CONTAINS THE INDEX OF STORAGE OF THE DIAGONAL TERM*/
8682 /*               OF LINE I */
8683 /*               GPOSIT(3,I) CONTAINS THE INDEX COLUMN OF THE FIRST TERM OF */
8684 /*                           PROFILE OF LINE I */
8685 /*       GNSTOC : NOMBER OF TERM IN THE PROFILE OF GMATRI */
8686 /*       GMATRI : MATRIX OF CONSTRAINTS IN FORM OF PROFILE */
8687 /*       VECIN :  INPUT VECTOR */
8688
8689 /*     OUTPUT ARGUMENTS : */
8690 /*     --------------------- */
8691 /*       VECOUT : VECTOR PRODUCT */
8692 /*       IERCOD : ERROR CODE */
8693
8694
8695 /*     COMMONS USED : */
8696 /*     ------------------ */
8697
8698
8699 /*     REFERENCES CALLED : */
8700 /*     --------------------- */
8701
8702
8703 /*     DESCRIPTION/NOTES/LIMITATIONS : */
8704 /*     ----------------------------------- */
8705 /* > */
8706 /* ***********************************************************************
8707  */
8708 /*                            DECLARATIONS */
8709 /* ***********************************************************************
8710  */
8711
8712
8713
8714 /* ***********************************************************************
8715  */
8716 /*                      INITIALISATIONS */
8717 /* ***********************************************************************
8718  */
8719
8720     /* Parameter adjustments */
8721     --vecin;
8722     gposit -= 4;
8723     --vecout;
8724     --gmatri;
8725
8726     /* Function Body */
8727     ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 2;
8728     if (ldbg) {
8729         AdvApp2Var_SysBase::mgenmsg_("MMTMAVE", 7L);
8730     }
8731     *iercod = 0;
8732
8733 /* ***********************************************************************
8734  */
8735 /*                     PROCESSING */
8736 /* ***********************************************************************
8737  */
8738
8739
8740
8741     i__1 = *ncolon;
8742     for (i__ = 1; i__ <= i__1; ++i__) {
8743         somme = 0.;
8744         i__2 = *nligne;
8745         for (j = 1; j <= i__2; ++j) {
8746             imin = gposit[j * 3 + 3];
8747             imax = gposit[j * 3 + 1] + gposit[j * 3 + 3] - 1;
8748             aux = gposit[j * 3 + 2] - gposit[j * 3 + 1] - imin + 1;
8749             if (imin <= i__ && i__ <= imax) {
8750                 k = i__ + aux;
8751                 somme += gmatri[k] * vecin[j];
8752             }
8753         }
8754         vecout[i__] = somme;
8755     }
8756
8757
8758
8759
8760
8761     goto L9999;
8762
8763 /* ***********************************************************************
8764  */
8765 /*                   ERROR PROCESSING */
8766 /* ***********************************************************************
8767  */
8768
8769
8770 /* ***********************************************************************
8771  */
8772 /*                   RETURN CALLING PROGRAM */
8773 /* ***********************************************************************
8774  */
8775
8776 L9999:
8777
8778 /* ___ DESALLOCATION, ... */
8779
8780     AdvApp2Var_SysBase::maermsg_("MMTMAVE", iercod, 7L);
8781     if (ldbg) {
8782         AdvApp2Var_SysBase::mgsomsg_("MMTMAVE", 7L);
8783     }
8784  return 0 ;
8785 } /* mmtmave_ */
8786
8787 //=======================================================================
8788 //function : mmtrpj0_
8789 //purpose  :
8790 //=======================================================================
8791 int mmtrpj0_(integer *ncofmx,
8792              integer *ndimen,
8793              integer *ncoeff,
8794              doublereal *epsi3d,
8795              doublereal *crvlgd,
8796              doublereal *ycvmax,
8797              doublereal *epstrc,
8798              integer *ncfnew)
8799
8800 {
8801   /* System generated locals */
8802   integer crvlgd_dim1, crvlgd_offset, i__1, i__2;
8803   doublereal d__1;
8804
8805   /* Local variables */
8806   integer ncut, i__;
8807   doublereal bidon, error;
8808   integer nd;
8809
8810
8811 /* ***********************************************************************
8812  */
8813
8814 /*     FUNCTION : */
8815 /*     ---------- */
8816 /*        Lowers the degree of a curve defined on (-1,1) in the direction of */
8817 /*        Legendre with a given precision. */
8818
8819 /*     KEYWORDS : */
8820 /*     ----------- */
8821 /*        LEGENDRE, POLYGON, TRUNCATION, CURVE, SMOOTHING. */
8822
8823 /*     INPUT ARGUMENTS : */
8824 /*     ------------------ */
8825 /*        NCOFMX : Max Nb of coeff. of the curve (dimensioning). */
8826 /*        NDIMEN : Dimension of the space. */
8827 /*        NCOEFF : Degree +1 of the polynom. */
8828 /*        EPSI3D : Precision required for the approximation. */
8829 /*        CRVLGD : The curve the degree which of it is required to lower. */
8830
8831 /*     OUTPUT ARGUMENTS : */
8832 /*     ------------------- */
8833 /*        EPSTRC : Precision of the approximation. */
8834 /*        NCFNEW : Degree +1 of the resulting polynom. */
8835
8836 /*     COMMONS USED   : */
8837 /*     ---------------- */
8838
8839 /*     REFERENCES CALLED   : */
8840 /*     ----------------------- */
8841
8842 /*     DESCRIPTION/NOTES/LIMITATIONS : */
8843 /*     ----------------------------------- */
8844 /* > */
8845 /* ***********************************************************************
8846  */
8847
8848
8849 /* ------- Minimum degree that can be attained : Stop at 1 (RBD) ---------
8850 */
8851
8852     /* Parameter adjustments */
8853     --ycvmax;
8854     crvlgd_dim1 = *ncofmx;
8855     crvlgd_offset = crvlgd_dim1 + 1;
8856     crvlgd -= crvlgd_offset;
8857
8858     /* Function Body */
8859     *ncfnew = 1;
8860 /* ------------------- Init for error calculation -----------------------
8861 */
8862     i__1 = *ndimen;
8863     for (i__ = 1; i__ <= i__1; ++i__) {
8864         ycvmax[i__] = 0.;
8865 /* L100: */
8866     }
8867     *epstrc = 0.;
8868     error = 0.;
8869
8870 /*   Cutting of coefficients. */
8871
8872     ncut = 2;
8873 /* ------ Loop on the series of Legendre :NCOEFF --> 2 (RBD) -----------
8874 */
8875     i__1 = ncut;
8876     for (i__ = *ncoeff; i__ >= i__1; --i__) {
8877 /*   Factor of renormalization. */
8878         bidon = ((i__ - 1) * 2. + 1.) / 2.;
8879         bidon = sqrt(bidon);
8880         i__2 = *ndimen;
8881         for (nd = 1; nd <= i__2; ++nd) {
8882             ycvmax[nd] += (d__1 = crvlgd[i__ + nd * crvlgd_dim1], advapp_abs(d__1)) *
8883                      bidon;
8884 /* L310: */
8885         }
8886 /*   Cutting is stopped if the norm becomes too great. */
8887         error = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
8888         if (error > *epsi3d) {
8889             *ncfnew = i__;
8890             goto L9999;
8891         }
8892
8893 /* ---  Max error cumulee when the I-th coeff is removed. */
8894
8895         *epstrc = error;
8896
8897 /* L300: */
8898     }
8899
8900 /* --------------------------------- End --------------------------------
8901 */
8902
8903 L9999:
8904     return 0;
8905 } /* mmtrpj0_ */
8906
8907 //=======================================================================
8908 //function : mmtrpj2_
8909 //purpose  :
8910 //=======================================================================
8911 int mmtrpj2_(integer *ncofmx,
8912              integer *ndimen,
8913              integer *ncoeff,
8914              doublereal *epsi3d,
8915              doublereal *crvlgd,
8916              doublereal *ycvmax,
8917              doublereal *epstrc,
8918              integer *ncfnew)
8919
8920 {
8921     /* Initialized data */
8922
8923     static doublereal xmaxj[57] = { .9682458365518542212948163499456,
8924             .986013297183269340427888048593603,
8925             1.07810420343739860362585159028115,
8926             1.17325804490920057010925920756025,
8927             1.26476561266905634732910520370741,
8928             1.35169950227289626684434056681946,
8929             1.43424378958284137759129885012494,
8930             1.51281316274895465689402798226634,
8931             1.5878364329591908800533936587012,
8932             1.65970112228228167018443636171226,
8933             1.72874345388622461848433443013543,
8934             1.7952515611463877544077632304216,
8935             1.85947199025328260370244491818047,
8936             1.92161634324190018916351663207101,
8937             1.98186713586472025397859895825157,
8938             2.04038269834980146276967984252188,
8939             2.09730119173852573441223706382076,
8940             2.15274387655763462685970799663412,
8941             2.20681777186342079455059961912859,
8942             2.25961782459354604684402726624239,
8943             2.31122868752403808176824020121524,
8944             2.36172618435386566570998793688131,
8945             2.41117852396114589446497298177554,
8946             2.45964731268663657873849811095449,
8947             2.50718840313973523778244737914028,
8948             2.55385260994795361951813645784034,
8949             2.59968631659221867834697883938297,
8950             2.64473199258285846332860663371298,
8951             2.68902863641518586789566216064557,
8952             2.73261215675199397407027673053895,
8953             2.77551570192374483822124304745691,
8954             2.8177699459714315371037628127545,
8955             2.85940333797200948896046563785957,
8956             2.90044232019793636101516293333324,
8957             2.94091151970640874812265419871976,
8958             2.98083391718088702956696303389061,
8959             3.02023099621926980436221568258656,
8960             3.05912287574998661724731962377847,
8961             3.09752842783622025614245706196447,
8962             3.13546538278134559341444834866301,
8963             3.17295042316122606504398054547289,
8964             3.2099992681699613513775259670214,
8965             3.24662674946606137764916854570219,
8966             3.28284687953866689817670991319787,
8967             3.31867291347259485044591136879087,
8968             3.35411740487202127264475726990106,
8969             3.38919225660177218727305224515862,
8970             3.42390876691942143189170489271753,
8971             3.45827767149820230182596660024454,
8972             3.49230918177808483937957161007792,
8973             3.5260130200285724149540352829756,
8974             3.55939845146044235497103883695448,
8975             3.59247431368364585025958062194665,
8976             3.62524904377393592090180712976368,
8977             3.65773070318071087226169680450936,
8978             3.68992700068237648299565823810245,
8979             3.72184531357268220291630708234186 };
8980
8981     /* System generated locals */
8982     integer crvlgd_dim1, crvlgd_offset, i__1, i__2;
8983     doublereal d__1;
8984
8985     /* Local variables */
8986     integer ncut, i__;
8987     doublereal bidon, error;
8988     integer ia, nd;
8989     doublereal bid, eps1;
8990
8991
8992 /* ***********************************************************************
8993  */
8994
8995 /*     FUNCTION : */
8996 /*     ---------- */
8997 /*        Lower the degree of a curve defined on (-1,1) in the direction of */
8998 /*        Legendre with a given precision. */
8999
9000 /*     KEYWORDS : */
9001 /*     ----------- */
9002 /*        LEGENDRE, POLYGON, TRUNCATION, CURVE, SMOOTHING. */
9003
9004 /*     INPUT ARGUMENTS : */
9005 /*     ------------------ */
9006 /*        NCOFMX : Max nb of coeff. of the curve (dimensioning). */
9007 /*        NDIMEN : Dimension of the space. */
9008 /*        NCOEFF : Degree +1 of the polynom. */
9009 /*        EPSI3D : Precision required for the approximation. */
9010 /*        CRVLGD : The curve the degree which of will be lowered. */
9011
9012 /*     OUTPUT ARGUMENTS : */
9013 /*     ------------------- */
9014 /*        YCVMAX : Auxiliary table (error max on each dimension).
9015 */
9016 /*        EPSTRC : Precision of the approximation. */
9017 /*        NCFNEW : Degree +1 of the resulting polynom. */
9018
9019 /*     COMMONS USED   : */
9020 /*     ---------------- */
9021
9022 /*     REFERENCES CALLED   : */
9023 /*     ----------------------- */
9024
9025 /*     DESCRIPTION/NOTES/LIMITATIONS : */
9026 /*     ----------------------------------- */
9027 /* > */
9028 /* ***********************************************************************
9029  */
9030
9031
9032     /* Parameter adjustments */
9033     --ycvmax;
9034     crvlgd_dim1 = *ncofmx;
9035     crvlgd_offset = crvlgd_dim1 + 1;
9036     crvlgd -= crvlgd_offset;
9037
9038     /* Function Body */
9039
9040
9041
9042 /*   Minimum degree that can be reached : Stop at IA (RBD). -------------
9043 */
9044     ia = 2;
9045     *ncfnew = ia;
9046 /* Init for calculation of error. */
9047     i__1 = *ndimen;
9048     for (i__ = 1; i__ <= i__1; ++i__) {
9049         ycvmax[i__] = 0.;
9050 /* L100: */
9051     }
9052     *epstrc = 0.;
9053     error = 0.;
9054
9055 /*   Cutting of coefficients. */
9056
9057     ncut = ia + 1;
9058 /* ------ Loop on the series of Jacobi :NCOEFF --> IA+1 (RBD) ----------
9059 */
9060     i__1 = ncut;
9061     for (i__ = *ncoeff; i__ >= i__1; --i__) {
9062 /*   Factor of renormalization. */
9063         bidon = xmaxj[i__ - ncut];
9064         i__2 = *ndimen;
9065         for (nd = 1; nd <= i__2; ++nd) {
9066             ycvmax[nd] += (d__1 = crvlgd[i__ + nd * crvlgd_dim1], advapp_abs(d__1)) *
9067                      bidon;
9068 /* L310: */
9069         }
9070 /*   One stops to cut if the norm becomes too great. */
9071         error = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
9072         if (error > *epsi3d) {
9073             *ncfnew = i__;
9074             goto L400;
9075         }
9076
9077 /* --- Max error cumulated when the I-th coeff is removed. */
9078
9079         *epstrc = error;
9080
9081 /* L300: */
9082     }
9083
9084 /* ------- Cutting of zero coeffs of interpolation (RBD) -------
9085 */
9086
9087 L400:
9088     if (*ncfnew == ia) {
9089         AdvApp2Var_MathBase::mmeps1_(&eps1);
9090         for (i__ = ia; i__ >= 2; --i__) {
9091             bid = 0.;
9092             i__1 = *ndimen;
9093             for (nd = 1; nd <= i__1; ++nd) {
9094                 bid += (d__1 = crvlgd[i__ + nd * crvlgd_dim1], advapp_abs(d__1));
9095 /* L600: */
9096             }
9097             if (bid > eps1) {
9098                 *ncfnew = i__;
9099                 goto L9999;
9100             }
9101 /* L500: */
9102         }
9103 /* --- If all coeffs can be removed, this is a point. */
9104         *ncfnew = 1;
9105     }
9106
9107 /* --------------------------------- End --------------------------------
9108 */
9109
9110 L9999:
9111     return 0;
9112 } /* mmtrpj2_ */
9113
9114 //=======================================================================
9115 //function : mmtrpj4_
9116 //purpose  :
9117 //=======================================================================
9118 int mmtrpj4_(integer *ncofmx,
9119              integer *ndimen,
9120              integer *ncoeff,
9121              doublereal *epsi3d,
9122              doublereal *crvlgd,
9123              doublereal *ycvmax,
9124              doublereal *epstrc,
9125              integer *ncfnew)
9126 {
9127     /* Initialized data */
9128
9129     static doublereal xmaxj[55] = { 1.1092649593311780079813740546678,
9130             1.05299572648705464724876659688996,
9131             1.0949715351434178709281698645813,
9132             1.15078388379719068145021100764647,
9133             1.2094863084718701596278219811869,
9134             1.26806623151369531323304177532868,
9135             1.32549784426476978866302826176202,
9136             1.38142537365039019558329304432581,
9137             1.43575531950773585146867625840552,
9138             1.48850442653629641402403231015299,
9139             1.53973611681876234549146350844736,
9140             1.58953193485272191557448229046492,
9141             1.63797820416306624705258190017418,
9142             1.68515974143594899185621942934906,
9143             1.73115699602477936547107755854868,
9144             1.77604489805513552087086912113251,
9145             1.81989256661534438347398400420601,
9146             1.86276344480103110090865609776681,
9147             1.90471563564740808542244678597105,
9148             1.94580231994751044968731427898046,
9149             1.98607219357764450634552790950067,
9150             2.02556989246317857340333585562678,
9151             2.06433638992049685189059517340452,
9152             2.10240936014742726236706004607473,
9153             2.13982350649113222745523925190532,
9154             2.17661085564771614285379929798896,
9155             2.21280102016879766322589373557048,
9156             2.2484214321456956597803794333791,
9157             2.28349755104077956674135810027654,
9158             2.31805304852593774867640120860446,
9159             2.35210997297725685169643559615022,
9160             2.38568889602346315560143377261814,
9161             2.41880904328694215730192284109322,
9162             2.45148841120796359750021227795539,
9163             2.48374387161372199992570528025315,
9164             2.5155912654873773953959098501893,
9165             2.54704548720896557684101746505398,
9166             2.57812056037881628390134077704127,
9167             2.60882970619319538196517982945269,
9168             2.63918540521920497868347679257107,
9169             2.66919945330942891495458446613851,
9170             2.69888301230439621709803756505788,
9171             2.72824665609081486737132853370048,
9172             2.75730041251405791603760003778285,
9173             2.78605380158311346185098508516203,
9174             2.81451587035387403267676338931454,
9175             2.84269522483114290814009184272637,
9176             2.87060005919012917988363332454033,
9177             2.89823818258367657739520912946934,
9178             2.92561704377132528239806135133273,
9179             2.95274375377994262301217318010209,
9180             2.97962510678256471794289060402033,
9181             3.00626759936182712291041810228171,
9182             3.03267744830655121818899164295959,
9183             3.05886060707437081434964933864149 };
9184
9185     /* System generated locals */
9186     integer crvlgd_dim1, crvlgd_offset, i__1, i__2;
9187     doublereal d__1;
9188
9189     /* Local variables */
9190     integer ncut, i__;
9191     doublereal bidon, error;
9192     integer ia, nd;
9193     doublereal bid, eps1;
9194
9195
9196
9197 /* ***********************************************************************
9198  */
9199
9200 /*     FUNCTION : */
9201 /*     ---------- */
9202 /*        Lowers the degree of a curve defined on (-1,1) in the direction of */
9203 /*        Legendre with a given precision. */
9204
9205 /*     KEYWORDS : */
9206 /*     ----------- */
9207 /*        LEGENDRE, POLYGON, TRONCATION, CURVE, SMOOTHING. */
9208
9209 /*     INPUT ARGUMENTS : */
9210 /*     ------------------ */
9211 /*        NCOFMX : Max nb of coeff. of the curve (dimensioning). */
9212 /*        NDIMEN : Dimension of the space. */
9213 /*        NCOEFF : Degree +1 of the polynom. */
9214 /*        EPSI3D : Precision required for the approximation. */
9215 /*        CRVLGD : The curve which wishes to lower the degree. */
9216
9217 /*     OUTPUT ARGUMENTS : */
9218 /*     ------------------- */
9219 /*        YCVMAX : Auxiliary table (max error on each dimension).
9220 */
9221 /*        EPSTRC : Precision of the approximation. */
9222 /*        NCFNEW : Degree +1 of the resulting polynom. */
9223
9224 /*     COMMONS USED   : */
9225 /*     ---------------- */
9226
9227 /*     REFERENCES CALLED   : */
9228 /*     ----------------------- */
9229
9230 /*     DESCRIPTION/NOTES/LIMITATIONS : */
9231 /*     ----------------------------------- */
9232 /* > */
9233 /* ***********************************************************************
9234  */
9235
9236
9237     /* Parameter adjustments */
9238     --ycvmax;
9239     crvlgd_dim1 = *ncofmx;
9240     crvlgd_offset = crvlgd_dim1 + 1;
9241     crvlgd -= crvlgd_offset;
9242
9243     /* Function Body */
9244
9245
9246
9247 /*   Minimum degree that can be reached : Stop at IA (RBD). -------------
9248 */
9249     ia = 4;
9250     *ncfnew = ia;
9251 /* Init for error calculation. */
9252     i__1 = *ndimen;
9253     for (i__ = 1; i__ <= i__1; ++i__) {
9254         ycvmax[i__] = 0.;
9255 /* L100: */
9256     }
9257     *epstrc = 0.;
9258     error = 0.;
9259
9260 /*   Cutting of coefficients. */
9261
9262     ncut = ia + 1;
9263 /* ------ Loop on the series of Jacobi :NCOEFF --> IA+1 (RBD) ----------
9264 */
9265     i__1 = ncut;
9266     for (i__ = *ncoeff; i__ >= i__1; --i__) {
9267 /*   Factor of renormalization. */
9268         bidon = xmaxj[i__ - ncut];
9269         i__2 = *ndimen;
9270         for (nd = 1; nd <= i__2; ++nd) {
9271             ycvmax[nd] += (d__1 = crvlgd[i__ + nd * crvlgd_dim1], advapp_abs(d__1)) *
9272                      bidon;
9273 /* L310: */
9274         }
9275 /*   Stop cutting if the norm becomes too great. */
9276         error = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
9277         if (error > *epsi3d) {
9278             *ncfnew = i__;
9279             goto L400;
9280         }
9281
9282 /* -- Error max cumulated when the I-eme coeff is removed. */
9283
9284         *epstrc = error;
9285
9286 /* L300: */
9287     }
9288
9289 /* ------- Cutting of zero coeffs of the pole of interpolation (RBD) -------
9290 */
9291
9292 L400:
9293     if (*ncfnew == ia) {
9294         AdvApp2Var_MathBase::mmeps1_(&eps1);
9295         for (i__ = ia; i__ >= 2; --i__) {
9296             bid = 0.;
9297             i__1 = *ndimen;
9298             for (nd = 1; nd <= i__1; ++nd) {
9299                 bid += (d__1 = crvlgd[i__ + nd * crvlgd_dim1], advapp_abs(d__1));
9300 /* L600: */
9301             }
9302             if (bid > eps1) {
9303                 *ncfnew = i__;
9304                 goto L9999;
9305             }
9306 /* L500: */
9307         }
9308 /* --- If all coeffs can be removed, this is a point. */
9309         *ncfnew = 1;
9310     }
9311
9312 /* --------------------------------- End --------------------------------
9313 */
9314
9315 L9999:
9316     return 0;
9317 } /* mmtrpj4_ */
9318
9319 //=======================================================================
9320 //function : mmtrpj6_
9321 //purpose  :
9322 //=======================================================================
9323 int mmtrpj6_(integer *ncofmx,
9324              integer *ndimen,
9325              integer *ncoeff,
9326              doublereal *epsi3d,
9327              doublereal *crvlgd,
9328              doublereal *ycvmax,
9329              doublereal *epstrc,
9330              integer *ncfnew)
9331
9332 {
9333     /* Initialized data */
9334
9335     static doublereal xmaxj[53] = { 1.21091229812484768570102219548814,
9336             1.11626917091567929907256116528817,
9337             1.1327140810290884106278510474203,
9338             1.1679452722668028753522098022171,
9339             1.20910611986279066645602153641334,
9340             1.25228283758701572089625983127043,
9341             1.29591971597287895911380446311508,
9342             1.3393138157481884258308028584917,
9343             1.3821288728999671920677617491385,
9344             1.42420414683357356104823573391816,
9345             1.46546895108549501306970087318319,
9346             1.50590085198398789708599726315869,
9347             1.54550385142820987194251585145013,
9348             1.58429644271680300005206185490937,
9349             1.62230484071440103826322971668038,
9350             1.65955905239130512405565733793667,
9351             1.69609056468292429853775667485212,
9352             1.73193098017228915881592458573809,
9353             1.7671112206990325429863426635397,
9354             1.80166107681586964987277458875667,
9355             1.83560897003644959204940535551721,
9356             1.86898184653271388435058371983316,
9357             1.90180515174518670797686768515502,
9358             1.93410285411785808749237200054739,
9359             1.96589749778987993293150856865539,
9360             1.99721027139062501070081653790635,
9361             2.02806108474738744005306947877164,
9362             2.05846864831762572089033752595401,
9363             2.08845055210580131460156962214748,
9364             2.11802334209486194329576724042253,
9365             2.14720259305166593214642386780469,
9366             2.17600297710595096918495785742803,
9367             2.20443832785205516555772788192013,
9368             2.2325216999457379530416998244706,
9369             2.2602654243075083168599953074345,
9370             2.28768115912702794202525264301585,
9371             2.3147799369092684021274946755348,
9372             2.34157220782483457076721300512406,
9373             2.36806787963276257263034969490066,
9374             2.39427635443992520016789041085844,
9375             2.42020656255081863955040620243062,
9376             2.44586699364757383088888037359254,
9377             2.47126572552427660024678584642791,
9378             2.49641045058324178349347438430311,
9379             2.52130850028451113942299097584818,
9380             2.54596686772399937214920135190177,
9381             2.5703922285006754089328998222275,
9382             2.59459096001908861492582631591134,
9383             2.61856915936049852435394597597773,
9384             2.64233265984385295286445444361827,
9385             2.66588704638685848486056711408168,
9386             2.68923766976735295746679957665724,
9387             2.71238965987606292679677228666411 };
9388
9389     /* System generated locals */
9390     integer crvlgd_dim1, crvlgd_offset, i__1, i__2;
9391     doublereal d__1;
9392
9393     /* Local variables */
9394     integer ncut, i__;
9395     doublereal bidon, error;
9396     integer ia, nd;
9397     doublereal bid, eps1;
9398
9399
9400
9401 /* ***********************************************************************
9402  */
9403
9404 /*     FUNCTION : */
9405 /*     ---------- */
9406 /*        Lowers the degree of a curve defined on (-1,1) in the direction of */
9407 /*        Legendre to a given precision. */
9408
9409 /*     KEYWORDS : */
9410 /*     ----------- */
9411 /*        LEGENDRE,POLYGON,TRUNCATION,CURVE,SMOOTHING. */
9412
9413 /*     INPUT ARGUMENTS : */
9414 /*     ------------------ */
9415 /*        NCOFMX : Max nb of coeff. of the curve (dimensioning). */
9416 /*        NDIMEN : Dimension of the space. */
9417 /*        NCOEFF : Degree +1 of the polynom. */
9418 /*        EPSI3D : Precision required for the approximation. */
9419 /*        CRVLGD : The curve the degree which of will be lowered. */
9420
9421 /*     OUTPUT ARGUMENTS : */
9422 /*     ------------------- */
9423 /*        YCVMAX : Auxiliary table (max error on each dimension). */
9424 /*        EPSTRC : Precision of the approximation. */
9425 /*        NCFNEW : Degree +1 of the resulting polynom. */
9426
9427 /*     COMMONS USED   : */
9428 /*     ---------------- */
9429
9430 /*     REFERENCES CALLED   : */
9431 /*     ----------------------- */
9432
9433 /*     DESCRIPTION/NOTES/LIMITATIONS : */
9434 /*     ----------------------------------- */
9435 /* > */
9436 /* ***********************************************************************
9437  */
9438
9439
9440     /* Parameter adjustments */
9441     --ycvmax;
9442     crvlgd_dim1 = *ncofmx;
9443     crvlgd_offset = crvlgd_dim1 + 1;
9444     crvlgd -= crvlgd_offset;
9445
9446     /* Function Body */
9447
9448
9449
9450 /*   Minimum degree that can be reached : Stop at IA (RBD). -------------
9451 */
9452     ia = 6;
9453     *ncfnew = ia;
9454 /* Init for error calculation. */
9455     i__1 = *ndimen;
9456     for (i__ = 1; i__ <= i__1; ++i__) {
9457         ycvmax[i__] = 0.;
9458 /* L100: */
9459     }
9460     *epstrc = 0.;
9461     error = 0.;
9462
9463 /*   Cutting of coefficients. */
9464
9465     ncut = ia + 1;
9466 /* ------ Loop on the series of Jacobi :NCOEFF --> IA+1 (RBD) ----------
9467 */
9468     i__1 = ncut;
9469     for (i__ = *ncoeff; i__ >= i__1; --i__) {
9470 /*   Factor of renormalization. */
9471         bidon = xmaxj[i__ - ncut];
9472         i__2 = *ndimen;
9473         for (nd = 1; nd <= i__2; ++nd) {
9474             ycvmax[nd] += (d__1 = crvlgd[i__ + nd * crvlgd_dim1], advapp_abs(d__1)) *
9475                      bidon;
9476 /* L310: */
9477         }
9478 /*   Stop cutting if the norm becomes too great. */
9479         error = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
9480         if (error > *epsi3d) {
9481             *ncfnew = i__;
9482             goto L400;
9483         }
9484
9485 /* --- Max error cumulated when the I-th coeff is removed. */
9486
9487         *epstrc = error;
9488
9489 /* L300: */
9490     }
9491
9492 /* ------- Cutting of zero coeff. of the pole of interpolation (RBD) -------
9493 */
9494
9495 L400:
9496     if (*ncfnew == ia) {
9497         AdvApp2Var_MathBase::mmeps1_(&eps1);
9498         for (i__ = ia; i__ >= 2; --i__) {
9499             bid = 0.;
9500             i__1 = *ndimen;
9501             for (nd = 1; nd <= i__1; ++nd) {
9502                 bid += (d__1 = crvlgd[i__ + nd * crvlgd_dim1], advapp_abs(d__1));
9503 /* L600: */
9504             }
9505             if (bid > eps1) {
9506                 *ncfnew = i__;
9507                 goto L9999;
9508             }
9509 /* L500: */
9510         }
9511 /* --- If all coeffs can be removed, this is a point. */
9512         *ncfnew = 1;
9513     }
9514
9515 /* --------------------------------- End --------------------------------
9516 */
9517
9518 L9999:
9519     return 0;
9520 } /* mmtrpj6_ */
9521
9522 //=======================================================================
9523 //function : AdvApp2Var_MathBase::mmtrpjj_
9524 //purpose  :
9525 //=======================================================================
9526  int AdvApp2Var_MathBase::mmtrpjj_(integer *ncofmx,
9527                             integer *ndimen,
9528                             integer *ncoeff,
9529                             doublereal *epsi3d,
9530                             integer *iordre,
9531                             doublereal *crvlgd,
9532                             doublereal *ycvmax,
9533                             doublereal *errmax,
9534                             integer *ncfnew)
9535 {
9536     /* System generated locals */
9537     integer crvlgd_dim1, crvlgd_offset;
9538
9539     /* Local variables */
9540     integer ia;
9541
9542
9543 /* ***********************************************************************
9544  */
9545
9546 /*     FUNCTION : */
9547 /*     ---------- */
9548 /*        Lower the degree of a curve defined on (-1,1) in the direction of */
9549 /*        Legendre with a given precision. */
9550
9551 /*     KEYWORDS : */
9552 /*     ----------- */
9553 /*        LEGENDRE, POLYGON, TRUNCATION, CURVE, SMOOTHING. */
9554
9555 /*     INPUT ARGUMENTS : */
9556 /*     ------------------ */
9557 /*        NCOFMX : Max Nb coeff. of the curve (dimensioning). */
9558 /*        NDIMEN : Dimension of the space. */
9559 /*        NCOEFF : Degree +1 of the polynom. */
9560 /*        EPSI3D : Precision required for the approximation. */
9561 /*        IORDRE : Order of continuity at the extremities. */
9562 /*        CRVLGD : The curve the degree which of should be lowered. */
9563
9564 /*     OUTPUT ARGUMENTS : */
9565 /*     ------------------- */
9566 /*        ERRMAX : Precision of the approximation. */
9567 /*        NCFNEW : Degree +1 of the resulting polynom. */
9568
9569 /*     COMMONS USED   : */
9570 /*     ---------------- */
9571
9572 /*     REFERENCES CALLED : */
9573 /*     ----------------------- */
9574
9575 /*     DESCRIPTION/NOTES/LIMITATIONS : */
9576 /*     ----------------------------------- */
9577 /* > */
9578 /* ***********************************************************************
9579  */
9580
9581
9582     /* Parameter adjustments */
9583     --ycvmax;
9584     crvlgd_dim1 = *ncofmx;
9585     crvlgd_offset = crvlgd_dim1 + 1;
9586     crvlgd -= crvlgd_offset;
9587
9588     /* Function Body */
9589     ia = (*iordre + 1) << 1;
9590
9591     if (ia == 0) {
9592         mmtrpj0_(ncofmx, ndimen, ncoeff, epsi3d, &crvlgd[crvlgd_offset], &
9593                 ycvmax[1], errmax, ncfnew);
9594     } else if (ia == 2) {
9595         mmtrpj2_(ncofmx, ndimen, ncoeff, epsi3d, &crvlgd[crvlgd_offset], &
9596                 ycvmax[1], errmax, ncfnew);
9597     } else if (ia == 4) {
9598         mmtrpj4_(ncofmx, ndimen, ncoeff, epsi3d, &crvlgd[crvlgd_offset], &
9599                 ycvmax[1], errmax, ncfnew);
9600     } else {
9601         mmtrpj6_(ncofmx, ndimen, ncoeff, epsi3d, &crvlgd[crvlgd_offset], &
9602                 ycvmax[1], errmax, ncfnew);
9603     }
9604
9605 /* ------------------------ End -----------------------------------------
9606 */
9607
9608     return 0;
9609 } /* mmtrpjj_ */
9610
9611 //=======================================================================
9612 //function : AdvApp2Var_MathBase::mmunivt_
9613 //purpose  :
9614 //=======================================================================
9615  int AdvApp2Var_MathBase::mmunivt_(integer *ndimen,
9616              doublereal *vector,
9617              doublereal *vecnrm,
9618              doublereal *epsiln,
9619              integer *iercod)
9620 {
9621
9622   doublereal c_b2 = 10.;
9623
9624     /* System generated locals */
9625     integer i__1;
9626     doublereal d__1;
9627
9628     /* Local variables */
9629     integer nchif, iunit = 1, izero;
9630     doublereal vnorm;
9631     integer ii;
9632     doublereal bid;
9633     doublereal eps0;
9634
9635
9636
9637
9638 /* ***********************************************************************
9639  */
9640
9641 /*     FUNCTION : */
9642 /*     ---------- */
9643 /*        CALCULATE THE NORMAL VECTOR BASING ON ANY VECTOR */
9644 /*        WITH PRECISION GIVEN BY THE USER. */
9645
9646 /*     KEYWORDS : */
9647 /*     ----------- */
9648 /*        ALL, MATH_ACCES :: */
9649 /*        VECTEUR&, NORMALISATION, &VECTEUR */
9650
9651 /*     INPUT ARGUMENTS : */
9652 /*     ------------------ */
9653 /*        NDIMEN   : DIMENSION OF THE SPACE */
9654 /*        VECTOR   : VECTOR TO BE NORMED */
9655 /*        EPSILN   : EPSILON BELOW WHICH IT IS CONSIDERED THAT THE */
9656 /*                 NORM OF THE VECTOR IS NULL. IF EPSILN<=0, A DEFAULT VALUE */
9657 /*                 IS IMPOSED (10.D-17 ON VAX). */
9658
9659 /*     OUTPUT ARGUMENTS : */
9660 /*     ------------------- */
9661 /*        VECNRM : NORMED VECTOR */
9662 /*        IERCOD  101 : THE VECTOR IS NULL UP TO EPSILN. */
9663 /*                  0 : OK. */
9664
9665 /*     COMMONS USED   : */
9666 /*     ---------------- */
9667
9668 /*     REFERENCES CALLED   : */
9669 /*     ----------------------- */
9670
9671 /*     DESCRIPTION/NOTES/LIMITATIONS : */
9672 /*     ----------------------------------- */
9673 /*     VECTOR and VECNRM can be identic. */
9674
9675 /*     The norm of vector is calculated and each component is divided by */
9676 /*     this norm. After this it is checked if all componentes of the */
9677 /*     vector except for one cost 0 with machine precision. In */
9678 /*     this case the quasi-null components are set to 0.D0. */
9679 /* > */
9680 /* ***********************************************************************
9681  */
9682
9683
9684     /* Parameter adjustments */
9685     --vecnrm;
9686     --vector;
9687
9688     /* Function Body */
9689     *iercod = 0;
9690
9691 /* -------- Precision by default : zero machine 10.D-17 on Vax ------
9692 */
9693
9694     AdvApp2Var_SysBase::maovsr8_(&nchif);
9695     if (*epsiln <= 0.) {
9696         i__1 = -nchif;
9697         eps0 = AdvApp2Var_MathBase::pow__di(&c_b2, &i__1);
9698     } else {
9699         eps0 = *epsiln;
9700     }
9701
9702 /* ------------------------- Calculation of the norm --------------------
9703 */
9704
9705     vnorm = AdvApp2Var_MathBase::mzsnorm_(ndimen, &vector[1]);
9706     if (vnorm <= eps0) {
9707         AdvApp2Var_SysBase::mvriraz_(ndimen, &vecnrm[1]);
9708         *iercod = 101;
9709         goto L9999;
9710     }
9711
9712 /* ---------------------- Calculation of the vector norm  ---------------
9713 */
9714
9715     izero = 0;
9716     i__1 = (-nchif - 1) / 2;
9717     eps0 = AdvApp2Var_MathBase::pow__di(&c_b2, &i__1);
9718     i__1 = *ndimen;
9719     for (ii = 1; ii <= i__1; ++ii) {
9720         vecnrm[ii] = vector[ii] / vnorm;
9721         if ((d__1 = vecnrm[ii], advapp_abs(d__1)) <= eps0) {
9722             ++izero;
9723         } else {
9724             iunit = ii;
9725         }
9726 /* L20: */
9727     }
9728
9729 /* ------ Case when all coordinates except for one are almost null ----
9730 */
9731 /* ------------- then one of coordinates costs 1.D0 or -1.D0 --------
9732 */
9733
9734     if (izero == *ndimen - 1) {
9735         bid = vecnrm[iunit];
9736         i__1 = *ndimen;
9737         for (ii = 1; ii <= i__1; ++ii) {
9738             vecnrm[ii] = 0.;
9739 /* L30: */
9740         }
9741         if (bid > 0.) {
9742             vecnrm[iunit] = 1.;
9743         } else {
9744             vecnrm[iunit] = -1.;
9745         }
9746     }
9747
9748 /* -------------------------------- The end -----------------------------
9749 */
9750
9751 L9999:
9752     return 0;
9753 } /* mmunivt_ */
9754
9755 //=======================================================================
9756 //function : AdvApp2Var_MathBase::mmveps3_
9757 //purpose  :
9758 //=======================================================================
9759  int AdvApp2Var_MathBase::mmveps3_(doublereal *eps03)
9760 {
9761   /* Initialized data */
9762
9763   static char nomprg[8+1] = "MMEPS1  ";
9764
9765   integer ibb;
9766
9767
9768
9769 /************************************************************************
9770 *******/
9771
9772 /*     FUNCTION : */
9773 /*     ---------- */
9774 /*        Extraction of EPS1 from COMMON MPRCSN. */
9775
9776 /*     KEYWORDS : */
9777 /*     ----------- */
9778 /*        MPRCSN,PRECISON,EPS3. */
9779
9780 /*     INPUT ARGUMENTS : */
9781 /*     ------------------ */
9782 /*       Humm. */
9783
9784 /*     OUTPUT ARGUMENTS : */
9785 /*     ------------------- */
9786 /*        EPS3 :  space zero of the denominator (10**-9) */
9787 /*        EPS3 should value 10**-15 */
9788
9789 /*     COMMONS USED   : */
9790 /*     ---------------- */
9791
9792 /*     REFERENCES CALLED   : */
9793 /*     ----------------------- */
9794
9795 /*     DESCRIPTION/NOTES/LIMITATIONS : */
9796 /*     ----------------------------------- */
9797
9798 /* > */
9799 /* ***********************************************************************
9800  */
9801
9802
9803
9804 /* ***********************************************************************
9805  */
9806
9807 /*     FUNCTION : */
9808 /*     ---------- */
9809 /*          GIVES TOLERANCES OF NULLITY IN STRIM */
9810 /*          AND LIMITS OF ITERATIVE PROCESSES */
9811
9812 /*          GENERAL CONTEXT, MODIFIABLE BY THE UTILISER */
9813
9814 /*     KEYWORDS : */
9815 /*     ----------- */
9816 /*          PARAMETER , TOLERANCE */
9817
9818 /*     DESCRIPTION/NOTES/LIMITATIONS : */
9819 /*     ----------------------------------- */
9820 /*       INITIALISATION   :  PROFILE , **VIA MPRFTX** AT INPUT IN STRIM*/
9821 /*       LOADING OF DEFAULT VALUES OF THE PROFILE IN MPRFTX AT INPUT*/
9822 /*       IN STRIM. THEY ARE PRESERVED IN THE LOCAL VARIABLES OF MPRFTX */
9823
9824 /*        RESET DEFAULT VALUES                   : MDFINT */
9825 /*        MODIFICATION INTERACTIVE BY THE USER   : MDBINT */
9826
9827 /*        ACCESS FUNCTION  :  MMEPS1  ...  EPS1 */
9828 /*                            MEPSPB  ...  EPS3,EPS4 */
9829 /*                            MEPSLN  ...  EPS2, NITERM , NITERR */
9830 /*                            MEPSNR  ...  EPS2 , NITERM */
9831 /*                            MITERR  ...  NITERR */
9832
9833 /* > */
9834 /* ***********************************************************************
9835  */
9836
9837 /*     NITERM : MAX NB OF ITERATIONS */
9838 /*     NITERR : NB OF RAPID ITERATIONS */
9839 /*     EPS1   : TOLERANCE OF 3D NULL DISTANCE */
9840 /*     EPS2   : TOLERANCE OF ZERO PARAMETRIC DISTANCE */
9841 /*     EPS3   : TOLERANCE TO AVOID DIVISION BY 0.. */
9842 /*     EPS4   : TOLERANCE ANGULAR */
9843
9844
9845
9846 /* ***********************************************************************
9847  */
9848
9849     ibb = AdvApp2Var_SysBase::mnfndeb_();
9850     if (ibb >= 5) {
9851         AdvApp2Var_SysBase::mgenmsg_(nomprg, 6L);
9852     }
9853
9854     *eps03 = mmprcsn_.eps3;
9855
9856     return 0;
9857 } /* mmveps3_ */
9858
9859 //=======================================================================
9860 //function : AdvApp2Var_MathBase::mmvncol_
9861 //purpose  :
9862 //=======================================================================
9863  int AdvApp2Var_MathBase::mmvncol_(integer *ndimen,
9864                             doublereal *vecin,
9865                             doublereal *vecout,
9866                             integer *iercod)
9867
9868 {
9869   /* System generated locals */
9870   integer i__1;
9871
9872   /* Local variables */
9873   logical ldbg;
9874   integer d__;
9875   doublereal vaux1[3], vaux2[3];
9876   logical colin;
9877   doublereal valaux;
9878   integer aux;
9879
9880 /* ***********************************************************************
9881  */
9882
9883 /*     FUNCTION : */
9884 /*     ---------- */
9885 /*       CALCULATE A VECTOR NON-COLINEAR TO A GIVEN NON-NULL VECTOR */
9886
9887 /*     KEYWORDS : */
9888 /*     ----------- */
9889 /*      PUBLIC, VECTOR, FREE */
9890
9891 /*     INPUT ARGUMENTS  : */
9892 /*     -------------------- */
9893 /*       ndimen : dimension of the space */
9894 /*       vecin  : input vector */
9895
9896 /*     OUTPUT ARGUMENTS : */
9897 /*     --------------------- */
9898
9899 /*       vecout : vector non colinear to vecin */
9900
9901 /*     COMMONS USED : */
9902 /*     ------------------ */
9903
9904
9905 /*     REFERENCES CALLED : */
9906 /*     --------------------- */
9907
9908
9909 /*     DESCRIPTION/NOTES/LIMITATIONS : */
9910 /*     ----------------------------------- */
9911 /* > */
9912 /* ***********************************************************************
9913  */
9914 /*                            DECLARATIONS */
9915 /* ***********************************************************************
9916  */
9917
9918
9919
9920 /* ***********************************************************************
9921  */
9922 /*                      INITIALISATIONS */
9923 /* ***********************************************************************
9924  */
9925
9926     /* Parameter adjustments */
9927     --vecout;
9928     --vecin;
9929
9930     /* Function Body */
9931     ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 2;
9932     if (ldbg) {
9933         AdvApp2Var_SysBase::mgenmsg_("MMVNCOL", 7L);
9934     }
9935     *iercod = 0;
9936
9937 /* ***********************************************************************
9938  */
9939 /*                     PROCESSING */
9940 /* ***********************************************************************
9941  */
9942
9943     if (*ndimen <= 1 || *ndimen > 3) {
9944         goto L9101;
9945     }
9946     d__ = 1;
9947     aux = 0;
9948     while(d__ <= *ndimen) {
9949         if (vecin[d__] == 0.) {
9950             ++aux;
9951         }
9952         ++d__;
9953     }
9954     if (aux == *ndimen) {
9955         goto L9101;
9956     }
9957
9958
9959     for (d__ = 1; d__ <= 3; ++d__) {
9960         vaux1[d__ - 1] = 0.;
9961     }
9962     i__1 = *ndimen;
9963     for (d__ = 1; d__ <= i__1; ++d__) {
9964         vaux1[d__ - 1] = vecin[d__];
9965         vaux2[d__ - 1] = vecin[d__];
9966     }
9967     colin = TRUE_;
9968     d__ = 0;
9969     while(colin) {
9970         ++d__;
9971         if (d__ > 3) {
9972             goto L9101;
9973         }
9974         vaux2[d__ - 1] += 1;
9975         valaux = vaux1[1] * vaux2[2] - vaux1[2] * vaux2[1];
9976         if (valaux == 0.) {
9977             valaux = vaux1[2] * vaux2[0] - vaux1[0] * vaux2[2];
9978             if (valaux == 0.) {
9979                 valaux = vaux1[0] * vaux2[1] - vaux1[1] * vaux2[0];
9980                 if (valaux != 0.) {
9981                     colin = FALSE_;
9982                 }
9983             } else {
9984                 colin = FALSE_;
9985             }
9986         } else {
9987             colin = FALSE_;
9988         }
9989     }
9990     if (colin) {
9991         goto L9101;
9992     }
9993     i__1 = *ndimen;
9994     for (d__ = 1; d__ <= i__1; ++d__) {
9995         vecout[d__] = vaux2[d__ - 1];
9996     }
9997
9998     goto L9999;
9999
10000 /* ***********************************************************************
10001  */
10002 /*                   ERROR PROCESSING */
10003 /* ***********************************************************************
10004  */
10005
10006
10007 L9101:
10008     *iercod = 1;
10009     goto L9999;
10010
10011
10012 /* ***********************************************************************
10013  */
10014 /*                   RETURN CALLING PROGRAM */
10015 /* ***********************************************************************
10016  */
10017
10018 L9999:
10019
10020
10021     AdvApp2Var_SysBase::maermsg_("MMVNCOL", iercod, 7L);
10022     if (ldbg) {
10023         AdvApp2Var_SysBase::mgsomsg_("MMVNCOL", 7L);
10024     }
10025  return 0 ;
10026 } /* mmvncol_ */
10027
10028 //=======================================================================
10029 //function : AdvApp2Var_MathBase::mmwprcs_
10030 //purpose  :
10031 //=======================================================================
10032 void AdvApp2Var_MathBase::mmwprcs_(doublereal *epsil1,
10033                                    doublereal *epsil2,
10034                                    doublereal *epsil3,
10035                                    doublereal *epsil4,
10036                                    integer *niter1,
10037                                    integer *niter2)
10038
10039 {
10040
10041
10042 /* ***********************************************************************
10043  */
10044
10045 /*     FUNCTION : */
10046 /*     ---------- */
10047 /*     ACCESS IN WRITING FOR COMMON MPRCSN */
10048
10049 /*     KEYWORDS : */
10050 /*     ----------- */
10051 /*     WRITING */
10052
10053 /*     INPUT ARGUMENTS : */
10054 /*     -------------------- */
10055 /*     EPSIL1  : TOLERANCE OF 3D NULL DISTANCE */
10056 /*     EPSIL2  : TOLERANCE OF PARAMETRIC NULL DISTANCE */
10057 /*     EPSIL3  : TOLERANCE TO AVOID DIVISION BY 0.. */
10058 /*     EPSIL4  : ANGULAR TOLERANCE */
10059 /*     NITER1  : MAX NB OF ITERATIONS */
10060 /*     NITER2  : NB OF RAPID ITERATIONS */
10061
10062 /*     OUTPUT ARGUMENTS : */
10063 /*     --------------------- */
10064 /*     NONE */
10065
10066 /*     COMMONS USED : */
10067 /*     ------------------ */
10068
10069
10070 /*     REFERENCES CALLED : */
10071 /*     --------------------- */
10072
10073
10074 /*     DESCRIPTION/NOTES/LIMITATIONS : */
10075 /*     ----------------------------------- */
10076
10077 /* > */
10078 /* ***********************************************************************
10079  */
10080 /*                            DECLARATIONS */
10081 /* ***********************************************************************
10082  */
10083
10084
10085 /* ***********************************************************************
10086  */
10087 /*                      INITIALIZATIONS */
10088 /* ***********************************************************************
10089  */
10090
10091 /* ***********************************************************************
10092  */
10093 /*                      PROCESSING */
10094 /* ***********************************************************************
10095  */
10096
10097 /* ***********************************************************************
10098  */
10099
10100 /*     FUNCTION : */
10101 /*     ---------- */
10102 /*          GIVES TOLERANCES OF NULLITY IN STRIM */
10103 /*          AND  LIMITS OF ITERATIVE PROCESSES */
10104
10105 /*          GENERAL CONTEXT, MODIFIABLE BY THE UTILISER */
10106
10107 /*     KEYWORDS : */
10108 /*     ----------- */
10109 /*          PARAMETER , TOLERANCE */
10110
10111 /*     DESCRIPTION/NOTES/LIMITATIONS : */
10112 /*     ----------------------------------- */
10113 /*       INITIALISATION   :  PROFILE , **VIA MPRFTX** AT INPUT IN STRIM*/
10114 /*       LOADING OF DEFAULT VALUES OF THE PROFILE IN MPRFTX AT INPUT*/
10115 /*       IN STRIM. THEY ARE PRESERVED IN THE LOCAL VARIABLES OF MPRFTX */
10116
10117 /*        RESET DEFAULT VALUES                   : MDFINT */
10118 /*        MODIFICATION INTERACTIVE BY THE USER   : MDBINT */
10119
10120 /*        ACCESS FUNCTION  :  MMEPS1  ...  EPS1 */
10121 /*                            MEPSPB  ...  EPS3,EPS4 */
10122 /*                            MEPSLN  ...  EPS2, NITERM , NITERR */
10123 /*                            MEPSNR  ...  EPS2 , NITERM */
10124 /*                            MITERR  ...  NITERR */
10125
10126 /* > */
10127 /* ***********************************************************************
10128  */
10129
10130 /*     NITERM : MAX NB OF ITERATIONS */
10131 /*     NITERR : NB OF RAPID ITERATIONS */
10132 /*     EPS1   : TOLERANCE OF 3D NULL DISTANCE */
10133 /*     EPS2   : TOLERANCE OF ZERO PARAMETRIC DISTANCE */
10134 /*     EPS3   : TOLERANCE TO AVOID DIVISION BY 0.. */
10135 /*     EPS4   : TOLERANCE ANGULAR */
10136
10137
10138 /* ***********************************************************************
10139  */
10140     mmprcsn_.eps1 = *epsil1;
10141     mmprcsn_.eps2 = *epsil2;
10142     mmprcsn_.eps3 = *epsil3;
10143     mmprcsn_.eps4 = *epsil4;
10144     mmprcsn_.niterm = *niter1;
10145     mmprcsn_.niterr = *niter2;
10146  return ;
10147 } /* mmwprcs_  */
10148
10149
10150 //=======================================================================
10151 //function : AdvApp2Var_MathBase::pow__di
10152 //purpose  :
10153 //=======================================================================
10154  doublereal AdvApp2Var_MathBase::pow__di (doublereal *x,
10155                                    integer *n)
10156 {
10157   doublereal result ;
10158   integer    absolute ;
10159   result = 1.0e0 ;
10160   if ( *n > 0 ) {absolute = *n;}
10161   else {absolute = -*n;}
10162     /* System generated locals */
10163   for(integer ii = 0 ; ii < absolute ; ii++) {
10164       result *=  *x ;
10165    }
10166   if (*n < 0) {
10167    result = 1.0e0 / result ;
10168  }
10169  return result ;
10170 }
10171
10172
10173 /* **********************************************************************
10174 */
10175
10176 /*     FUNCTION : */
10177 /*     ---------- */
10178 /*        Calculate integer function power not obligatory in the most efficient way ;
10179 */
10180
10181 /*     KEYWORDS : */
10182 /*     ----------- */
10183 /*       POWER */
10184
10185 /*     INPUT ARGUMENTS : */
10186 /*     ------------------ */
10187 /*        X      :  argument of X**N */
10188 /*        N      :  power */
10189
10190 /*     OUTPUT ARGUMENTS : */
10191 /*     ------------------- */
10192 /*        return X**N */
10193
10194 /*     COMMONS USED   : */
10195 /*     ---------------- */
10196
10197 /*     REFERENCES CALLED   : */
10198 /*     ----------------------- */
10199
10200 /*     DESCRIPTION/NOTES/LIMITATIONS : */
10201 /*     ----------------------------------- */
10202
10203 /* > */
10204 /* ***********************************************************************/
10205
10206 //=======================================================================
10207 //function : pow__ii
10208 //purpose  :
10209 //=======================================================================
10210 integer pow__ii(integer *x,
10211                 integer *n)
10212
10213 {
10214   integer result ;
10215   integer    absolute ;
10216   result = 1 ;
10217   if ( *n > 0 ) {absolute = *n;}
10218   else {absolute = -*n;}
10219     /* System generated locals */
10220   for(integer ii = 0 ; ii < absolute ; ii++) {
10221       result *=  *x ;
10222    }
10223   if (*n < 0) {
10224    result = 1 / result ;
10225  }
10226  return result ;
10227 }
10228
10229
10230 /* **********************************************************************
10231 */
10232 /* **********************************************************************
10233 */
10234
10235 /*     FUNCTION : */
10236 /*     ---------- */
10237 /*        Calculate integer function power not obligatory in the most efficient way ;
10238 */
10239
10240 /*     KEYWORDS : */
10241 /*     ----------- */
10242 /*       POWER */
10243
10244 /*     INPUT ARGUMENTS : */
10245 /*     ------------------ */
10246 /*        X      :  argument of X**N */
10247 /*        N      :  power */
10248
10249 /*     OUTPUT ARGUMENTS : */
10250 /*     ------------------- */
10251 /*        return X**N */
10252
10253 /*     COMMONS USED   : */
10254 /*     ---------------- */
10255
10256 /*     REFERENCES CALLED   : */
10257 /*     ----------------------- */
10258
10259 /*     DESCRIPTION/NOTES/LIMITATIONS : */
10260 /*     ----------------------------------- */
10261
10262 /* > */
10263 /* ***********************************************************************/
10264
10265 //=======================================================================
10266 //function : AdvApp2Var_MathBase::msc_
10267 //purpose  :
10268 //=======================================================================
10269  doublereal AdvApp2Var_MathBase::msc_(integer *ndimen,
10270                                doublereal *vecte1,
10271                                doublereal *vecte2)
10272
10273 {
10274   /* System generated locals */
10275   integer i__1;
10276   doublereal ret_val;
10277
10278   /* Local variables */
10279   integer i__;
10280   doublereal x;
10281
10282
10283
10284 /************************************************************************
10285 *******/
10286
10287 /*     FUNCTION : */
10288 /*     ---------- */
10289 /*        Calculate the scalar product of 2 vectors in the space */
10290 /*        of dimension NDIMEN. */
10291
10292 /*     KEYWORDS : */
10293 /*     ----------- */
10294 /*        PRODUCT MSCALAIRE. */
10295
10296 /*     INPUT ARGUMENTS  : */
10297 /*     ------------------ */
10298 /*        NDIMEN : Dimension of the space. */
10299 /*        VECTE1,VECTE2: Vectors. */
10300
10301 /*     OUTPUT ARGUMENTS : */
10302 /*     ------------------- */
10303
10304 /*     COMMONS USED     : */
10305 /*     ---------------- */
10306
10307 /*     REFERENCES CALLED : */
10308 /*     ----------------------- */
10309
10310 /*     DESCRIPTION/NOTES/LIMITATIONS : */
10311 /*     ----------------------------------- */
10312
10313 /* > */
10314 /* ***********************************************************************
10315  */
10316
10317
10318 /*     PRODUIT MSCALAIRE */
10319     /* Parameter adjustments */
10320     --vecte2;
10321     --vecte1;
10322
10323     /* Function Body */
10324     x = 0.;
10325
10326     i__1 = *ndimen;
10327     for (i__ = 1; i__ <= i__1; ++i__) {
10328         x += vecte1[i__] * vecte2[i__];
10329 /* L100: */
10330     }
10331     ret_val = x;
10332
10333 /* ----------------------------------- THE END --------------------------
10334 */
10335
10336     return ret_val;
10337 } /* msc_ */
10338
10339 //=======================================================================
10340 //function : mvcvin2_
10341 //purpose  :
10342 //=======================================================================
10343 int mvcvin2_(integer *ncoeff,
10344              doublereal *crvold,
10345              doublereal *crvnew,
10346              integer *iercod)
10347
10348 {
10349   /* System generated locals */
10350   integer i__1, i__2;
10351
10352   /* Local variables */
10353   integer m1jm1, ncfm1, j, k;
10354   doublereal bid;
10355   doublereal cij1, cij2;
10356
10357
10358
10359 /************************************************************************
10360 *******/
10361
10362 /*     FONCTION : */
10363 /*     ---------- */
10364 /*        INVERSION OF THE PARAMETERS ON CURVE 2D. */
10365
10366 /*     KEYWORDS : */
10367 /*     ----------- */
10368 /*        CURVE,2D,INVERSION,PARAMETER. */
10369
10370 /*     INPUT ARGUMENTS : */
10371 /*     ------------------ */
10372 /*        NCOEFF   : NB OF COEFF OF THE CURVE. */
10373 /*        CRVOLD   : CURVE OF ORIGIN */
10374
10375 /*     OUTPUT ARGUMENTS : */
10376 /*     ------------------- */
10377 /*        CRVNEW   : THE RESULTING CURVE AFTER CHANGE OF T BY 1-T */
10378 /*        IERCOD   :  0 OK, */
10379 /*                   10 NB OF COEFF NULL OR TOO GREAT. */
10380
10381 /*     COMMONS USED   : */
10382 /*     ---------------- */
10383 /*    MCCNP */
10384
10385 /*     REFERENCES CALLED   : */
10386 /*     ---------------------- */
10387 /*            Neant */
10388 /*     DESCRIPTION/NOTES/LIMITATIONS : */
10389 /*     ----------------------------------- */
10390 /*     THE FOLLOWING CALL IS ABSOLUTELY LEGAL : */
10391 /*          CALL MVCVIN2(NCOEFF,CURVE,CURVE,IERCOD), THE TABLE CURVE */
10392 /*     BECOMES INPUT AND OUTPUT ARGUMENT (RBD). */
10393 /*     BECAUSE OF MCCNP, THE NB OF COEFF OF THE CURVE IS LIMITED TO */
10394 /*     NDGCNP+1 = 61. */
10395
10396 /* > */
10397 /* ***********************************************************************
10398  */
10399
10400
10401 /* **********************************************************************
10402 */
10403
10404 /*     FUNCTION : */
10405 /*     ---------- */
10406 /*      Serves to provide coefficients of the binome (triangle of Pascal). */
10407
10408 /*     KEYWORDS : */
10409 /*     ----------- */
10410 /*      Coeff of binome from 0 to 60. read only . init par block data */
10411
10412 /*     DEMSCRIPTION/NOTES/LIMITATIONS : */
10413 /*     ----------------------------------- */
10414 /*     The coefficients of the binome form a triangular matrix. */
10415 /*     This matrix is completed in table CNP by transposition. */
10416 /*     So: CNP(I,J) = CNP(J,I) for I and J = 0, ..., 60. */
10417
10418 /*     Initialization is done by block-data MMLLL09.RES, */
10419 /*     created by program MQINICNP.FOR (see the team (AC) ). */
10420
10421
10422 /* > */
10423 /* **********************************************************************
10424 */
10425
10426
10427
10428 /* ***********************************************************************
10429  */
10430
10431     /* Parameter adjustments */
10432     crvnew -= 3;
10433     crvold -= 3;
10434
10435     /* Function Body */
10436     if (*ncoeff < 1 || *ncoeff - 1 > 60) {
10437         *iercod = 10;
10438         goto L9999;
10439     }
10440     *iercod = 0;
10441
10442
10443 /* CONSTANT TERM OF THE NEW CURVE */
10444
10445     cij1 = crvold[3];
10446     cij2 = crvold[4];
10447     i__1 = *ncoeff;
10448     for (k = 2; k <= i__1; ++k) {
10449         cij1 += crvold[(k << 1) + 1];
10450         cij2 += crvold[(k << 1) + 2];
10451     }
10452     crvnew[3] = cij1;
10453     crvnew[4] = cij2;
10454     if (*ncoeff == 1) {
10455         goto L9999;
10456     }
10457
10458 /* INTERMEDIARY POWERS OF THE PARAMETER */
10459
10460     ncfm1 = *ncoeff - 1;
10461     m1jm1 = 1;
10462     i__1 = ncfm1;
10463     for (j = 2; j <= i__1; ++j) {
10464         m1jm1 = -m1jm1;
10465         cij1 = crvold[(j << 1) + 1];
10466         cij2 = crvold[(j << 1) + 2];
10467         i__2 = *ncoeff;
10468         for (k = j + 1; k <= i__2; ++k) {
10469             bid = mmcmcnp_.cnp[k - 1 + (j - 1) * 61];
10470             cij1 += crvold[(k << 1) + 1] * bid;
10471             cij2 += crvold[(k << 1) + 2] * bid;
10472         }
10473         crvnew[(j << 1) + 1] = cij1 * m1jm1;
10474         crvnew[(j << 1) + 2] = cij2 * m1jm1;
10475     }
10476
10477 /* TERM OF THE HIGHEST  DEGREE */
10478
10479     crvnew[(*ncoeff << 1) + 1] = -crvold[(*ncoeff << 1) + 1] * m1jm1;
10480     crvnew[(*ncoeff << 1) + 2] = -crvold[(*ncoeff << 1) + 2] * m1jm1;
10481
10482 L9999:
10483     if (*iercod > 0) {
10484         AdvApp2Var_SysBase::maermsg_("MVCVIN2", iercod, 7L);
10485     }
10486  return 0 ;
10487 } /* mvcvin2_ */
10488
10489 //=======================================================================
10490 //function : mvcvinv_
10491 //purpose  :
10492 //=======================================================================
10493 int mvcvinv_(integer *ncoeff,
10494              doublereal *crvold,
10495              doublereal *crvnew,
10496              integer *iercod)
10497
10498 {
10499   /* System generated locals */
10500   integer i__1, i__2;
10501
10502   /* Local variables */
10503   integer m1jm1, ncfm1, j, k;
10504   doublereal bid;
10505   //extern /* Subroutine */ int maermsg_();
10506   doublereal cij1, cij2, cij3;
10507
10508
10509 /* **********************************************************************
10510 */
10511
10512 /*     FUNCTION : */
10513 /*     ---------- */
10514 /*        INVERSION OF THE PARAMETER ON A CURBE 3D (I.E. INVERSION */
10515 /*        OF THE DIRECTION OF PARSING). */
10516
10517 /*     KEYWORDS : */
10518 /*     ----------- */
10519 /*        CURVE,INVERSION,PARAMETER. */
10520
10521 /*     INPUT ARGUMENTS : */
10522 /*     ------------------ */
10523 /*        NCOEFF   : NB OF COEFF OF THE CURVE. */
10524 /*        CRVOLD   : CURVE OF ORIGIN */
10525
10526 /*     OUTPUT ARGUMENTS : */
10527 /*     ------------------- */
10528 /*        CRVNEW   : RESULTING CURVE AFTER CHANGE OF T INTO 1-T */
10529 /*        IERCOD   :  0 OK, */
10530 /*                   10 NB OF COEFF NULL OR TOO GREAT. */
10531
10532 /*     COMMONS USED   : */
10533 /*     ---------------- */
10534 /*    MCCNP */
10535
10536 /*     REFERENCES CALLED   : */
10537 /*     ---------------------- */
10538 /*            Neant */
10539 /*     DESCRIPTION/NOTES/LIMITATIONS : */
10540 /*     ----------------------------------- */
10541 /*     THE FOLLOWING CALL IS ABSOLUTELY LEGAL : */
10542 /*          CALL MVCVINV(NCOEFF,CURVE,CURVE,IERCOD), TABLE CURVE */
10543 /*     BECOMES INPUT AND OUTPUT ARGUMENT (RBD). */
10544 /*     THE NUMBER OF COEFF OF THE CURVE IS LIMITED TO NDGCNP+1 = 61 */
10545 /*     BECAUSE OF USE OF COMMON MCCNP. */
10546 /* > */
10547 /* ***********************************************************************
10548  */
10549
10550 /* **********************************************************************
10551 */
10552
10553 /*     FUNCTION : */
10554 /*     ---------- */
10555 /*      Serves to provide the binomial coefficients (triangle of Pascal). */
10556
10557 /*     KEYWORDS : */
10558 /*     ----------- */
10559 /*      Binomial Coeff from 0 to 60. read only . init par block data */
10560
10561 /*     DEMSCRIPTION/NOTES/LIMITATIONS : */
10562 /*     ----------------------------------- */
10563 /*     The binomial coefficients form a triangular matrix. */
10564 /*     This matrix is completed in table CNP by its transposition. */
10565 /*     So: CNP(I,J) = CNP(J,I) for I and J = 0, ..., 60. */
10566
10567 /*     Initialisation is done by block-data MMLLL09.RES, */
10568 /*     created by program MQINICNP.FOR (see the team (AC) ). */
10569 /* > */
10570 /* **********************************************************************
10571 */
10572
10573
10574
10575 /* ***********************************************************************
10576  */
10577
10578     /* Parameter adjustments */
10579     crvnew -= 4;
10580     crvold -= 4;
10581
10582     /* Function Body */
10583     if (*ncoeff < 1 || *ncoeff - 1 > 60) {
10584         *iercod = 10;
10585         goto L9999;
10586     }
10587     *iercod = 0;
10588
10589 /* CONSTANT TERM OF THE NEW CURVE */
10590
10591     cij1 = crvold[4];
10592     cij2 = crvold[5];
10593     cij3 = crvold[6];
10594     i__1 = *ncoeff;
10595     for (k = 2; k <= i__1; ++k) {
10596         cij1 += crvold[k * 3 + 1];
10597         cij2 += crvold[k * 3 + 2];
10598         cij3 += crvold[k * 3 + 3];
10599 /* L30: */
10600     }
10601     crvnew[4] = cij1;
10602     crvnew[5] = cij2;
10603     crvnew[6] = cij3;
10604     if (*ncoeff == 1) {
10605         goto L9999;
10606     }
10607
10608 /* INTERMEDIARY POWER OF THE PARAMETER */
10609
10610     ncfm1 = *ncoeff - 1;
10611     m1jm1 = 1;
10612     i__1 = ncfm1;
10613     for (j = 2; j <= i__1; ++j) {
10614         m1jm1 = -m1jm1;
10615         cij1 = crvold[j * 3 + 1];
10616         cij2 = crvold[j * 3 + 2];
10617         cij3 = crvold[j * 3 + 3];
10618         i__2 = *ncoeff;
10619         for (k = j + 1; k <= i__2; ++k) {
10620             bid = mmcmcnp_.cnp[k - 1 + (j - 1) * 61];
10621             cij1 += crvold[k * 3 + 1] * bid;
10622             cij2 += crvold[k * 3 + 2] * bid;
10623             cij3 += crvold[k * 3 + 3] * bid;
10624 /* L40: */
10625         }
10626         crvnew[j * 3 + 1] = cij1 * m1jm1;
10627         crvnew[j * 3 + 2] = cij2 * m1jm1;
10628         crvnew[j * 3 + 3] = cij3 * m1jm1;
10629 /* L50: */
10630     }
10631
10632     /* TERM OF THE HIGHEST DEGREE */
10633
10634     crvnew[*ncoeff * 3 + 1] = -crvold[*ncoeff * 3 + 1] * m1jm1;
10635     crvnew[*ncoeff * 3 + 2] = -crvold[*ncoeff * 3 + 2] * m1jm1;
10636     crvnew[*ncoeff * 3 + 3] = -crvold[*ncoeff * 3 + 3] * m1jm1;
10637
10638 L9999:
10639     AdvApp2Var_SysBase::maermsg_("MVCVINV", iercod, 7L);
10640     return 0;
10641 } /* mvcvinv_ */
10642
10643 //=======================================================================
10644 //function : mvgaus0_
10645 //purpose  :
10646 //=======================================================================
10647 int mvgaus0_(integer *kindic,
10648              doublereal *urootl,
10649              doublereal *hiltab,
10650              integer *nbrval,
10651              integer *iercod)
10652
10653 {
10654     /* System generated locals */
10655     integer i__1;
10656
10657     /* Local variables */
10658     doublereal tampc[40];
10659     NCollection_Array1<doublereal> tamp (tampc[0], 1, 40);
10660     integer ndegl, kg, ii;
10661
10662 /* **********************************************************************
10663 */
10664
10665 /*      FUNCTION : */
10666 /*      -------- */
10667 /*  Loading of a degree gives roots of LEGENDRE polynom */
10668 /*  DEFINED on [-1,1] and weights of Gauss quadrature formulas */
10669 /*  (based on corresponding LAGRANGIAN interpolators). */
10670 /*  The symmetry relative to 0 is used between [-1,0] and [0,1]. */
10671
10672 /*      KEYWORDS : */
10673 /*      --------- */
10674 /*         . VOLUMIC, LEGENDRE, LAGRANGE, GAUSS */
10675
10676 /*      INPUT ARGUMENTSE : */
10677 /*      ------------------ */
10678
10679 /*  KINDIC : Takes values from 1 to 10 depending of the degree */
10680 /*           of the used polynom. */
10681 /*           The degree of the polynom is equal to 4 k, i.e. 4, 8, */
10682 /*           12, 16, 20, 24, 28, 32, 36 and 40. */
10683
10684 /*      OUTPUT ARGUMENTS : */
10685 /*      ------------------- */
10686
10687 /*  UROOTL : Roots of LEGENDRE polynom in domain [1,0] */
10688 /*           given in decreasing order. For domain [-1,0], it is */
10689 /*           necessary to take the opposite values. */
10690 /*  HILTAB : LAGRANGE interpolators associated to roots. For */
10691 /*           opposed roots, interpolatorsare equal. */
10692 /*  NBRVAL : Nb of coefficients. Is equal to the half of degree */
10693 /*           depending on the symmetry (i.e. 2*KINDIC). */
10694
10695 /*  IERCOD  :  Error code: */
10696 /*          < 0 ==> Attention - Warning */
10697 /*          =-1 ==> Value of false KINDIC. NBRVAL is forced to 20 */
10698 /*                  (order 40) */
10699 /*          = 0 ==> Everything is OK */
10700
10701 /*      COMMON USED : */
10702 /*      ---------------- */
10703
10704 /*      REFERENCES CALLED : */
10705 /*      ------------------- */
10706
10707 /*      DESCRIPTION/NOTES/LIMITATIONS : */
10708 /*      --------------------------------- */
10709 /*      If KINDIC is not correct (i.e < 1 or > 10), the degree is set */
10710 /*      to 40 directly (ATTENTION to overload - to avoid it, */
10711 /*      preview UROOTL and HILTAB dimensioned at least to 20). */
10712
10713 /*      The value of coefficients was calculated with quadruple precision */
10714 /*      by JJM with help of GD. */
10715 /*      Checking of roots was done by GD. */
10716
10717 /*      See detailed explications on the listing */
10718 /* > */
10719 /* **********************************************************************
10720 */
10721
10722
10723 /* ------------------------------------ */
10724 /* ****** Test  validity of KINDIC ** */
10725 /* ------------------------------------ */
10726
10727     /* Parameter adjustments */
10728     --hiltab;
10729     --urootl;
10730
10731     /* Function Body */
10732     *iercod = 0;
10733     kg = *kindic;
10734     if (kg < 1 || kg > 10) {
10735         kg = 10;
10736         *iercod = -1;
10737     }
10738     *nbrval = kg << 1;
10739     ndegl = *nbrval << 1;
10740
10741 /* ----------------------------------------------------------------------
10742 */
10743 /* ****** Load NBRVAL positive roots depending on the degree **
10744 */
10745 /* ----------------------------------------------------------------------
10746 */
10747 /* ATTENTION : Sign minus (-) in the loop is intentional. */
10748
10749     mmextrl_(&ndegl, tamp);
10750     i__1 = *nbrval;
10751     for (ii = 1; ii <= i__1; ++ii) {
10752         urootl[ii] = -tamp(ii);
10753 /* L100: */
10754     }
10755
10756 /* ------------------------------------------------------------------- */
10757 /* ****** Loading of NBRVAL Gauss weight depending on the degree ** */
10758 /* ------------------------------------------------------------------- */
10759
10760     mmexthi_(&ndegl, tamp);
10761     i__1 = *nbrval;
10762     for (ii = 1; ii <= i__1; ++ii) {
10763         hiltab[ii] = tamp(ii);
10764 /* L200: */
10765     }
10766
10767 /* ------------------------------- */
10768 /* ****** End of sub-program ** */
10769 /* ------------------------------- */
10770
10771     return 0;
10772 } /* mvgaus0_ */
10773
10774 //=======================================================================
10775 //function : mvpscr2_
10776 //purpose  :
10777 //=======================================================================
10778 int mvpscr2_(integer *ncoeff,
10779              doublereal *curve2,
10780              doublereal *tparam,
10781              doublereal *pntcrb)
10782 {
10783   /* System generated locals */
10784   integer i__1;
10785
10786   /* Local variables */
10787   integer ndeg, kk;
10788   doublereal xxx, yyy;
10789
10790
10791
10792 /* **********************************************************************
10793 */
10794
10795 /*     FUNCTION : */
10796 /*     ---------- */
10797 /*  POSITIONING ON CURVE (NCF,2) IN SPACE OF DIMENSION 2. */
10798
10799 /*     KEYWORDS : */
10800 /*     ----------- */
10801 /*     TOUS,MATH_ACCES:: COURBE&,POSITIONNEMENT,&POINT. */
10802
10803 /*     INPUT ARGUMENTS : */
10804 /*     ------------------ */
10805 /*     NCOEFF : NUMBER OF COEFFICIENTS OF THE CURVE */
10806 /*     CURVE2 : EQUATION OF CURVE 2D */
10807 /*     TPARAM : VALUE OF PARAMETER AT GIVEN POINT */
10808
10809 /*     OUTPUT ARGUMENTS : */
10810 /*     ------------------- */
10811 /*     PNTCRB : COORDINATES OF POINT CORRESPONDING TO PARAMETER */
10812 /*              TPARAM ON CURVE 2D CURVE2. */
10813
10814 /*     COMMONS USED   : */
10815 /*     ---------------- */
10816
10817 /*     REFERENCES CALLED   : */
10818 /*     ---------------------- */
10819
10820 /*     DESCRIPTION/NOTES/LIMITATIONS : */
10821 /*     ----------------------------------- */
10822 /*     MSCHEMA OF HORNER. */
10823
10824 /* > */
10825 /* **********************************************************************
10826 */
10827
10828
10829 /* -------- INITIALIZATIONS AND PROCESSING OF PARTICULAR CASES ----------
10830 */
10831
10832 /* ---> Cas when NCOEFF > 1 (case STANDARD). */
10833     /* Parameter adjustments */
10834     --pntcrb;
10835     curve2 -= 3;
10836
10837     /* Function Body */
10838     if (*ncoeff >= 2) {
10839         goto L1000;
10840     }
10841 /* ---> Case when NCOEFF <= 1. */
10842     if (*ncoeff <= 0) {
10843         pntcrb[1] = 0.;
10844         pntcrb[2] = 0.;
10845         goto L9999;
10846     } else if (*ncoeff == 1) {
10847         pntcrb[1] = curve2[3];
10848         pntcrb[2] = curve2[4];
10849         goto L9999;
10850     }
10851
10852 /* -------------------- MSCHEMA OF HORNER (PARTICULAR CASE) --------------
10853  */
10854
10855 L1000:
10856
10857     if (*tparam == 1.) {
10858         xxx = 0.;
10859         yyy = 0.;
10860         i__1 = *ncoeff;
10861         for (kk = 1; kk <= i__1; ++kk) {
10862             xxx += curve2[(kk << 1) + 1];
10863             yyy += curve2[(kk << 1) + 2];
10864 /* L100: */
10865         }
10866         goto L5000;
10867     } else if (*tparam == 0.) {
10868         pntcrb[1] = curve2[3];
10869         pntcrb[2] = curve2[4];
10870         goto L9999;
10871     }
10872
10873 /* ---------------------------- MSCHEMA OF HORNER ------------------------
10874  */
10875 /* ---> TPARAM is different from 1.D0 and 0.D0. */
10876
10877     ndeg = *ncoeff - 1;
10878     xxx = curve2[(*ncoeff << 1) + 1];
10879     yyy = curve2[(*ncoeff << 1) + 2];
10880     for (kk = ndeg; kk >= 1; --kk) {
10881         xxx = xxx * *tparam + curve2[(kk << 1) + 1];
10882         yyy = yyy * *tparam + curve2[(kk << 1) + 2];
10883 /* L200: */
10884     }
10885     goto L5000;
10886
10887 /* ------------------------ RECOVER THE CALCULATED POINT ---------------
10888 */
10889
10890 L5000:
10891     pntcrb[1] = xxx;
10892     pntcrb[2] = yyy;
10893
10894 /* ------------------------------ THE END -------------------------------
10895 */
10896
10897 L9999:
10898     return 0;
10899 } /* mvpscr2_ */
10900
10901 //=======================================================================
10902 //function : mvpscr3_
10903 //purpose  :
10904 //=======================================================================
10905 int mvpscr3_(integer *ncoeff,
10906              doublereal *curve3,
10907              doublereal *tparam,
10908              doublereal *pntcrb)
10909
10910 {
10911   /* System generated locals */
10912   integer i__1;
10913
10914   /* Local variables */
10915   integer ndeg, kk;
10916   doublereal xxx, yyy, zzz;
10917
10918
10919
10920 /* **********************************************************************
10921 */
10922
10923 /*     FUNCTION : */
10924 /*     ---------- */
10925 /* POSITIONING ON A CURVE (3,NCF) IN THE SPACE OF DIMENSION 3. */
10926
10927 /*     KEYWORDS : */
10928 /*     ----------- */
10929 /*     TOUS, MATH_ACCES:: COURBE&,POSITIONNEMENT,&POINT. */
10930
10931 /*     INPUT ARGUMENTS  : */
10932 /*     ------------------ */
10933 /*     NCOEFF : NB OF COEFFICIENTS OF THE CURVE */
10934 /*     CURVE3 : EQUATION OF CURVE 3D */
10935 /*     TPARAM : VALUE OF THE PARAMETER AT THE GIVEN POINT */
10936
10937 /*     OUTPUT ARGUMENTS : */
10938 /*     ------------------- */
10939 /*     PNTCRB : COORDINATES OF THE POINT CORRESPONDING TO PARAMETER */
10940 /*              TPARAM ON CURVE 3D CURVE3. */
10941
10942 /*     COMMONS USED   : */
10943 /*     ---------------- */
10944
10945 /*     REFERENCES CALLED   : */
10946 /*     ---------------------- */
10947 /*            Neant */
10948
10949 /*     DESCRIPTION/NOTES/LIMITATIONS : */
10950 /*     ----------------------------------- */
10951 /*     MSCHEMA OF HORNER. */
10952 /* > */
10953 /* **********************************************************************
10954 */
10955 /*                           DECLARATIONS */
10956 /* **********************************************************************
10957 */
10958
10959
10960 /* -------- INITIALISATIONS AND PROCESSING OF PARTICULAR CASES ----------
10961 */
10962
10963 /* ---> Case when NCOEFF > 1 (cas STANDARD). */
10964     /* Parameter adjustments */
10965     --pntcrb;
10966     curve3 -= 4;
10967
10968     /* Function Body */
10969     if (*ncoeff >= 2) {
10970         goto L1000;
10971     }
10972 /* ---> Case when NCOEFF <= 1. */
10973     if (*ncoeff <= 0) {
10974         pntcrb[1] = 0.;
10975         pntcrb[2] = 0.;
10976         pntcrb[3] = 0.;
10977         goto L9999;
10978     } else if (*ncoeff == 1) {
10979         pntcrb[1] = curve3[4];
10980         pntcrb[2] = curve3[5];
10981         pntcrb[3] = curve3[6];
10982         goto L9999;
10983     }
10984
10985 /* -------------------- MSCHEMA OF HORNER (PARTICULAR CASE) --------------
10986  */
10987
10988 L1000:
10989
10990     if (*tparam == 1.) {
10991         xxx = 0.;
10992         yyy = 0.;
10993         zzz = 0.;
10994         i__1 = *ncoeff;
10995         for (kk = 1; kk <= i__1; ++kk) {
10996             xxx += curve3[kk * 3 + 1];
10997             yyy += curve3[kk * 3 + 2];
10998             zzz += curve3[kk * 3 + 3];
10999 /* L100: */
11000         }
11001         goto L5000;
11002     } else if (*tparam == 0.) {
11003         pntcrb[1] = curve3[4];
11004         pntcrb[2] = curve3[5];
11005         pntcrb[3] = curve3[6];
11006         goto L9999;
11007     }
11008
11009 /* ---------------------------- MSCHEMA OF HORNER ------------------------
11010  */
11011 /* ---> Here TPARAM is different from 1.D0 and 0.D0. */
11012
11013     ndeg = *ncoeff - 1;
11014     xxx = curve3[*ncoeff * 3 + 1];
11015     yyy = curve3[*ncoeff * 3 + 2];
11016     zzz = curve3[*ncoeff * 3 + 3];
11017     for (kk = ndeg; kk >= 1; --kk) {
11018         xxx = xxx * *tparam + curve3[kk * 3 + 1];
11019         yyy = yyy * *tparam + curve3[kk * 3 + 2];
11020         zzz = zzz * *tparam + curve3[kk * 3 + 3];
11021 /* L200: */
11022     }
11023     goto L5000;
11024
11025 /* ------------------------ RETURN THE CALCULATED POINT ------------------
11026 */
11027
11028 L5000:
11029     pntcrb[1] = xxx;
11030     pntcrb[2] = yyy;
11031     pntcrb[3] = zzz;
11032
11033 /* ------------------------------ THE END -------------------------------
11034 */
11035
11036 L9999:
11037     return 0;
11038 } /* mvpscr3_ */
11039
11040 //=======================================================================
11041 //function : AdvApp2Var_MathBase::mvsheld_
11042 //purpose  :
11043 //=======================================================================
11044  int AdvApp2Var_MathBase::mvsheld_(integer *n,
11045                             integer *is,
11046                             doublereal *dtab,
11047                             integer *icle)
11048
11049 {
11050   /* System generated locals */
11051   integer dtab_dim1, dtab_offset, i__1, i__2;
11052
11053   /* Local variables */
11054   integer incr;
11055   doublereal dsave;
11056   integer i3, i4, i5, incrp1;
11057
11058
11059 /************************************************************************
11060 *******/
11061
11062 /*     FUNCTION : */
11063 /*     ---------- */
11064 /*       PARSING OF COLUMNS OF TABLE OF REAL*8 BY SHELL METHOD*/
11065 /*        (IN INCREASING ORDER) */
11066
11067 /*     KEYWORDS : */
11068 /*     ----------- */
11069 /*        POINT-ENTRY, PARSING, SHELL */
11070
11071 /*     INPUT ARGUMENTS : */
11072 /*     ------------------ */
11073 /*        N      : NUMBER OF COLUMNS OF THE TABLE */
11074 /*        IS     : NUMBER OF LINE OF THE TABLE */
11075 /*        DTAB   : TABLE OF REAL*8 TO BE PARSED */
11076 /*        ICLE   : POSITION OF THE KEY ON THE COLUMN */
11077
11078 /*     OUTPUT ARGUMENTS : */
11079 /*     ------------------- */
11080 /*        DTAB   : PARSED TABLE */
11081
11082 /*     COMMONS USED   : */
11083 /*     ---------------- */
11084
11085
11086 /*     REFERENCES CALLED   : */
11087 /*     ---------------------- */
11088 /*            Neant */
11089
11090 /*     DESCRIPTION/NOTES/LIMITATIONS : */
11091 /*     ----------------------------------- */
11092 /*     CLASSIC SHELL METHOD : PARSING BY SERIES */
11093 /*     Declaration DTAB(IS, 1) corresponds to DTAB(IS, *) */
11094 /* > */
11095 /* ***********************************************************************
11096  */
11097
11098
11099     /* Parameter adjustments */
11100     dtab_dim1 = *is;
11101     dtab_offset = dtab_dim1 + 1;
11102     dtab -= dtab_offset;
11103
11104     /* Function Body */
11105     if (*n <= 1) {
11106         goto L9900;
11107     }
11108 /*     ------------------------ */
11109
11110 /*  INITIALIZATION OF THE SEQUENCE OF INCREMENTS */
11111 /*  FIND THE GREATEST INCREMENT SO THAT INCR < N/9 */
11112
11113     incr = 1;
11114 L1001:
11115     if (incr >= *n / 9) {
11116         goto L1002;
11117     }
11118 /*     ----------------------------- */
11119     incr = incr * 3 + 1;
11120     goto L1001;
11121
11122 /*  LOOP ON INCREMENTS TILL INCR = 1 */
11123 /*  PARSING BY SERIES DISTANT FROM INCR */
11124
11125 L1002:
11126     incrp1 = incr + 1;
11127 /*     ----------------- */
11128     i__1 = *n;
11129     for (i3 = incrp1; i3 <= i__1; ++i3) {
11130 /*        ---------------------- */
11131
11132 /*  SET ELEMENT I3 AT ITS PLACE IN THE SERIES */
11133
11134         i4 = i3 - incr;
11135 L1004:
11136         if (i4 < 1) {
11137             goto L1003;
11138         }
11139 /*           ------------------------- */
11140         if (dtab[*icle + i4 * dtab_dim1] <= dtab[*icle + (i4 + incr) *
11141                 dtab_dim1]) {
11142             goto L1003;
11143         }
11144
11145         i__2 = *is;
11146         for (i5 = 1; i5 <= i__2; ++i5) {
11147 /*              ------------------ */
11148             dsave = dtab[i5 + i4 * dtab_dim1];
11149             dtab[i5 + i4 * dtab_dim1] = dtab[i5 + (i4 + incr) * dtab_dim1];
11150             dtab[i5 + (i4 + incr) * dtab_dim1] = dsave;
11151         }
11152 /*              -------- */
11153         i4 -= incr;
11154         goto L1004;
11155
11156 L1003:
11157         ;
11158     }
11159 /*           -------- */
11160
11161 /*  PASSAGE TO THE NEXT INCREMENT */
11162
11163     incr /= 3;
11164     if (incr >= 1) {
11165         goto L1002;
11166     }
11167
11168 L9900:
11169  return 0   ;
11170 } /* mvsheld_ */
11171
11172 //=======================================================================
11173 //function : AdvApp2Var_MathBase::mzsnorm_
11174 //purpose  :
11175 //=======================================================================
11176  doublereal AdvApp2Var_MathBase::mzsnorm_(integer *ndimen,
11177                                    doublereal *vecteu)
11178
11179 {
11180   /* System generated locals */
11181   integer i__1;
11182   doublereal ret_val, d__1, d__2;
11183
11184   /* Local variables */
11185   doublereal xsom;
11186   integer i__, irmax;
11187
11188
11189
11190 /* ***********************************************************************
11191  */
11192
11193 /*     FUNCTION : */
11194 /*     ---------- */
11195 /*        SERVES to calculate the euclidian norm of a vector : */
11196 /*                       ____________________________ */
11197 /*                  Z = V  V(1)**2 + V(2)**2 + ... */
11198
11199 /*     KEYWORDS : */
11200 /*     ----------- */
11201 /*        SURMFACIQUE, */
11202
11203 /*     INPUT ARGUMENTS : */
11204 /*     ------------------ */
11205 /*        NDIMEN : Dimension of the vector */
11206 /*        VECTEU : vector of dimension NDIMEN */
11207
11208 /*     OUTPUT ARGUMENTS : */
11209 /*     ------------------- */
11210 /*        MZSNORM : Value of the euclidian norm of vector VECTEU */
11211
11212 /*     COMMONS USED   : */
11213 /*     ---------------- */
11214
11215 /*      .Neant. */
11216
11217 /*     REFERENCES CALLED   : */
11218 /*     ---------------------- */
11219 /*     Type  Name */
11220 /*      R*8  ABS            R*8  SQRT */
11221
11222 /*     DESCRIPTION/NOTESS/LIMITATIONS : */
11223 /*     ----------------------------------- */
11224 /*     To limit the risks of overflow, */
11225 /*     the term of the strongest absolute value is factorized : */
11226 /*                                _______________________ */
11227 /*                  Z = !V(1)! * V  1 + (V(2)/V(1))**2 + ... */
11228
11229 /* > */
11230 /* ***********************************************************************
11231  */
11232 /*                      DECLARATIONS */
11233 /* ***********************************************************************
11234  */
11235
11236
11237 /* ***********************************************************************
11238  */
11239 /*                     PROCESSING */
11240 /* ***********************************************************************
11241  */
11242
11243 /* ___ Find the strongest absolute value term */
11244
11245     /* Parameter adjustments */
11246     --vecteu;
11247
11248     /* Function Body */
11249     irmax = 1;
11250     i__1 = *ndimen;
11251     for (i__ = 2; i__ <= i__1; ++i__) {
11252         if ((d__1 = vecteu[irmax], advapp_abs(d__1)) < (d__2 = vecteu[i__], advapp_abs(d__2)
11253                 )) {
11254             irmax = i__;
11255         }
11256 /* L100: */
11257     }
11258
11259 /* ___ Calculate the norme */
11260
11261     if ((d__1 = vecteu[irmax], advapp_abs(d__1)) < 1.) {
11262         xsom = 0.;
11263         i__1 = *ndimen;
11264         for (i__ = 1; i__ <= i__1; ++i__) {
11265 /* Computing 2nd power */
11266             d__1 = vecteu[i__];
11267             xsom += d__1 * d__1;
11268 /* L200: */
11269         }
11270         ret_val = sqrt(xsom);
11271     } else {
11272         xsom = 0.;
11273         i__1 = *ndimen;
11274         for (i__ = 1; i__ <= i__1; ++i__) {
11275             if (i__ == irmax) {
11276                 xsom += 1.;
11277             } else {
11278 /* Computing 2nd power */
11279                 d__1 = vecteu[i__] / vecteu[irmax];
11280                 xsom += d__1 * d__1;
11281             }
11282 /* L300: */
11283         }
11284         ret_val = (d__1 = vecteu[irmax], advapp_abs(d__1)) * sqrt(xsom);
11285     }
11286
11287 /* ***********************************************************************
11288  */
11289 /*                   RETURN CALLING PROGRAM */
11290 /* ***********************************************************************
11291  */
11292
11293     return ret_val;
11294 } /* mzsnorm_ */
11295