lili/OCCT
1
0
Fork 0
mirror of https://github.com/Open-Cascade-SAS/OCCT.git synced 2026-08-24 19:36:05 +08:00
Code Issues Packages Projects Releases Wiki Activity
Files
07e6d8d40e387ea3026c0d24df0742edcdf99de4
OCCT/src/ModelingData/TKGeomBase/AdvApp2Var/AdvApp2Var_ApproxF2var.cxx
T

8793 lines
294 KiB
C++
Raw Blame History

// Copyright (c) 1999-2014 OPEN CASCADE SAS
//
// This file is part of Open CASCADE Technology software library.
//
// This library is free software; you can redistribute it and/or modify it under
// the terms of the GNU Lesser General Public License version 2.1 as published
// by the Free Software Foundation, with special exception defined in the file
// OCCT_LGPL_EXCEPTION.txt. Consult the file LICENSE_LGPL_21.txt included in OCCT
// distribution for complete text of the license and disclaimer of any warranty.
//
// Alternatively, this file may be used under the terms of Open CASCADE
// commercial license or contractual agreement.
#include <AdvApp2Var_SysBase.hxx>
#include <AdvApp2Var_MathBase.hxx>
#include "AdvApp2Var_Data.pxx"
#include <AdvApp2Var_ApproxF2var.hxx>
#include <algorithm>
#include <cmath>
static int mmjacpt_(const int* ndimen,
const int* ncoefu,
const int* ncoefv,
const int* iordru,
const int* iordrv,
const double* ptclgd,
double* ptcaux,
double* ptccan);
static int mma2ce2_(int* numdec,
int* ndimen,
int* nbsesp,
int* ndimse,
int* ndminu,
int* ndminv,
int* ndguli,
int* ndgvli,
int* ndjacu,
int* ndjacv,
int* iordru,
int* iordrv,
int* nbpntu,
int* nbpntv,
double* epsapr,
double* sosotb,
double* disotb,
double* soditb,
double* diditb,
double* gssutb,
double* gssvtb,
double* xmaxju,
double* xmaxjv,
double* vecerr,
double* chpair,
double* chimpr,
double* patjac,
double* errmax,
double* errmoy,
int* ndegpu,
int* ndegpv,
int* itydec,
int* iercod);
static int mma2cfu_(int* ndujac,
int* nbpntu,
int* nbpntv,
double* sosotb,
double* disotb,
double* soditb,
double* diditb,
double* gssutb,
double* chpair,
double* chimpr);
static int mma2cfv_(int* ndvjac,
int* mindgu,
int* maxdgu,
int* nbpntv,
double* gssvtb,
double* chpair,
double* chimpr,
double* patjac);
static int mma2er1_(int* ndjacu,
int* ndjacv,
int* ndimen,
int* mindgu,
int* maxdgu,
int* mindgv,
int* maxdgv,
int* iordru,
int* iordrv,
double* xmaxju,
double* xmaxjv,
double* patjac,
double* vecerr,
double* erreur);
static int mma2er2_(int* ndjacu,
int* ndjacv,
int* ndimen,
int* mindgu,
int* maxdgu,
int* mindgv,
int* maxdgv,
int* iordru,
int* iordrv,
double* xmaxju,
double* xmaxjv,
double* patjac,
double* epmscut,
double* vecerr,
double* erreur,
int* newdgu,
int* newdgv);
static int mma2moy_(int* ndgumx,
int* ndgvmx,
int* ndimen,
int* mindgu,
int* maxdgu,
int* mindgv,
int* maxdgv,
int* iordru,
int* iordrv,
double* patjac,
double* errmoy);
static int mma2ds2_(int* ndimen,
double* uintfn,
double* vintfn,
const AdvApp2Var_EvaluatorFunc2Var& foncnp,
int* nbpntu,
int* nbpntv,
double* urootb,
double* vrootb,
int* iiuouv,
double* sosotb,
double* disotb,
double* soditb,
double* diditb,
double* fpntab,
double* ttable,
int* iercod);
static int mma1fdi_(int* ndimen,
double* uvfonc,
const AdvApp2Var_EvaluatorFunc2Var& foncnp,
int* isofav,
double* tconst,
int* nbroot,
double* ttable,
int* iordre,
int* ideriv,
double* fpntab,
double* somtab,
double* diftab,
double* contr1,
double* contr2,
int* iercod);
static int mma1cdi_(int* ndimen,
int* nbroot,
double* rootlg,
int* iordre,
double* contr1,
double* contr2,
double* somtab,
double* diftab,
double* fpntab,
double* hermit,
int* iercod);
static int mma1jak_(int* ndimen,
int* nbroot,
int* iordre,
int* ndgjac,
double* somtab,
double* diftab,
double* cgauss,
double* crvjac,
int* iercod);
static int mma1cnt_(int* ndimen,
int* iordre,
double* contr1,
double* contr2,
double* hermit,
int* ndgjac,
double* crvjac);
static int mma1fer_(int* ndimen,
int* nbsesp,
int* ndimse,
int* iordre,
int* ndgjac,
double* crvjac,
int* ncflim,
double* epsapr,
double* ycvmax,
double* errmax,
double* errmoy,
int* ncoeff,
int* iercod);
static int mma1noc_(double* dfuvin,
int* ndimen,
int* iordre,
double* cntrin,
double* duvout,
int* isofav,
int* ideriv,
double* cntout);
static int mmmapcoe_(int* ndim,
int* ndgjac,
int* iordre,
int* nbpnts,
double* somtab,
double* diftab,
double* gsstab,
double* crvjac);
static int mmaperm_(int* ncofmx,
int* ndim,
int* ncoeff,
int* iordre,
double* crvjac,
int* ncfnew,
double* errmoy);
//=================================================================================================
int mma1cdi_(int* ndimen,
int* nbroot,
double* rootlg,
int* iordre,
double* contr1,
double* contr2,
double* somtab,
double* diftab,
double* fpntab,
double* hermit,
int* iercod)
{
int c__1 = 1;
/* System generated locals */
int contr1_dim1, contr1_offset, contr2_dim1, contr2_offset, somtab_dim1, somtab_offset,
diftab_dim1, diftab_offset, fpntab_dim1, fpntab_offset, hermit_dim1, hermit_offset, i__1, i__2,
i__3;
/* Local variables */
int nroo2, ncfhe, nd, ii, kk;
int ibb, kkm, kkp;
double bid1, bid2, bid3 = 0.;
/* **********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* Discretisation on the parameters of interpolation polynomes */
/* constraints of order IORDRE. */
/* KEYWORDS : */
/* ----------- */
/* ALL, AB_SPECIFI::CONTRAINTE&, DISCRETISATION, &POINT */
/* INPUT ARGUMENTS : */
/* ------------------ */
/* NDIMEN: Space dimension. */
/* NBROOT: Number of INTERNAL discretisation parameters. */
/* It is also the root number Legendre polynome where */
/* the discretization is performed. */
/* ROOTLG: Table of discretization parameters ON (-1,1). */
/* IORDRE: Order of constraint imposed to the extremities of the iso. */
/* = 0, the extremities of the iso are calculated */
/* = 1, additionally, the 1st derivative in the direction */
/* of the iso is calculated. */
/* = 2, additionally, the 2nd derivative in the direction */
/* of the iso is calculated. */
/* CONTR1: Contains, if IORDRE>=0, values IORDRE+1 in TTABLE(0)
*/
/* (1st extremity) of derivatives of F(Uc,Ve) or F(Ue,Vc), */
/* see below. */
/* CONTR2: Contains, if IORDRE>=0, values IORDRE+1 in */
/* TTABLE(NBROOT+1) (2nd extremity) of: */
/* If ISOFAV=1, derived of order IDERIV by U, derived */
/* ordre 0 to IORDRE by V of F(Uc,Ve) or Uc=TCONST */
/* (fixed iso value) and Ve is the fixed extremity. */
/* If ISOFAV=2, derivative of order IDERIV by V, derivative */
/* of order 0 to IORDRE by U of F(Ue,Vc) or Vc=TCONST */
/* (fixed iso value) and Ue is the fixed extremity. */
/* SOMTAB: Table of NBROOT/2 sums of 2 index points */
/* NBROOT-II+1 and II, for II = 1, NBROOT/2. */
/* DIFTAB: Table of NBROOT/2 differences of 2 index points */
/* NBROOT-II+1 and II, for II = 1, NBROOT/2. */
/* OUTPUT ARGUMENTS : */
/* ------------------- */
/* SOMTAB: Table of NBROOT/2 sums of 2 index points */
/* NBROOT-II+1 and II, for II = 1, NBROOT/2 */
/* DIFTAB: Table of NBROOT/2 differences of 2 index points */
/* NBROOT-II+1 and II, for II = 1, NBROOT/2 */
/* FPNTAB: Auxiliary table. */
/* HERMIT: Table of coeff. 2*(IORDRE+1) Hermite polynoms */
/* of degree 2*IORDRE+1. */
/* IERCOD: Error code, */
/* = 0, Everything is OK */
/* = 1, The value of IORDRE is out of (0,2) */
/* COMMON USED : */
/* ---------------- */
/* REFERENCES CALLED : */
/* ----------------------- */
/* DESCRIPTION/NOTES/LIMITATIONS : */
/* ----------------------------------- */
/* The results of discretization are arranged in 2 tables */
/* SOMTAB and DIFTAB to earn time during the */
/* calculation of coefficients of the approximation curve. */
/* If NBROOT is uneven in SOMTAB(0,*) and DIFTAB(0,*) one stores */
/* the values of the median root of Legendre (0.D0 in (-1,1)). */
/* **********************************************************************
*/
/* Name of the routine */
/* Parameter adjustments */
diftab_dim1 = *nbroot / 2 + 1;
diftab_offset = diftab_dim1;
diftab -= diftab_offset;
somtab_dim1 = *nbroot / 2 + 1;
somtab_offset = somtab_dim1;
somtab -= somtab_offset;
--rootlg;
hermit_dim1 = (*iordre << 1) + 2;
hermit_offset = hermit_dim1;
hermit -= hermit_offset;
fpntab_dim1 = *nbroot;
fpntab_offset = fpntab_dim1 + 1;
fpntab -= fpntab_offset;
contr2_dim1 = *ndimen;
contr2_offset = contr2_dim1 + 1;
contr2 -= contr2_offset;
contr1_dim1 = *ndimen;
contr1_offset = contr1_dim1 + 1;
contr1 -= contr1_offset;
/* Function Body */
ibb = AdvApp2Var_SysBase::mnfndeb_();
if (ibb >= 3)
{
AdvApp2Var_SysBase::mgenmsg_("MMA1CDI", 7L);
}
*iercod = 0;
/* --- Recuperate 2*(IORDRE+1) coeff of 2*(IORDRE+1) of Hermite polynom ---
*/
AdvApp2Var_ApproxF2var::mma1her_(iordre, &hermit[hermit_offset], iercod);
if (*iercod > 0)
{
goto L9100;
}
/* ------------------- Discretization of Hermite polynoms -----------
*/
ncfhe = (*iordre + 1) << 1;
i__1 = ncfhe;
for (ii = 1; ii <= i__1; ++ii)
{
i__2 = *nbroot;
for (kk = 1; kk <= i__2; ++kk)
{
AdvApp2Var_MathBase::mmmpocur_(&ncfhe,
&c__1,
&ncfhe,
&hermit[ii * hermit_dim1],
&rootlg[kk],
&fpntab[kk + ii * fpntab_dim1]);
/* L200: */
}
/* L100: */
}
/* ---- Discretizations of boundary polynoms are taken ----
*/
nroo2 = *nbroot / 2;
i__1 = *ndimen;
for (nd = 1; nd <= i__1; ++nd)
{
i__2 = *iordre + 1;
for (ii = 1; ii <= i__2; ++ii)
{
bid1 = contr1[nd + ii * contr1_dim1];
bid2 = contr2[nd + ii * contr2_dim1];
i__3 = nroo2;
for (kk = 1; kk <= i__3; ++kk)
{
kkm = nroo2 - kk + 1;
bid3 = bid1 * fpntab[kkm + ((ii << 1) - 1) * fpntab_dim1]
+ bid2 * fpntab[kkm + (ii << 1) * fpntab_dim1];
somtab[kk + nd * somtab_dim1] -= bid3;
diftab[kk + nd * diftab_dim1] += bid3;
/* L500: */
}
i__3 = nroo2;
for (kk = 1; kk <= i__3; ++kk)
{
kkp = (*nbroot + 1) / 2 + kk;
bid3 = bid1 * fpntab[kkp + ((ii << 1) - 1) * fpntab_dim1]
+ bid2 * fpntab[kkp + (ii << 1) * fpntab_dim1];
somtab[kk + nd * somtab_dim1] -= bid3;
diftab[kk + nd * diftab_dim1] -= bid3;
/* L600: */
}
/* L400: */
}
/* L300: */
}
/* ------------ Cas when discretization is done on the roots of a -----------
*/
/* ---------- Legendre polynom of uneven degree, 0 is root --------
*/
if (*nbroot % 2 == 1)
{
i__1 = *ndimen;
for (nd = 1; nd <= i__1; ++nd)
{
i__2 = *iordre + 1;
for (ii = 1; ii <= i__2; ++ii)
{
bid3 = fpntab[nroo2 + 1 + ((ii << 1) - 1) * fpntab_dim1] * contr1[nd + ii * contr1_dim1]
+ fpntab[nroo2 + 1 + (ii << 1) * fpntab_dim1] * contr2[nd + ii * contr2_dim1];
/* L800: */
}
somtab[nd * somtab_dim1] -= bid3;
diftab[nd * diftab_dim1] -= bid3;
/* L700: */
}
}
goto L9999;
/* ------------------------------ The End -------------------------------
*/
/* --> IORDRE is not in the authorized zone. */
L9100:
*iercod = 1;
goto L9999;
L9999:
if (ibb >= 3)
{
AdvApp2Var_SysBase::mgsomsg_("MMA1CDI", 7L);
}
return 0;
} /* mma1cdi_ */
//=================================================================================================
int mma1cnt_(int* ndimen,
int* iordre,
double* contr1,
double* contr2,
double* hermit,
int* ndgjac,
double* crvjac)
{
/* System generated locals */
int contr1_dim1, contr1_offset, contr2_dim1, contr2_offset, hermit_dim1, hermit_offset,
crvjac_dim1, crvjac_offset, i__1, i__2, i__3;
/* Local variables */
int nd, ii, jj, ibb;
double bid;
/* ***********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* Add constraint to polynom. */
/* MOTS CLES : */
/* ----------- */
/* ALL,AB_SPECIFI::COURE&,APPROXIMATION,ADDITION,&CONSTRAINT */
/* INPUT ARGUMENTS : */
/* -------------------- */
/* NDIMEN: Dimension of the space */
/* IORDRE: Order of constraint. */
/* CONTR1: pt of constraint in -1, from order 0 to IORDRE. */
/* CONTR2: Pt of constraint in +1, from order 0 to IORDRE. */
/* HERMIT: Table of Hermit polynoms of order IORDRE. */
/* CRVJAV: Curve of approximation in Jacobi base. */
/* OUTPUT ARGUMENTS : */
/* --------------------- */
/* CRVJAV: Curve of approximation in Jacobi base */
/* to which the polynom of interpolation of constraints is added. */
/* COMMON USED : */
/* ------------------ */
/* REFERENCES CALLED : */
/* --------------------- */
/* DESCRIPTION/NOTES/LIMITATIONS : */
/* ----------------------------------- */
/* > */
/* ***********************************************************************
*/
/* DECLARATIONS */
/* ***********************************************************************
*/
/* Name of the routine */
/* ***********************************************************************
*/
/* INITIALISATIONS */
/* ***********************************************************************
*/
/* Parameter adjustments */
hermit_dim1 = (*iordre << 1) + 2;
hermit_offset = hermit_dim1;
hermit -= hermit_offset;
contr2_dim1 = *ndimen;
contr2_offset = contr2_dim1 + 1;
contr2 -= contr2_offset;
contr1_dim1 = *ndimen;
contr1_offset = contr1_dim1 + 1;
contr1 -= contr1_offset;
crvjac_dim1 = *ndgjac + 1;
crvjac_offset = crvjac_dim1;
crvjac -= crvjac_offset;
/* Function Body */
ibb = AdvApp2Var_SysBase::mnfndeb_();
if (ibb >= 3)
{
AdvApp2Var_SysBase::mgenmsg_("MMA1CNT", 7L);
}
/* ***********************************************************************
*/
/* Processing */
/* ***********************************************************************
*/
i__1 = *ndimen;
for (nd = 1; nd <= i__1; ++nd)
{
i__2 = (*iordre << 1) + 1;
for (ii = 0; ii <= i__2; ++ii)
{
bid = 0.;
i__3 = *iordre + 1;
for (jj = 1; jj <= i__3; ++jj)
{
bid = bid + contr1[nd + jj * contr1_dim1] * hermit[ii + ((jj << 1) - 1) * hermit_dim1]
+ contr2[nd + jj * contr2_dim1] * hermit[ii + (jj << 1) * hermit_dim1];
/* L300: */
}
crvjac[ii + nd * crvjac_dim1] = bid;
/* L200: */
}
/* L100: */
}
/* ***********************************************************************
*/
/* RETURN CALLING PROGRAM */
/* ***********************************************************************
*/
if (ibb >= 3)
{
AdvApp2Var_SysBase::mgsomsg_("MMA1CNT", 7L);
}
return 0;
} /* mma1cnt_ */
//=================================================================================================
int mma1fdi_(int* ndimen,
double* uvfonc,
const AdvApp2Var_EvaluatorFunc2Var& foncnp,
int* isofav,
double* tconst,
int* nbroot,
double* ttable,
int* iordre,
int* ideriv,
double* fpntab,
double* somtab,
double* diftab,
double* contr1,
double* contr2,
int* iercod)
{
/* System generated locals */
int fpntab_dim1, somtab_dim1, somtab_offset, diftab_dim1, diftab_offset, contr1_dim1,
contr1_offset, contr2_dim1, contr2_offset, i__1, i__2;
double d__1;
/* Local variables */
int ideb, ifin, nroo2, ideru, iderv;
double renor;
int ii, nd, ibb, iim, nbp, iip;
double bid1, bid2;
/* **********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* DiscretiZation of a non-polynomial function F(U,V) or of */
/* its derivative with fixed isoparameter. */
/* KEYWORDS : */
/* ----------- */
/* ALL, AB_SPECIFI::FONCTION&, DISCRETISATION, &POINT */
/* INPUT ARGUMENTS : */
/* ------------------ */
/* NDIMEN: Space dimension. */
/* UVFONC: Limits of the path of definition by U and by V of the approximated function */
/* FONCNP: The NAME of the non-polynomial function to be approximated */
/* (external program). */
/* ISOFAV: Fixed isoparameter for the discretization; */
/* = 1, discretization with fixed U and variable V. */
/* = 2, discretization with fixed V and variable U. */
/* TCONST: Iso value is also fixed. */
/* NBROOT: Number of INTERNAL discretization parameters. */
/* (if there are constraints, 2 extremities should be added).
*/
/* This is also the root number of the Legendre polynom where */
/* the discretization is done. */
/* TTABLE: Table of discretization parameters and of 2 extremities */
/* (Respectively (-1, NBROOT Legendre roots,1) */
/* reframed within the adequate interval. */
/* IORDRE: Order of constraint imposed on the extremities of the iso. */
/* (If Iso-U, it is necessary to calculate the derivatives by V and vice */
/* versa). */
/* = 0, the extremities of the iso are calculated. */
/* = 1, additionally the 1st derivative in the direction of the iso is calculated */
/* = 2, additionally the 2nd derivative in the direction of the iso is calculated */
/* IDERIV: Order of derivative transversal to fixed iso (If Iso-U=Uc */
/* is fixed, the derivative of order IDERIV is discretized by U of */
/* F(Uc,v). Same if iso-V is fixed). */
/* Varies from 0 (positioning) to 2 (2nd derivative). */
/* OUTPUT ARGUMENTS : */
/* ------------------- */
/* FPNTAB: Auxiliary table.
SOMTAB: Table of NBROOT/2 sums of 2 index points */
/* NBROOT-II+1 and II, for II = 1, NBROOT/2 */
/* DIFTAB: Table of NBROOT/2 differences of 2 index points */
/* NBROOT-II+1 and II, for II = 1, NBROOT/2 */
/* CONTR1: Contains, if IORDRE>=0, values IORDRE+1 in TTABLE(0)
*/
/* (1st extremity) of derivatives of F(Uc,Ve) or F(Ue,Vc), */
/* see below. */
/* CONTR2: Contains, if IORDRE>=0, values IORDRE+1 in */
/* TTABLE(NBROOT+1) (2nd extremity) of: */
/* If ISOFAV=1, derived of order IDERIV by U, derived */
/* ordre 0 to IORDRE by V of F(Uc,Ve) or Uc=TCONST */
/* (fixed iso value) and Ve is the fixed extremity. */
/* If ISOFAV=2, derivative of order IDERIV by V, derivative */
/* of order 0 to IORDRE by U of F(Ue,Vc) or Vc=TCONST */
/* (fixed iso value) and Ue is the fixed extremity. */
/* IERCOD: Error code > 100; Pb in evaluation of FONCNP, */
/* the returned error code is equal to error code of FONCNP + 100. */
/* COMMONS USED : */
/* ---------------- */
/* REFERENCES CALLED : */
/* ----------------------- */
/* DESCRIPTION/NOTES/LIMITATIONS : */
/* ----------------------------------- */
/* The results of discretization are arranged in 2 tables */
/* SOMTAB and DIFTAB to earn time during the */
/* calculation of coefficients of the approximation curve. */
/* If NBROOT is uneven in SOMTAB(0,*) and DIFTAB(0,*) one stores */
/* the values of the median root of Legendre (0.D0 in (-1,1)). */
/* Function F(u,v) defined in UVFONC is reparameterized in */
/* (-1,1)x(-1,1). Then 1st and 2nd derivatives are renormalized. */
/* > */
/* **********************************************************************
*/
/* Name of the routine */
/* Parameter adjustments */
diftab_dim1 = *nbroot / 2 + 1;
diftab_offset = diftab_dim1;
diftab -= diftab_offset;
somtab_dim1 = *nbroot / 2 + 1;
somtab_offset = somtab_dim1;
somtab -= somtab_offset;
fpntab_dim1 = *ndimen;
--fpntab;
contr2_dim1 = *ndimen;
contr2_offset = contr2_dim1 + 1;
contr2 -= contr2_offset;
contr1_dim1 = *ndimen;
contr1_offset = contr1_dim1 + 1;
contr1 -= contr1_offset;
/* Function Body */
ibb = AdvApp2Var_SysBase::mnfndeb_();
if (ibb >= 3)
{
AdvApp2Var_SysBase::mgenmsg_("MMA1FDI", 7L);
}
*iercod = 0;
/* --------------- Definition of the nb of points to calculate --------------
*/
/* --> If constraints, the limits are also taken */
if (*iordre >= 0)
{
ideb = 0;
ifin = *nbroot + 1;
/* --> Otherwise, only Legendre roots (reframed) are used
. */
}
else
{
ideb = 1;
ifin = *nbroot;
}
/* --> Nb of point to calculate. */
nbp = ifin - ideb + 1;
nroo2 = *nbroot / 2;
/* --------------- Determination of the order of global derivation --------
*/
/* --> ISOFAV takes only values 1 or 2. */
/* if Iso-U, derive by U of order IDERIV */
if (*isofav == 1)
{
ideru = *ideriv;
iderv = 0;
d__1 = (uvfonc[1] - uvfonc[0]) / 2.;
renor = AdvApp2Var_MathBase::pow__di(&d__1, ideriv);
/* if Iso-V, derive by V of order IDERIV */
}
else
{
ideru = 0;
iderv = *ideriv;
d__1 = (uvfonc[3] - uvfonc[2]) / 2.;
renor = AdvApp2Var_MathBase::pow__di(&d__1, ideriv);
}
/* ----------- Discretization on roots of the ---------------
*/
/* ---------------------- Legendre polynom of degree NBROOT -------------------
*/
(*const_cast<AdvApp2Var_EvaluatorFunc2Var*>(&foncnp))
.Evaluate(ndimen,
&uvfonc[0],
&uvfonc[2],
isofav,
tconst,
&nbp,
&ttable[ideb],
&ideru,
&iderv,
&fpntab[ideb * fpntab_dim1 + 1],
iercod);
if (*iercod > 0)
{
goto L9999;
}
i__1 = *ndimen;
for (nd = 1; nd <= i__1; ++nd)
{
i__2 = nroo2;
for (ii = 1; ii <= i__2; ++ii)
{
iip = (*nbroot + 1) / 2 + ii;
iim = nroo2 - ii + 1;
bid1 = fpntab[nd + iim * fpntab_dim1];
bid2 = fpntab[nd + iip * fpntab_dim1];
somtab[ii + nd * somtab_dim1] = renor * (bid2 + bid1);
diftab[ii + nd * diftab_dim1] = renor * (bid2 - bid1);
/* L200: */
}
/* L100: */
}
/* ------------ Case when discretisation is done on roots of a ----
*/
/* ---------- Legendre polynom of uneven degree, 0 is root --------
*/
if (*nbroot % 2 == 1)
{
i__1 = *ndimen;
for (nd = 1; nd <= i__1; ++nd)
{
somtab[nd * somtab_dim1] = renor * fpntab[nd + (nroo2 + 1) * fpntab_dim1];
diftab[nd * diftab_dim1] = renor * fpntab[nd + (nroo2 + 1) * fpntab_dim1];
/* L300: */
}
}
else
{
i__1 = *ndimen;
for (nd = 1; nd <= i__1; ++nd)
{
somtab[nd * somtab_dim1] = 0.;
diftab[nd * diftab_dim1] = 0.;
}
}
/* --------------------- Take into account constraints ----------------
*/
if (*iordre >= 0)
{
/* --> Recover already calculated extremities. */
i__1 = *ndimen;
for (nd = 1; nd <= i__1; ++nd)
{
contr1[nd + contr1_dim1] = renor * fpntab[nd];
contr2[nd + contr2_dim1] = renor * fpntab[nd + (*nbroot + 1) * fpntab_dim1];
/* L400: */
}
/* --> Nb of points to calculate/call to FONCNP */
nbp = 1;
/* If Iso-U, derive by V till order IORDRE */
if (*isofav == 1)
{
/* --> Factor of normalisation 1st derivative. */
bid1 = (uvfonc[3] - uvfonc[2]) / 2.;
i__1 = *iordre;
for (iderv = 1; iderv <= i__1; ++iderv)
{
(*const_cast<AdvApp2Var_EvaluatorFunc2Var*>(&foncnp))
.Evaluate(ndimen,
&uvfonc[0],
&uvfonc[2],
isofav,
tconst,
&nbp,
ttable,
&ideru,
&iderv,
&contr1[(iderv + 1) * contr1_dim1 + 1],
iercod);
if (*iercod > 0)
{
goto L9999;
}
/* L500: */
}
i__1 = *iordre;
for (iderv = 1; iderv <= i__1; ++iderv)
{
(*const_cast<AdvApp2Var_EvaluatorFunc2Var*>(&foncnp))
.Evaluate(ndimen,
&uvfonc[0],
&uvfonc[2],
isofav,
tconst,
&nbp,
&ttable[*nbroot + 1],
&ideru,
&iderv,
&contr2[(iderv + 1) * contr2_dim1 + 1],
iercod);
if (*iercod > 0)
{
goto L9999;
}
/* L510: */
}
/* If Iso-V, derive by U till order IORDRE */
}
else
{
/* --> Factor of normalization 1st derivative. */
bid1 = (uvfonc[1] - uvfonc[0]) / 2.;
i__1 = *iordre;
for (ideru = 1; ideru <= i__1; ++ideru)
{
(*const_cast<AdvApp2Var_EvaluatorFunc2Var*>(&foncnp))
.Evaluate(ndimen,
&uvfonc[0],
&uvfonc[2],
isofav,
tconst,
&nbp,
ttable,
&ideru,
&iderv,
&contr1[(ideru + 1) * contr1_dim1 + 1],
iercod);
if (*iercod > 0)
{
goto L9999;
}
/* L600: */
}
i__1 = *iordre;
for (ideru = 1; ideru <= i__1; ++ideru)
{
(*const_cast<AdvApp2Var_EvaluatorFunc2Var*>(&foncnp))
.Evaluate(ndimen,
&uvfonc[0],
&uvfonc[2],
isofav,
tconst,
&nbp,
&ttable[*nbroot + 1],
&ideru,
&iderv,
&contr2[(ideru + 1) * contr2_dim1 + 1],
iercod);
if (*iercod > 0)
{
goto L9999;
}
/* L610: */
}
}
/* ------------------------- Normalization of derivatives -------------
---- */
/* (The function is redefined on (-1,1)*(-1,1)) */
bid2 = renor;
i__1 = *iordre;
for (ii = 1; ii <= i__1; ++ii)
{
bid2 = bid1 * bid2;
i__2 = *ndimen;
for (nd = 1; nd <= i__2; ++nd)
{
contr1[nd + (ii + 1) * contr1_dim1] *= bid2;
contr2[nd + (ii + 1) * contr2_dim1] *= bid2;
/* L710: */
}
/* L700: */
}
}
/* ------------------------------ The end -------------------------------
*/
L9999:
if (*iercod > 0)
{
*iercod += 100;
AdvApp2Var_SysBase::maermsg_("MMA1FDI", iercod, 7L);
}
if (ibb >= 3)
{
AdvApp2Var_SysBase::mgsomsg_("MMA1FDI", 7L);
}
return 0;
} /* mma1fdi_ */
//=================================================================================================
int mma1fer_(int*, // ndimen,
int* nbsesp,
int* ndimse,
int* iordre,
int* ndgjac,
double* crvjac,
int* ncflim,
double* epsapr,
double* ycvmax,
double* errmax,
double* errmoy,
int* ncoeff,
int* iercod)
{
/* System generated locals */
int crvjac_dim1, crvjac_offset, i__1, i__2;
/* Local variables */
int idim, ncfja, ncfnw, ndses, ii, kk, ibb, ier;
int nbr0;
/* ***********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* Calculate the degree and the errors of approximation of a border. */
/* KEYWORDS : */
/* ----------- */
/* TOUS,AB_SPECIFI :: COURBE&,TRONCATURE, &PRECISION */
/* INPUT ARGUMENTS : */
/* -------------------- */
/* NDIMEN: Total Dimension of the space (sum of dimensions of sub-spaces) */
/* NBSESP: Number of "independent" sub-spaces. */
/* NDIMSE: Table of dimensions of sub-spaces. */
/* IORDRE: Order of constraint at the extremities of the border */
/* -1 = no constraints, */
/* 0 = constraints of passage to limits (i.e. C0), */
/* 1 = C0 + constraints of 1st derivatives (i.e. C1), */
/* 2 = C1 + constraints of 2nd derivatives (i.e. C2). */
/* NDGJAC: Degree of development in series to use for the calculation */
/* in the base of Jacobi. */
/* CRVJAC: Table of coeff. of the curve of approximation in the */
/* base of Jacobi. */
/* NCFLIM: Max number of coeff of the polynomial curve */
/* of approximation (should be above or equal to */
/* 2*IORDRE+2 and below or equal to 50). */
/* EPSAPR: Table of errors of approximations that cannot be passed, */
/* sub-space by sub-space. */
/* OUTPUT ARGUMENTS : */
/* --------------------- */
/* YCVMAX: Auxiliary Table. */
/* ERRMAX: Table of errors (sub-space by sub-space) */
/* MAXIMUM made in the approximation of FONCNP by */
/* COURBE. */
/* ERRMOY: Table of errors (sub-space by sub-space) */
/* AVERAGE made in the approximation of FONCNP by */
/* COURBE. */
/* NCOEFF: Number of significative coeffs. of the calculated "curve". */
/* IERCOD: Error code */
/* = 0, ok, */
/* =-1, warning, required tolerance can't be */
/* met with coefficients NFCLIM. */
/* = 1, order of constraints (IORDRE) is not within authorised values */
/* COMMONS USED : */
/* ------------------ */
/* REFERENCES CALLED : */
/* --------------------- */
/* DESCRIPTION/NOTES/LIMITATIONS : */
/* ----------------------------------- */
/* > */
/* **********************************************************************
*/
/* Name of the routine */
/* Parameter adjustments */
--ycvmax;
--errmoy;
--errmax;
--epsapr;
--ndimse;
crvjac_dim1 = *ndgjac + 1;
crvjac_offset = crvjac_dim1;
crvjac -= crvjac_offset;
/* Function Body */
ibb = AdvApp2Var_SysBase::mnfndeb_();
if (ibb >= 3)
{
AdvApp2Var_SysBase::mgenmsg_("MMA1FER", 7L);
}
*iercod = 0;
idim = 1;
*ncoeff = 0;
ncfja = *ndgjac + 1;
/* ------------ Calculate the degree of the curve and of the Max error --------
*/
/* -------------- of approximation for all sub-spaces --------
*/
i__1 = *nbsesp;
for (ii = 1; ii <= i__1; ++ii)
{
ndses = ndimse[ii];
/* ------------ cutting of coeff. and calculation of Max error -------
---- */
AdvApp2Var_MathBase::mmtrpjj_(&ncfja,
&ndses,
&ncfja,
&epsapr[ii],
iordre,
&crvjac[idim * crvjac_dim1],
&ycvmax[1],
&errmax[ii],
&ncfnw);
/* ******************************************************************
**** */
/* ------------- If precision OK, calculate the average error -------
---- */
/* ******************************************************************
**** */
if (ncfnw <= *ncflim)
{
mmaperm_(&ncfja, &ndses, &ncfja, iordre, &crvjac[idim * crvjac_dim1], &ncfnw, &errmoy[ii]);
*ncoeff = std::max(ncfnw, *ncoeff);
/* ------------- Set the declined coefficients to 0.D0 -----------
-------- */
nbr0 = *ncflim - ncfnw;
if (nbr0 > 0)
{
i__2 = ndses;
for (kk = 1; kk <= i__2; ++kk)
{
AdvApp2Var_SysBase::mvriraz_(&nbr0, &crvjac[ncfnw + (idim + kk - 1) * crvjac_dim1]);
/* L200: */
}
}
}
else
{
/* **************************************************************
******** */
/* ------------------- If required precision can't be reached----
-------- */
/* **************************************************************
******** */
*iercod = -1;
/* ------------------------- calculate the Max error ------------
-------- */
AdvApp2Var_MathBase::mmaperx_(&ncfja,
&ndses,
&ncfja,
iordre,
&crvjac[idim * crvjac_dim1],
ncflim,
&ycvmax[1],
&errmax[ii],
&ier);
if (ier > 0)
{
goto L9100;
}
/* -------------------- nb of coeff to be returned -------------
-------- */
*ncoeff = *ncflim;
/* ------------------- and calculation of the average error ----
-------- */
mmaperm_(&ncfja, &ndses, &ncfja, iordre, &crvjac[idim * crvjac_dim1], ncflim, &errmoy[ii]);
}
idim += ndses;
/* L100: */
}
goto L9999;
/* ------------------------------ The end -------------------------------
*/
/* --> The order of constraints is not within authorized values. */
L9100:
*iercod = 1;
goto L9999;
L9999:
if (*iercod != 0)
{
AdvApp2Var_SysBase::maermsg_("MMA1FER", iercod, 7L);
}
if (ibb >= 3)
{
AdvApp2Var_SysBase::mgsomsg_("MMA1FER", 7L);
}
return 0;
} /* mma1fer_ */
//=================================================================================================
int AdvApp2Var_ApproxF2var::mma1her_(const int* iordre, double* hermit, int* iercod)
{
/* System generated locals */
int hermit_dim1, hermit_offset;
/* Local variables */
int ibb;
/* **********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* Calculate 2*(IORDRE+1) Hermit polynoms of degree 2*IORDRE+1 */
/* on (-1,1) */
/* KEYWORDS : */
/* ----------- */
/* ALL, AB_SPECIFI::CONTRAINTE&, INTERPOLATION, &POLYNOME */
/* INPUT ARGUMENTS : */
/* ------------------ */
/* IORDRE: Order of constraint. */
/* = 0, Polynom of interpolation of order C0 on (-1,1). */
/* = 1, Polynom of interpolation of order C0 and C1 on (-1,1). */
/* = 2, Polynom of interpolation of order C0, C1 and C2 on (-1,1).
*/
/* OUTPUT ARGUMENTS : */
/* ------------------- */
/* HERMIT: Table of 2*IORDRE+2 coeff. of each of 2*(IORDRE+1) */
/* HERMIT polynom. */
/* IERCOD: Error code, */
/* = 0, Ok */
/* = 1, required order of constraint is not managed here. */
/* COMMONS USED : */
/* ---------------- */
/* REFERENCES CALLED : */
/* ----------------------- */
/* DESCRIPTION/NOTES/LIMITATIONS : */
/* ----------------------------------- */
/* The part of HERMIT(*,2*i+j) table where j=1 or 2 and i=0 to IORDRE, */
/* contains the coefficients of the polynom of degree 2*IORDRE+1 */
/* such as ALL values in -1 and in +1 of this polynom and its */
/* derivatives till order of derivation IORDRE are NULL, */
/* EXCEPT for the derivative of order i: */
/* - valued 1 in -1 if j=1 */
/* - valued 1 in +1 if j=2. */
/* > */
/* **********************************************************************
*/
/* Name of the routine */
/* Parameter adjustments */
hermit_dim1 = (*iordre + 1) << 1;
hermit_offset = hermit_dim1 + 1;
hermit -= hermit_offset;
/* Function Body */
ibb = AdvApp2Var_SysBase::mnfndeb_();
if (ibb >= 3)
{
AdvApp2Var_SysBase::mgenmsg_("MMA1HER", 7L);
}
*iercod = 0;
/* --- Recover (IORDRE+2) coeff of 2*(IORDRE+1) Hermit polynoms --
*/
if (*iordre == 0)
{
hermit[hermit_dim1 + 1] = .5;
hermit[hermit_dim1 + 2] = -.5;
hermit[(hermit_dim1 << 1) + 1] = .5;
hermit[(hermit_dim1 << 1) + 2] = .5;
}
else if (*iordre == 1)
{
hermit[hermit_dim1 + 1] = .5;
hermit[hermit_dim1 + 2] = -.75;
hermit[hermit_dim1 + 3] = 0.;
hermit[hermit_dim1 + 4] = .25;
hermit[(hermit_dim1 << 1) + 1] = .5;
hermit[(hermit_dim1 << 1) + 2] = .75;
hermit[(hermit_dim1 << 1) + 3] = 0.;
hermit[(hermit_dim1 << 1) + 4] = -.25;
hermit[hermit_dim1 * 3 + 1] = .25;
hermit[hermit_dim1 * 3 + 2] = -.25;
hermit[hermit_dim1 * 3 + 3] = -.25;
hermit[hermit_dim1 * 3 + 4] = .25;
hermit[(hermit_dim1 << 2) + 1] = -.25;
hermit[(hermit_dim1 << 2) + 2] = -.25;
hermit[(hermit_dim1 << 2) + 3] = .25;
hermit[(hermit_dim1 << 2) + 4] = .25;
}
else if (*iordre == 2)
{
hermit[hermit_dim1 + 1] = .5;
hermit[hermit_dim1 + 2] = -.9375;
hermit[hermit_dim1 + 3] = 0.;
hermit[hermit_dim1 + 4] = .625;
hermit[hermit_dim1 + 5] = 0.;
hermit[hermit_dim1 + 6] = -.1875;
hermit[(hermit_dim1 << 1) + 1] = .5;
hermit[(hermit_dim1 << 1) + 2] = .9375;
hermit[(hermit_dim1 << 1) + 3] = 0.;
hermit[(hermit_dim1 << 1) + 4] = -.625;
hermit[(hermit_dim1 << 1) + 5] = 0.;
hermit[(hermit_dim1 << 1) + 6] = .1875;
hermit[hermit_dim1 * 3 + 1] = .3125;
hermit[hermit_dim1 * 3 + 2] = -.4375;
hermit[hermit_dim1 * 3 + 3] = -.375;
hermit[hermit_dim1 * 3 + 4] = .625;
hermit[hermit_dim1 * 3 + 5] = .0625;
hermit[hermit_dim1 * 3 + 6] = -.1875;
hermit[(hermit_dim1 << 2) + 1] = -.3125;
hermit[(hermit_dim1 << 2) + 2] = -.4375;
hermit[(hermit_dim1 << 2) + 3] = .375;
hermit[(hermit_dim1 << 2) + 4] = .625;
hermit[(hermit_dim1 << 2) + 5] = -.0625;
hermit[(hermit_dim1 << 2) + 6] = -.1875;
hermit[hermit_dim1 * 5 + 1] = .0625;
hermit[hermit_dim1 * 5 + 2] = -.0625;
hermit[hermit_dim1 * 5 + 3] = -.125;
hermit[hermit_dim1 * 5 + 4] = .125;
hermit[hermit_dim1 * 5 + 5] = .0625;
hermit[hermit_dim1 * 5 + 6] = -.0625;
hermit[hermit_dim1 * 6 + 1] = .0625;
hermit[hermit_dim1 * 6 + 2] = .0625;
hermit[hermit_dim1 * 6 + 3] = -.125;
hermit[hermit_dim1 * 6 + 4] = -.125;
hermit[hermit_dim1 * 6 + 5] = .0625;
hermit[hermit_dim1 * 6 + 6] = .0625;
}
else
{
*iercod = 1;
}
/* ------------------------------ The End -------------------------------
*/
AdvApp2Var_SysBase::maermsg_("MMA1HER", iercod, 7L);
if (ibb >= 3)
{
AdvApp2Var_SysBase::mgsomsg_("MMA1HER", 7L);
}
return 0;
} /* mma1her_ */
//=================================================================================================
int mma1jak_(int* ndimen,
int* nbroot,
int* iordre,
int* ndgjac,
double* somtab,
double* diftab,
double* cgauss,
double* crvjac,
int* iercod)
{
/* System generated locals */
int somtab_dim1, somtab_offset, diftab_dim1, diftab_offset, crvjac_dim1, crvjac_offset;
/* Local variables */
int ibb;
/* **********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* Calculate the curve of approximation of a non-polynomial function */
/* in the base of Jacobi. */
/* KEYWORDS : */
/* ----------- */
/* FUNCTION,DISCRETISATION,APPROXIMATION,CONSTRAINT,CURVE,JACOBI */
/* INPUT ARGUMENTS : */
/* ------------------ */
/* NDIMEN: Total dimension of the space (sum of dimensions */
/* of sub-spaces) */
/* NBROOT: Nb of points of discretization of the iso, extremities not */
/* included. */
/* IORDRE: Order of constraint at the extremities of the boundary */
/* -1 = no constraints, */
/* 0 = constraints of passage of limits (i.e. C0), */
/* 1 = C0 + constraints of 1st derivatives (i.e. C1), */
/* 2 = C1 + constraints of 2nd derivatives (i.e. C2). */
/* NDGJAC: Degree of development in series to be used for calculation in the */
/* base of Jacobi. */
/* OUTPUT ARGUMENTS : */
/* ------------------- */
/* CRVJAC : Curve of approximation of FONCNP with (eventually) */
/* taking into account of constraints at the extremities. */
/* This curve is of degree NDGJAC. */
/* IERCOD : Error code : */
/* 0 = All is ok. */
/* 33 = Pb to return data of du block data */
/* of coeff. of integration by GAUSS method. */
/* by program MMAPPTT. */
/* COMMONS USED : */
/* ---------------- */
/* REFERENCES CALLED : */
/* ----------------------- */
/* > */
/* **********************************************************************
*/
/* Name of the routine */
/* Parameter adjustments */
diftab_dim1 = *nbroot / 2 + 1;
diftab_offset = diftab_dim1;
diftab -= diftab_offset;
somtab_dim1 = *nbroot / 2 + 1;
somtab_offset = somtab_dim1;
somtab -= somtab_offset;
crvjac_dim1 = *ndgjac + 1;
crvjac_offset = crvjac_dim1;
crvjac -= crvjac_offset;
/* Function Body */
ibb = AdvApp2Var_SysBase::mnfndeb_();
if (ibb >= 2)
{
AdvApp2Var_SysBase::mgenmsg_("MMA1JAK", 7L);
}
*iercod = 0;
/* ----------------- Recover coeffs of integration by Gauss -----------
*/
AdvApp2Var_ApproxF2var::mmapptt_(ndgjac, nbroot, iordre, cgauss, iercod);
if (*iercod > 0)
{
*iercod = 33;
goto L9999;
}
/* --------------- Calculate the curve in the base of Jacobi -----------
*/
mmmapcoe_(ndimen,
ndgjac,
iordre,
nbroot,
&somtab[somtab_offset],
&diftab[diftab_offset],
cgauss,
&crvjac[crvjac_offset]);
/* ------------------------------ The End -------------------------------
*/
L9999:
if (*iercod != 0)
{
AdvApp2Var_SysBase::maermsg_("MMA1JAK", iercod, 7L);
}
if (ibb >= 2)
{
AdvApp2Var_SysBase::mgsomsg_("MMA1JAK", 7L);
}
return 0;
} /* mma1jak_ */
//=================================================================================================
int mma1noc_(double* dfuvin,
int* ndimen,
int* iordre,
double* cntrin,
double* duvout,
int* isofav,
int* ideriv,
double* cntout)
{
/* System generated locals */
int i__1;
double d__1;
/* Local variables */
double rider, riord;
int nd, ibb;
double bid;
/* **********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* Normalization of constraints of derivatives, defined on DFUVIN */
/* on block DUVOUT. */
/* KEYWORDS : */
/* ----------- */
/* ALL, AB_SPECIFI::VECTEUR&,DERIVEE&,NORMALISATION,&VECTEUR */
/* INPUT ARGUMENTS : */
/* ------------------ */
/* DFUVIN: Limits of the block of definition by U and by V where
*/
/* constraints CNTRIN are defined. */
/* NDIMEN: Dimension of the space. */
/* IORDRE: Order of constraint imposed at the extremities of the iso. */
/* (if Iso-U, it is necessary to calculate derivatives by V and vice */
/* versa). */
/* = 0, the extremities of the iso are calculated */
/* = 1, additionally the 1st derivative in the direction */
/* of the iso is calculated */
/* = 2, additionally the 2nd derivative in the direction */
/* of the iso is calculated */
/* CNTRIN: Contains, if IORDRE>=0, IORDRE+1 derivatives */
/* of order IORDRE of F(Uc,v) or of F(u,Vc), following the */
/* value of ISOFAV, RENORMALIZED by u and v in (-1,1). */
/* DUVOUT: Limits of the block of definition by U and by V where the */
/* constraints CNTOUT will be defined. */
/* ISOFAV: Isoparameter fixed for the discretization; */
/* = 1, discretization with fixed U=Uc and variable V. */
/* = 2, discretization with fixed V=Vc and variable U. */
/* IDERIV: Order of transverse derivative to the fixed iso (If Iso-U=Uc */
/* is fixed, the derivative of order IDERIV is discretized by U */
/* of F(Uc,v). The same if iso-V is fixed). */
/* Varies from (positioning) to 2 (2nd derivative). */
/* OUTPUT ARGUMENTS : */
/* ------------------- */
/* CNTOUT: Contains, if IORDRE>=0, IORDRE+1 derivatives */
/* of order IORDRE of F(Uc,v) or of F(u,Vc), depending on the */
/* value of ISOFAV, RENORMALIZED for u and v in DUVOUT. */
/* COMMONS USED : */
/* ---------------- */
/* REFERENCES CALLED : */
/* --------------------- */
/* DESCRIPTION/NOTES/LIMITATIONS : */
/* ------------------------------- */
/* CNTRIN can be an output/input argument, */
/* so the call: */
/* CALL MMA1NOC(DFUVIN,NDIMEN,IORDRE,CNTRIN,DUVOUT */
/* 1 ,ISOFAV,IDERIV,CNTRIN) */
/* is correct. */
/* > */
/* **********************************************************************
*/
/* Name of the routine */
/* Parameter adjustments */
dfuvin -= 3;
--cntout;
--cntrin;
duvout -= 3;
/* Function Body */
ibb = AdvApp2Var_SysBase::mnfndeb_();
if (ibb >= 3)
{
AdvApp2Var_SysBase::mgenmsg_("MMA1NOC", 7L);
}
/* --------------- Determination of coefficients of normalization -------
*/
if (*isofav == 1)
{
d__1 = (dfuvin[4] - dfuvin[3]) / (duvout[4] - duvout[3]);
rider = AdvApp2Var_MathBase::pow__di(&d__1, ideriv);
d__1 = (dfuvin[6] - dfuvin[5]) / (duvout[6] - duvout[5]);
riord = AdvApp2Var_MathBase::pow__di(&d__1, iordre);
}
else
{
d__1 = (dfuvin[6] - dfuvin[5]) / (duvout[6] - duvout[5]);
rider = AdvApp2Var_MathBase::pow__di(&d__1, ideriv);
d__1 = (dfuvin[4] - dfuvin[3]) / (duvout[4] - duvout[3]);
riord = AdvApp2Var_MathBase::pow__di(&d__1, iordre);
}
/* ------------- Renormalization of the vector of constraint ---------------
*/
bid = rider * riord;
i__1 = *ndimen;
for (nd = 1; nd <= i__1; ++nd)
{
cntout[nd] = bid * cntrin[nd];
/* L100: */
}
/* ------------------------------ The end -------------------------------
*/
if (ibb >= 3)
{
AdvApp2Var_SysBase::mgsomsg_("MMA1NOC", 7L);
}
return 0;
} /* mma1noc_ */
//=================================================================================================
int mma1nop_(int* nbroot, double* rootlg, double* uvfonc, int* isofav, double* ttable, int* iercod)
{
/* System generated locals */
int i__1;
/* Local variables */
double alinu, blinu, alinv, blinv;
int ii, ibb;
/* ***********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* Normalization of parameters of an iso, starting from */
/* parametric block and parameters on (-1,1). */
/* KEYWORDS : */
/* ----------- */
/* TOUS,AB_SPECIFI :: ISO&,POINT&,NORMALISATION,&POINT,&ISO */
/* INPUT ARGUMENTS : */
/* -------------------- */
/* NBROOT: Nb of points of discretisation INSIDE the iso */
/* defined on (-1,1). */
/* ROOTLG: Table of discretization parameters on )-1,1( */
/* of the iso. */
/* UVFONC: Block of definition of the iso */
/* ISOFAV: = 1, this is iso-u; =2, this is iso-v. */
/* OUTPUT ARGUMENTS : */
/* --------------------- */
/* TTABLE: Table of parameters renormalized on UVFONC of the iso.
*/
/* IERCOD: = 0, OK */
/* = 1, ISOFAV is out of allowed values. */
/* > */
/* **********************************************************************
*/
/* Name of the routine */
/* Parameter adjustments */
--rootlg;
uvfonc -= 3;
/* Function Body */
ibb = AdvApp2Var_SysBase::mnfndeb_();
if (ibb >= 3)
{
AdvApp2Var_SysBase::mgenmsg_("MMA1NOP", 7L);
}
alinu = (uvfonc[4] - uvfonc[3]) / 2.;
blinu = (uvfonc[4] + uvfonc[3]) / 2.;
alinv = (uvfonc[6] - uvfonc[5]) / 2.;
blinv = (uvfonc[6] + uvfonc[5]) / 2.;
if (*isofav == 1)
{
ttable[0] = uvfonc[5];
i__1 = *nbroot;
for (ii = 1; ii <= i__1; ++ii)
{
ttable[ii] = alinv * rootlg[ii] + blinv;
/* L100: */
}
ttable[*nbroot + 1] = uvfonc[6];
}
else if (*isofav == 2)
{
ttable[0] = uvfonc[3];
i__1 = *nbroot;
for (ii = 1; ii <= i__1; ++ii)
{
ttable[ii] = alinu * rootlg[ii] + blinu;
/* L200: */
}
ttable[*nbroot + 1] = uvfonc[4];
}
else
{
goto L9100;
}
goto L9999;
/* ------------------------------ THE END -------------------------------
*/
L9100:
*iercod = 1;
goto L9999;
L9999:
if (*iercod != 0)
{
AdvApp2Var_SysBase::maermsg_("MMA1NOP", iercod, 7L);
}
if (ibb >= 3)
{
AdvApp2Var_SysBase::mgsomsg_("MMA1NOP", 7L);
}
return 0;
} /* mma1nop_ */
//=================================================================================================
int AdvApp2Var_ApproxF2var::mma2ac1_(int const* ndimen,
int const* mxujac,
int const* mxvjac,
int const* iordru,
int const* iordrv,
double const* contr1,
double const* contr2,
double const* contr3,
double const* contr4,
double const* uhermt,
double const* vhermt,
double* patjac)
{
/* System generated locals */
int contr1_dim1, contr1_dim2, contr1_offset, contr2_dim1, contr2_dim2, contr2_offset, contr3_dim1,
contr3_dim2, contr3_offset, contr4_dim1, contr4_dim2, contr4_offset, uhermt_dim1, uhermt_offset,
vhermt_dim1, vhermt_offset, patjac_dim1, patjac_dim2, patjac_offset, i__1, i__2, i__3, i__4,
i__5;
/* Local variables */
long ldbg;
int ndgu, ndgv;
double bidu1, bidu2, bidv1, bidv2;
int ioru1, iorv1, ii, nd, jj, ku, kv;
double cnt1, cnt2, cnt3, cnt4;
/* **********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* Add polynoms of edge constraints. */
/* KEYWORDS : */
/* ----------- */
/* TOUS,AB_SPECIFI::POINT&,CONTRAINTE&,ADDITION,&POLYNOME */
/* INPUT ARGUMENTS : */
/* ------------------ */
/* NDIMEN: Dimension of the space. */
/* MXUJAC: Max degree of the polynom of approximation by U. The */
/* representation in the orthogonal base starts from degree */
/* 0 to degree MXUJAC-2*(IORDRU+1). The polynomial base is the */
/* base of Jacobi of order -1 (Legendre), 0, 1 or 2 */
/* MXVJAC: Max degree of the polynom of approximation by V. The */
/* representation in the orthogonal base starts from degree */
/* 0 to degree MXUJAC-2*(IORDRU+1). The polynomial base is the */
/* base of Jacobi of order -1 (Legendre), 0, 1 or 2 */
/* IORDRU: Order of the base of Jacobi (-1,0,1 or 2) by U. Corresponds */
/* to the step of constraints: C0, C1 or C2. */
/* IORDRV: Order of the base of Jacobi (-1,0,1 or 2) by V. Corresponds */
/* to the step of constraints: C0, C1 or C2. */
/* CONTR1: Contains, if IORDRU and IORDRV>=0, the values at the */
/* extremities of F(U0,V0) and its derivatives. */
/* CONTR2: Contains, if IORDRU and IORDRV>=0, the values at the */
/* extremities of F(U1,V0) and its derivatives. */
/* CONTR3: Contains, if IORDRU and IORDRV>=0, the values at the */
/* extremities of F(U0,V1) and its derivatives. */
/* CONTR4: Contains, if IORDRU and IORDRV>=0, the values at the */
/* extremities of F(U1,V1) and its derivatives. */
/* UHERMT: Coeff. of Hermit polynoms of order IORDRU. */
/* VHERMT: Coeff. of Hermit polynoms of order IORDRV. */
/* PATJAC: Table of coefficients of the polynom P(u,v) of approximation */
/* of F(u,v) WITHOUT taking into account the constraints. */
/* OUTPUT ARGUMENTS : */
/* ------------------- */
/* PATJAC: Table of coefficients of the polynom P(u,v) by approximation */
/* of F(u,v) WITH taking into account of constraints. */
/* > */
/* **********************************************************************
*/
/* Name of the routine */
/* --------------------------- Initialization --------------------------
*/
/* Parameter adjustments */
patjac_dim1 = *mxujac + 1;
patjac_dim2 = *mxvjac + 1;
patjac_offset = patjac_dim1 * patjac_dim2;
patjac -= patjac_offset;
uhermt_dim1 = (*iordru << 1) + 2;
uhermt_offset = uhermt_dim1;
uhermt -= uhermt_offset;
vhermt_dim1 = (*iordrv << 1) + 2;
vhermt_offset = vhermt_dim1;
vhermt -= vhermt_offset;
contr4_dim1 = *ndimen;
contr4_dim2 = *iordru + 2;
contr4_offset = contr4_dim1 * (contr4_dim2 + 1) + 1;
contr4 -= contr4_offset;
contr3_dim1 = *ndimen;
contr3_dim2 = *iordru + 2;
contr3_offset = contr3_dim1 * (contr3_dim2 + 1) + 1;
contr3 -= contr3_offset;
contr2_dim1 = *ndimen;
contr2_dim2 = *iordru + 2;
contr2_offset = contr2_dim1 * (contr2_dim2 + 1) + 1;
contr2 -= contr2_offset;
contr1_dim1 = *ndimen;
contr1_dim2 = *iordru + 2;
contr1_offset = contr1_dim1 * (contr1_dim2 + 1) + 1;
contr1 -= contr1_offset;
/* Function Body */
ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
if (ldbg)
{
AdvApp2Var_SysBase::mgenmsg_("MMA2AC1", 7L);
}
/* ------------ SUBTRACTION OF ANGULAR CONSTRAINTS -------------------
*/
ioru1 = *iordru + 1;
iorv1 = *iordrv + 1;
ndgu = (*iordru << 1) + 1;
ndgv = (*iordrv << 1) + 1;
i__1 = iorv1;
for (jj = 1; jj <= i__1; ++jj)
{
i__2 = ioru1;
for (ii = 1; ii <= i__2; ++ii)
{
i__3 = *ndimen;
for (nd = 1; nd <= i__3; ++nd)
{
cnt1 = contr1[nd + (ii + jj * contr1_dim2) * contr1_dim1];
cnt2 = contr2[nd + (ii + jj * contr2_dim2) * contr2_dim1];
cnt3 = contr3[nd + (ii + jj * contr3_dim2) * contr3_dim1];
cnt4 = contr4[nd + (ii + jj * contr4_dim2) * contr4_dim1];
i__4 = ndgv;
for (kv = 0; kv <= i__4; ++kv)
{
bidv1 = vhermt[kv + ((jj << 1) - 1) * vhermt_dim1];
bidv2 = vhermt[kv + (jj << 1) * vhermt_dim1];
i__5 = ndgu;
for (ku = 0; ku <= i__5; ++ku)
{
bidu1 = uhermt[ku + ((ii << 1) - 1) * uhermt_dim1];
bidu2 = uhermt[ku + (ii << 1) * uhermt_dim1];
patjac[ku + (kv + nd * patjac_dim2) * patjac_dim1] =
patjac[ku + (kv + nd * patjac_dim2) * patjac_dim1] - bidu1 * bidv1 * cnt1
- bidu2 * bidv1 * cnt2 - bidu1 * bidv2 * cnt3 - bidu2 * bidv2 * cnt4;
/* L500: */
}
/* L400: */
}
/* L300: */
}
/* L200: */
}
/* L100: */
}
/* ------------------------------ The end -------------------------------
*/
if (ldbg)
{
AdvApp2Var_SysBase::mgsomsg_("MMA2AC1", 7L);
}
return 0;
} /* mma2ac1_ */
//=================================================================================================
int AdvApp2Var_ApproxF2var::mma2ac2_(const int* ndimen,
const int* mxujac,
const int* mxvjac,
const int* iordrv,
const int* nclimu,
const int* ncfiv1,
const double* crbiv1,
const int* ncfiv2,
const double* crbiv2,
const double* vhermt,
double* patjac)
{
/* System generated locals */
int crbiv1_dim1, crbiv1_dim2, crbiv1_offset, crbiv2_dim1, crbiv2_dim2, crbiv2_offset, patjac_dim1,
patjac_dim2, patjac_offset, vhermt_dim1, vhermt_offset, i__1, i__2, i__3, i__4;
/* Local variables */
long ldbg;
int ndgv1, ndgv2, ii, jj, nd, kk;
double bid1, bid2;
/* **********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* Add polynoms of constraints */
/* KEYWORDS : */
/* ----------- */
/* FUNCTION,APPROXIMATION,COEFFICIENT,POLYNOM */
/* INPUT ARGUMENTS : */
/* ------------------ */
/* NDIMEN: Dimension of the space. */
/* MXUJAC: Max degree of the polynom of approximation by U. The */
/* representation in the orthogonal base starts from degree */
/* 0 to degree MXUJAC-2*(IORDRU+1). The polynomial base is the */
/* base of Jacobi of order -1 (Legendre), 0, 1 or 2 */
/* MXVJAC: Max degree of the polynom of approximation by V. The */
/* representation in the orthogonal base starts from degree */
/* 0 to degree MXUJAC-2*(IORDRU+1). The polynomial base is the */
/* base of Jacobi of order -1 (Legendre), 0, 1 or 2 */
/* IORDRV: Order of the base of Jacobi (-1,0,1 or 2) by V. Corresponds */
/* to the step of constraints: C0, C1 or C2. */
/* NCLIMU LIMIT nb of coeff by u of the solution P(u,v)
* NCFIV1: Nb of Coeff. of curves stored in CRBIV1. */
/* CRBIV1: Table of coeffs of the approximation of iso-V0 and its */
/* derivatives till order IORDRV. */
/* NCFIV2: Nb of Coeff. of curves stored in CRBIV2. */
/* CRBIV2: Table of coeffs of approximation of iso-V1 and its */
/* derivatives till order IORDRV. */
/* VHERMT: Coeff. of Hermit polynoms of order IORDRV. */
/* PATJAC: Table of coefficients of the polynom P(u,v) of approximation */
/* of F(u,v) WITHOUT taking into account the constraints. */
/* OUTPUT ARGUMENTS : */
/* ------------------- */
/* PATJAC: Table of coefficients of the polynom P(u,v) by approximation */
/* of F(u,v) WITH taking into account of constraints. */
/* > */
/* > */
/* **********************************************************************
*/
/* Name of the routine */
/* --------------------------- Initialisations --------------------------
*/
/* Parameter adjustments */
patjac_dim1 = *mxujac + 1;
patjac_dim2 = *mxvjac + 1;
patjac_offset = patjac_dim1 * patjac_dim2;
patjac -= patjac_offset;
vhermt_dim1 = (*iordrv << 1) + 2;
vhermt_offset = vhermt_dim1;
vhermt -= vhermt_offset;
--ncfiv2;
--ncfiv1;
crbiv2_dim1 = *nclimu;
crbiv2_dim2 = *ndimen;
crbiv2_offset = crbiv2_dim1 * (crbiv2_dim2 + 1);
crbiv2 -= crbiv2_offset;
crbiv1_dim1 = *nclimu;
crbiv1_dim2 = *ndimen;
crbiv1_offset = crbiv1_dim1 * (crbiv1_dim2 + 1);
crbiv1 -= crbiv1_offset;
/* Function Body */
ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
if (ldbg)
{
AdvApp2Var_SysBase::mgenmsg_("MMA2AC2", 7L);
}
/* ------------ ADDING of coeff by u of curves, by v of Hermit --------
*/
i__1 = *iordrv + 1;
for (ii = 1; ii <= i__1; ++ii)
{
ndgv1 = ncfiv1[ii] - 1;
ndgv2 = ncfiv2[ii] - 1;
i__2 = *ndimen;
for (nd = 1; nd <= i__2; ++nd)
{
i__3 = (*iordrv << 1) + 1;
for (jj = 0; jj <= i__3; ++jj)
{
bid1 = vhermt[jj + ((ii << 1) - 1) * vhermt_dim1];
i__4 = ndgv1;
for (kk = 0; kk <= i__4; ++kk)
{
patjac[kk + (jj + nd * patjac_dim2) * patjac_dim1] +=
bid1 * crbiv1[kk + (nd + ii * crbiv1_dim2) * crbiv1_dim1];
/* L400: */
}
bid2 = vhermt[jj + (ii << 1) * vhermt_dim1];
i__4 = ndgv2;
for (kk = 0; kk <= i__4; ++kk)
{
patjac[kk + (jj + nd * patjac_dim2) * patjac_dim1] +=
bid2 * crbiv2[kk + (nd + ii * crbiv2_dim2) * crbiv2_dim1];
/* L500: */
}
/* L300: */
}
/* L200: */
}
/* L100: */
}
/* ------------------------------ The end -------------------------------
*/
if (ldbg)
{
AdvApp2Var_SysBase::mgsomsg_("MMA2AC2", 7L);
}
return 0;
} /* mma2ac2_ */
//=================================================================================================
int AdvApp2Var_ApproxF2var::mma2ac3_(const int* ndimen,
const int* mxujac,
const int* mxvjac,
const int* iordru,
const int* nclimv,
const int* ncfiu1,
const double* crbiu1,
const int* ncfiu2,
const double* crbiu2,
const double* uhermt,
double* patjac)
{
/* System generated locals */
int crbiu1_dim1, crbiu1_dim2, crbiu1_offset, crbiu2_dim1, crbiu2_dim2, crbiu2_offset, patjac_dim1,
patjac_dim2, patjac_offset, uhermt_dim1, uhermt_offset, i__1, i__2, i__3, i__4;
/* Local variables */
long ldbg;
int ndgu1, ndgu2, ii, jj, nd, kk;
double bid1, bid2;
/* **********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* Ajout des polynomes de contraintes */
/* KEYWORDS : */
/* ----------- */
/* FONCTION,APPROXIMATION,COEFFICIENT,POLYNOME */
/* INPUT ARGUMENTS : */
/* ------------------ */
/* NDIMEN: Dimension of the space. */
/* MXUJAC: Max degree of the polynom of approximation by U. The */
/* representation in the orthogonal base starts from degree */
/* 0 to degree MXUJAC-2*(IORDRU+1). The polynomial base is the */
/* base of Jacobi of order -1 (Legendre), 0, 1 or 2 */
/* MXVJAC: Max degree of the polynom of approximation by V. The */
/* representation in the orthogonal base starts from degree */
/* 0 to degree MXUJAC-2*(IORDRU+1). The polynomial base is the */
/* base of Jacobi of order -1 (Legendre), 0, 1 or 2 */
/* IORDRU: Order of the base of Jacobi (-1,0,1 or 2) by U. Corresponds */
/* to the step of constraints: C0, C1 or C2. */
/* NCLIMV LIMIT nb of coeff by v of the solution P(u,v)
* NCFIU1: Nb of Coeff. of curves stored in CRBIU1. */
/* CRBIU1: Table of coeffs of the approximation of iso-U0 and its */
/* derivatives till order IORDRU. */
/* NCFIU2: Nb of Coeff. of curves stored in CRBIU2. */
/* CRBIU2: Table of coeffs of approximation of iso-U1 and its */
/* derivatives till order IORDRU */
/* UHERMT: Coeff. of Hermit polynoms of order IORDRU. */
/* PATJAC: Table of coefficients of the polynom P(u,v) of approximation */
/* of F(u,v) WITHOUT taking into account the constraints. */
/* OUTPUT ARGUMENTS : */
/* ------------------- */
/* PATJAC: Table of coefficients of the polynom P(u,v) by approximation */
/* of F(u,v) WITH taking into account of constraints. */
/* > */
/* **********************************************************************
*/
/* The name of the routine */
/* --------------------------- Initializations --------------------------
*/
/* Parameter adjustments */
patjac_dim1 = *mxujac + 1;
patjac_dim2 = *mxvjac + 1;
patjac_offset = patjac_dim1 * patjac_dim2;
patjac -= patjac_offset;
uhermt_dim1 = (*iordru << 1) + 2;
uhermt_offset = uhermt_dim1;
uhermt -= uhermt_offset;
--ncfiu2;
--ncfiu1;
crbiu2_dim1 = *nclimv;
crbiu2_dim2 = *ndimen;
crbiu2_offset = crbiu2_dim1 * (crbiu2_dim2 + 1);
crbiu2 -= crbiu2_offset;
crbiu1_dim1 = *nclimv;
crbiu1_dim2 = *ndimen;
crbiu1_offset = crbiu1_dim1 * (crbiu1_dim2 + 1);
crbiu1 -= crbiu1_offset;
/* Function Body */
ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
if (ldbg)
{
AdvApp2Var_SysBase::mgenmsg_("MMA2AC3", 7L);
}
/* ------------ ADDING of coeff by u of curves, by v of Hermit --------
*/
i__1 = *iordru + 1;
for (ii = 1; ii <= i__1; ++ii)
{
ndgu1 = ncfiu1[ii] - 1;
ndgu2 = ncfiu2[ii] - 1;
i__2 = *ndimen;
for (nd = 1; nd <= i__2; ++nd)
{
i__3 = ndgu1;
for (jj = 0; jj <= i__3; ++jj)
{
bid1 = crbiu1[jj + (nd + ii * crbiu1_dim2) * crbiu1_dim1];
i__4 = (*iordru << 1) + 1;
for (kk = 0; kk <= i__4; ++kk)
{
patjac[kk + (jj + nd * patjac_dim2) * patjac_dim1] +=
bid1 * uhermt[kk + ((ii << 1) - 1) * uhermt_dim1];
/* L400: */
}
/* L300: */
}
i__3 = ndgu2;
for (jj = 0; jj <= i__3; ++jj)
{
bid2 = crbiu2[jj + (nd + ii * crbiu2_dim2) * crbiu2_dim1];
i__4 = (*iordru << 1) + 1;
for (kk = 0; kk <= i__4; ++kk)
{
patjac[kk + (jj + nd * patjac_dim2) * patjac_dim1] +=
bid2 * uhermt[kk + (ii << 1) * uhermt_dim1];
/* L600: */
}
/* L500: */
}
/* L200: */
}
/* L100: */
}
/* ------------------------------ The end -------------------------------
*/
if (ldbg)
{
AdvApp2Var_SysBase::mgsomsg_("MMA2AC3", 7L);
}
return 0;
} /* mma2ac3_ */
//=================================================================================================
int AdvApp2Var_ApproxF2var::mma2can_(const int* ncfmxu,
const int* ncfmxv,
const int* ndimen,
const int* iordru,
const int* iordrv,
const int* ncoefu,
const int* ncoefv,
const double* patjac,
double* pataux,
double* patcan,
int* iercod)
{
/* System generated locals */
int patjac_dim1, patjac_dim2, patjac_offset, patcan_dim1, patcan_dim2, patcan_offset, i__1, i__2;
/* Local variables */
long ldbg;
int ilon1, ilon2, ii, nd;
/* **********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* Change of Jacobi base to canonical (-1,1) and writing in a greater */
/* table. */
/* KEYWORDS : */
/* ----------- */
/* ALL,AB_SPECIFI,CARREAU&,CONVERSION,JACOBI,CANNONIQUE,&CARREAU */
/* INPUT ARGUMENTS : */
/* -------------------- */
/* NCFMXU: Dimension by U of resulting table PATCAN */
/* NCFMXV: Dimension by V of resulting table PATCAN */
/* NDIMEN: Dimension of the workspace. */
/* IORDRU: Order of constraint by U */
/* IORDRV: Order of constraint by V. */
/* NCOEFU: Nb of coeff by U of square PATJAC */
/* NCOEFV: Nb of coeff by V of square PATJAC */
/* PATJAC: Square in the base of Jacobi of order IORDRU by U and */
/* IORDRV by V. */
/* OUTPUT ARGUMENTS : */
/* --------------------- */
/* PATAUX: Auxiliary Table. */
/* PATCAN: Table of coefficients in the canonic base. */
/* IERCOD: Error code. */
/* = 0, everything goes well, and all things are equal. */
/* = 1, the program refuses to process with incorrect input arguments */
/* COMMONS USED : */
/* ------------------ */
/* REFERENCES CALLED : */
/* --------------------- */
/* DESCRIPTION/NOTES/LIMITATIONS : */
/* ----------------------------------- */
/* > */
/* **********************************************************************
*/
/* Parameter adjustments */
patcan_dim1 = *ncfmxu;
patcan_dim2 = *ncfmxv;
patcan_offset = patcan_dim1 * (patcan_dim2 + 1) + 1;
patcan -= patcan_offset;
--pataux;
patjac_dim1 = *ncoefu;
patjac_dim2 = *ncoefv;
patjac_offset = patjac_dim1 * (patjac_dim2 + 1) + 1;
patjac -= patjac_offset;
/* Function Body */
ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 2;
if (ldbg)
{
AdvApp2Var_SysBase::mgenmsg_("MMA2CAN", 7L);
}
*iercod = 0;
if (*iordru < -1 || *iordru > 2)
{
goto L9100;
}
if (*iordrv < -1 || *iordrv > 2)
{
goto L9100;
}
if (*ncoefu > *ncfmxu || *ncoefv > *ncfmxv)
{
goto L9100;
}
/* --> Pass to canonic base (-1,1) */
mmjacpt_(ndimen,
ncoefu,
ncoefv,
iordru,
iordrv,
&patjac[patjac_offset],
&pataux[1],
&patcan[patcan_offset]);
/* --> Write all in a greater table */
AdvApp2Var_MathBase::mmfmca8_(ncoefu,
ncoefv,
ndimen,
ncfmxu,
ncfmxv,
ndimen,
&patcan[patcan_offset],
&patcan[patcan_offset]);
/* --> Complete with zeros the resulting table. */
ilon1 = *ncfmxu - *ncoefu;
ilon2 = *ncfmxu * (*ncfmxv - *ncoefv);
i__1 = *ndimen;
for (nd = 1; nd <= i__1; ++nd)
{
if (ilon1 > 0)
{
i__2 = *ncoefv;
for (ii = 1; ii <= i__2; ++ii)
{
AdvApp2Var_SysBase::mvriraz_(&ilon1,
&patcan[*ncoefu + 1 + (ii + nd * patcan_dim2) * patcan_dim1]);
/* L110: */
}
}
if (ilon2 > 0)
{
AdvApp2Var_SysBase::mvriraz_(&ilon2,
&patcan[(*ncoefv + 1 + nd * patcan_dim2) * patcan_dim1 + 1]);
}
/* L100: */
}
goto L9999;
/* ----------------------
*/
L9100:
*iercod = 1;
goto L9999;
L9999:
AdvApp2Var_SysBase::maermsg_("MMA2CAN", iercod, 7L);
if (ldbg)
{
AdvApp2Var_SysBase::mgsomsg_("MMA2CAN", 7L);
}
return 0;
} /* mma2can_ */
//=================================================================================================
int mma2cd1_(int* ndimen,
int* nbpntu,
double* urootl,
int* nbpntv,
double* vrootl,
int* iordru,
int* iordrv,
double* contr1,
double* contr2,
double* contr3,
double* contr4,
double* fpntbu,
double* fpntbv,
double* uhermt,
double* vhermt,
double* sosotb,
double* soditb,
double* disotb,
double* diditb)
{
int c__1 = 1;
/* System generated locals */
int contr1_dim1, contr1_dim2, contr1_offset, contr2_dim1, contr2_dim2, contr2_offset, contr3_dim1,
contr3_dim2, contr3_offset, contr4_dim1, contr4_dim2, contr4_offset, uhermt_dim1, uhermt_offset,
vhermt_dim1, vhermt_offset, fpntbu_dim1, fpntbu_offset, fpntbv_dim1, fpntbv_offset, sosotb_dim1,
sosotb_dim2, sosotb_offset, diditb_dim1, diditb_dim2, diditb_offset, soditb_dim1, soditb_dim2,
soditb_offset, disotb_dim1, disotb_dim2, disotb_offset, i__1, i__2, i__3, i__4, i__5;
/* Local variables */
int ncfhu, ncfhv, nuroo, nvroo, nd, ii, jj, kk, ll, ibb, kkm, llm, kkp, llp;
double bid1, bid2, bid3, bid4;
double diu1, diu2, div1, div2, sou1, sou2, sov1, sov2;
/* **********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* Discretisation on the parameters of polynoms of interpolation */
/* of constraints at the corners of order IORDRE. */
/* KEYWORDS : */
/* ----------- */
/* TOUS, AB_SPECIFI::CONTRAINTE&, DISCRETISATION, &POINT */
/* INPUT ARGUMENTS : */
/* ------------------ */
/* NDIMEN: Dimension of the space. */
/* NBPNTU: Nb of INTERNAL parameters of discretisation by U. */
/* This is also the nb of root of Legendre polynom where discretization is done. */
/* UROOTL: Table of parameters of discretisation ON (-1,1) by U.
*/
/* NBPNTV: Nb of INTERNAL parameters of discretisation by V. */
/* This is also the nb of root of Legendre polynom where discretization is done. */
/* VROOTL: Table of discretization parameters on (-1,1) by V. */
/* IORDRU: Order of constraint imposed at the extremities of iso-V */
/* = 0, calculate the extremities of iso-V */
/* = 1, calculate, additionally, the 1st derivative in the direction of iso-V */
/* = 2, calculate, additionally, the 2nd derivative in the direction of iso-V */
/* IORDRV: Order of constraint imposed at the extremities of iso-U */
/* = 0, calculate the extremities of iso-U */
/* = 1, calculate, additionally, the 1st derivative in the direction of iso-U */
/* = 2, calculate, additionally, the 2nd derivative in the direction of iso-U */
/* CONTR1: Contains, if IORDRU and IORDRV>=0, the values at the */
/* extremities of F(U0,V0) and its derivatives. */
/* CONTR2: Contains, if IORDRU and IORDRV>=0, the values at the */
/* extremities of F(U1,V0) and its derivatives. */
/* CONTR3: Contains, if IORDRU and IORDRV>=0, the values at the */
/* extremities of F(U0,V1) and its derivatives. */
/* CONTR4: Contains, if IORDRU and IORDRV>=0, the values at the */
/* extremities of F(U1,V1) and its derivatives. */
/* SOSOTB: Preinitialized table (input/output argument). */
/* DISOTB: Preinitialized table (input/output argument). */
/* SODITB: Preinitialized table (input/output argument). */
/* DIDITB: Preinitialized table (input/output argument) */
/* OUTPUT ARGUMENTS : */
/* ------------------- */
/* FPNTBU: Auxiliary table. */
/* FPNTBV: Auxiliary table. */
/* UHERMT: Table of 2*(IORDRU+1) coeff. of 2*(IORDRU+1) polynoms of Hermite. */
/* VHERMT: Table of 2*(IORDRV+1) coeff. of 2*(IORDRV+1) polynoms of Hermite. */
/* SOSOTB: Table where the terms of constraints are added */
/* C(ui,vj) + C(ui,-vj) + C(-ui,vj) + C(-ui,-vj) */
/* with ui and vj positive roots of the Legendre polynom */
/* of degree NBPNTU and NBPNTV respectively. */
/* DISOTB: Table where the terms of constraints are added */
/* C(ui,vj) + C(ui,-vj) - C(-ui,vj) - C(-ui,-vj) */
/* with ui and vj positive roots of the polynom of Legendre */
/* of degree NBPNTU and NBPNTV respectively. */
/* SODITB: Table where the terms of constraints are added */
/* C(ui,vj) - C(ui,-vj) + C(-ui,vj) - C(-ui,-vj) */
/* with ui and vj positive roots of the polynom of Legendre */
/* of degree NBPNTU and NBPNTV respectively. */
/* DIDITB: Table where the terms of constraints are added */
/* C(ui,vj) - C(ui,-vj) - C(-ui,vj) + C(-ui,-vj) */
/* with ui and vj positive roots of the polynom of Legendre */
/* of degree NBPNTU and NBPNTV respectively. */
/* COMMONS USED : */
/* ---------------- */
/* REFERENCES CALLED : */
/* ----------------------- */
/* DESCRIPTION/NOTES/LIMITATIONS : */
/* ----------------------------------- */
/* > */
/* **********************************************************************
*/
/* Name of the routine */
/* Parameter adjustments */
--urootl;
diditb_dim1 = *nbpntu / 2 + 1;
diditb_dim2 = *nbpntv / 2 + 1;
diditb_offset = diditb_dim1 * diditb_dim2;
diditb -= diditb_offset;
disotb_dim1 = *nbpntu / 2;
disotb_dim2 = *nbpntv / 2;
disotb_offset = disotb_dim1 * (disotb_dim2 + 1) + 1;
disotb -= disotb_offset;
soditb_dim1 = *nbpntu / 2;
soditb_dim2 = *nbpntv / 2;
soditb_offset = soditb_dim1 * (soditb_dim2 + 1) + 1;
soditb -= soditb_offset;
sosotb_dim1 = *nbpntu / 2 + 1;
sosotb_dim2 = *nbpntv / 2 + 1;
sosotb_offset = sosotb_dim1 * sosotb_dim2;
sosotb -= sosotb_offset;
--vrootl;
uhermt_dim1 = (*iordru << 1) + 2;
uhermt_offset = uhermt_dim1;
uhermt -= uhermt_offset;
fpntbu_dim1 = *nbpntu;
fpntbu_offset = fpntbu_dim1 + 1;
fpntbu -= fpntbu_offset;
vhermt_dim1 = (*iordrv << 1) + 2;
vhermt_offset = vhermt_dim1;
vhermt -= vhermt_offset;
fpntbv_dim1 = *nbpntv;
fpntbv_offset = fpntbv_dim1 + 1;
fpntbv -= fpntbv_offset;
contr4_dim1 = *ndimen;
contr4_dim2 = *iordru + 2;
contr4_offset = contr4_dim1 * (contr4_dim2 + 1) + 1;
contr4 -= contr4_offset;
contr3_dim1 = *ndimen;
contr3_dim2 = *iordru + 2;
contr3_offset = contr3_dim1 * (contr3_dim2 + 1) + 1;
contr3 -= contr3_offset;
contr2_dim1 = *ndimen;
contr2_dim2 = *iordru + 2;
contr2_offset = contr2_dim1 * (contr2_dim2 + 1) + 1;
contr2 -= contr2_offset;
contr1_dim1 = *ndimen;
contr1_dim2 = *iordru + 2;
contr1_offset = contr1_dim1 * (contr1_dim2 + 1) + 1;
contr1 -= contr1_offset;
/* Function Body */
ibb = AdvApp2Var_SysBase::mnfndeb_();
if (ibb >= 3)
{
AdvApp2Var_SysBase::mgenmsg_("MMA2CD1", 7L);
}
/* ------------------- Discretisation of Hermite polynoms -----------
*/
ncfhu = (*iordru + 1) << 1;
i__1 = ncfhu;
for (ii = 1; ii <= i__1; ++ii)
{
i__2 = *nbpntu;
for (ll = 1; ll <= i__2; ++ll)
{
AdvApp2Var_MathBase::mmmpocur_(&ncfhu,
&c__1,
&ncfhu,
&uhermt[ii * uhermt_dim1],
&urootl[ll],
&fpntbu[ll + ii * fpntbu_dim1]);
/* L20: */
}
/* L10: */
}
ncfhv = (*iordrv + 1) << 1;
i__1 = ncfhv;
for (jj = 1; jj <= i__1; ++jj)
{
i__2 = *nbpntv;
for (kk = 1; kk <= i__2; ++kk)
{
AdvApp2Var_MathBase::mmmpocur_(&ncfhv,
&c__1,
&ncfhv,
&vhermt[jj * vhermt_dim1],
&vrootl[kk],
&fpntbv[kk + jj * fpntbv_dim1]);
/* L40: */
}
/* L30: */
}
/* ---- The discretizations of polynoms of constraints are subtracted ----
*/
nuroo = *nbpntu / 2;
nvroo = *nbpntv / 2;
i__1 = *ndimen;
for (nd = 1; nd <= i__1; ++nd)
{
i__2 = *iordrv + 1;
for (jj = 1; jj <= i__2; ++jj)
{
i__3 = *iordru + 1;
for (ii = 1; ii <= i__3; ++ii)
{
bid1 = contr1[nd + (ii + jj * contr1_dim2) * contr1_dim1];
bid2 = contr2[nd + (ii + jj * contr2_dim2) * contr2_dim1];
bid3 = contr3[nd + (ii + jj * contr3_dim2) * contr3_dim1];
bid4 = contr4[nd + (ii + jj * contr4_dim2) * contr4_dim1];
i__4 = nvroo;
for (kk = 1; kk <= i__4; ++kk)
{
kkp = (*nbpntv + 1) / 2 + kk;
kkm = nvroo - kk + 1;
sov1 = fpntbv[kkp + ((jj << 1) - 1) * fpntbv_dim1]
+ fpntbv[kkm + ((jj << 1) - 1) * fpntbv_dim1];
div1 = fpntbv[kkp + ((jj << 1) - 1) * fpntbv_dim1]
- fpntbv[kkm + ((jj << 1) - 1) * fpntbv_dim1];
sov2 = fpntbv[kkp + (jj << 1) * fpntbv_dim1] + fpntbv[kkm + (jj << 1) * fpntbv_dim1];
div2 = fpntbv[kkp + (jj << 1) * fpntbv_dim1] - fpntbv[kkm + (jj << 1) * fpntbv_dim1];
i__5 = nuroo;
for (ll = 1; ll <= i__5; ++ll)
{
llp = (*nbpntu + 1) / 2 + ll;
llm = nuroo - ll + 1;
sou1 = fpntbu[llp + ((ii << 1) - 1) * fpntbu_dim1]
+ fpntbu[llm + ((ii << 1) - 1) * fpntbu_dim1];
diu1 = fpntbu[llp + ((ii << 1) - 1) * fpntbu_dim1]
- fpntbu[llm + ((ii << 1) - 1) * fpntbu_dim1];
sou2 = fpntbu[llp + (ii << 1) * fpntbu_dim1] + fpntbu[llm + (ii << 1) * fpntbu_dim1];
diu2 = fpntbu[llp + (ii << 1) * fpntbu_dim1] - fpntbu[llm + (ii << 1) * fpntbu_dim1];
sosotb[ll + (kk + nd * sosotb_dim2) * sosotb_dim1] =
sosotb[ll + (kk + nd * sosotb_dim2) * sosotb_dim1] - bid1 * sou1 * sov1
- bid2 * sou2 * sov1 - bid3 * sou1 * sov2 - bid4 * sou2 * sov2;
soditb[ll + (kk + nd * soditb_dim2) * soditb_dim1] =
soditb[ll + (kk + nd * soditb_dim2) * soditb_dim1] - bid1 * sou1 * div1
- bid2 * sou2 * div1 - bid3 * sou1 * div2 - bid4 * sou2 * div2;
disotb[ll + (kk + nd * disotb_dim2) * disotb_dim1] =
disotb[ll + (kk + nd * disotb_dim2) * disotb_dim1] - bid1 * diu1 * sov1
- bid2 * diu2 * sov1 - bid3 * diu1 * sov2 - bid4 * diu2 * sov2;
diditb[ll + (kk + nd * diditb_dim2) * diditb_dim1] =
diditb[ll + (kk + nd * diditb_dim2) * diditb_dim1] - bid1 * diu1 * div1
- bid2 * diu2 * div1 - bid3 * diu1 * div2 - bid4 * diu2 * div2;
/* L450: */
}
/* L400: */
}
/* ------------ Case when the discretization is done only on the roots
----------- */
/* ---------- of Legendre polynom of uneven degree, 0 is root
----------- */
if (*nbpntu % 2 == 1)
{
sou1 = fpntbu[nuroo + 1 + ((ii << 1) - 1) * fpntbu_dim1];
sou2 = fpntbu[nuroo + 1 + (ii << 1) * fpntbu_dim1];
i__4 = nvroo;
for (kk = 1; kk <= i__4; ++kk)
{
kkp = (*nbpntv + 1) / 2 + kk;
kkm = nvroo - kk + 1;
sov1 = fpntbv[kkp + ((jj << 1) - 1) * fpntbv_dim1]
+ fpntbv[kkm + ((jj << 1) - 1) * fpntbv_dim1];
div1 = fpntbv[kkp + ((jj << 1) - 1) * fpntbv_dim1]
- fpntbv[kkm + ((jj << 1) - 1) * fpntbv_dim1];
sov2 = fpntbv[kkp + (jj << 1) * fpntbv_dim1] + fpntbv[kkm + (jj << 1) * fpntbv_dim1];
div2 = fpntbv[kkp + (jj << 1) * fpntbv_dim1] - fpntbv[kkm + (jj << 1) * fpntbv_dim1];
sosotb[(kk + nd * sosotb_dim2) * sosotb_dim1] =
sosotb[(kk + nd * sosotb_dim2) * sosotb_dim1] - bid1 * sou1 * sov1
- bid2 * sou2 * sov1 - bid3 * sou1 * sov2 - bid4 * sou2 * sov2;
diditb[(kk + nd * diditb_dim2) * diditb_dim1] =
diditb[(kk + nd * diditb_dim2) * diditb_dim1] - bid1 * sou1 * div1
- bid2 * sou2 * div1 - bid3 * sou1 * div2 - bid4 * sou2 * div2;
/* L500: */
}
}
if (*nbpntv % 2 == 1)
{
sov1 = fpntbv[nvroo + 1 + ((jj << 1) - 1) * fpntbv_dim1];
sov2 = fpntbv[nvroo + 1 + (jj << 1) * fpntbv_dim1];
i__4 = nuroo;
for (ll = 1; ll <= i__4; ++ll)
{
llp = (*nbpntu + 1) / 2 + ll;
llm = nuroo - ll + 1;
sou1 = fpntbu[llp + ((ii << 1) - 1) * fpntbu_dim1]
+ fpntbu[llm + ((ii << 1) - 1) * fpntbu_dim1];
diu1 = fpntbu[llp + ((ii << 1) - 1) * fpntbu_dim1]
- fpntbu[llm + ((ii << 1) - 1) * fpntbu_dim1];
sou2 = fpntbu[llp + (ii << 1) * fpntbu_dim1] + fpntbu[llm + (ii << 1) * fpntbu_dim1];
diu2 = fpntbu[llp + (ii << 1) * fpntbu_dim1] - fpntbu[llm + (ii << 1) * fpntbu_dim1];
sosotb[ll + nd * sosotb_dim2 * sosotb_dim1] =
sosotb[ll + nd * sosotb_dim2 * sosotb_dim1] - bid1 * sou1 * sov1 - bid2 * sou2 * sov1
- bid3 * sou1 * sov2 - bid4 * sou2 * sov2;
diditb[ll + nd * diditb_dim2 * diditb_dim1] =
diditb[ll + nd * diditb_dim2 * diditb_dim1] - bid1 * diu1 * sov1 - bid2 * diu2 * sov1
- bid3 * diu1 * sov2 - bid4 * diu2 * sov2;
/* L600: */
}
}
if (*nbpntu % 2 == 1 && *nbpntv % 2 == 1)
{
sou1 = fpntbu[nuroo + 1 + ((ii << 1) - 1) * fpntbu_dim1];
sou2 = fpntbu[nuroo + 1 + (ii << 1) * fpntbu_dim1];
sov1 = fpntbv[nvroo + 1 + ((jj << 1) - 1) * fpntbv_dim1];
sov2 = fpntbv[nvroo + 1 + (jj << 1) * fpntbv_dim1];
sosotb[nd * sosotb_dim2 * sosotb_dim1] = sosotb[nd * sosotb_dim2 * sosotb_dim1]
- bid1 * sou1 * sov1 - bid2 * sou2 * sov1
- bid3 * sou1 * sov2 - bid4 * sou2 * sov2;
diditb[nd * diditb_dim2 * diditb_dim1] = diditb[nd * diditb_dim2 * diditb_dim1]
- bid1 * sou1 * sov1 - bid2 * sou2 * sov1
- bid3 * sou1 * sov2 - bid4 * sou2 * sov2;
}
/* L300: */
}
/* L200: */
}
/* L100: */
}
goto L9999;
/* ------------------------------ The End -------------------------------
*/
L9999:
if (ibb >= 3)
{
AdvApp2Var_SysBase::mgsomsg_("MMA2CD1", 7L);
}
return 0;
} /* mma2cd1_ */
//=================================================================================================
int mma2cd2_(int* ndimen,
int* nbpntu,
int* nbpntv,
double* vrootl,
int* iordrv,
double* sotbv1,
double* sotbv2,
double* ditbv1,
double* ditbv2,
double* fpntab,
double* vhermt,
double* sosotb,
double* soditb,
double* disotb,
double* diditb)
{
int c__1 = 1;
/* System generated locals */
int sotbv1_dim1, sotbv1_dim2, sotbv1_offset, sotbv2_dim1, sotbv2_dim2, sotbv2_offset, ditbv1_dim1,
ditbv1_dim2, ditbv1_offset, ditbv2_dim1, ditbv2_dim2, ditbv2_offset, fpntab_dim1, fpntab_offset,
vhermt_dim1, vhermt_offset, sosotb_dim1, sosotb_dim2, sosotb_offset, diditb_dim1, diditb_dim2,
diditb_offset, soditb_dim1, soditb_dim2, soditb_offset, disotb_dim1, disotb_dim2, disotb_offset,
i__1, i__2, i__3, i__4;
/* Local variables */
int ncfhv, nuroo, nvroo, ii, nd, jj, kk, ibb, jjm, jjp;
double bid1, bid2, bid3, bid4;
/* **********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* Discretisation on the parameters of polynoms of interpolation */
/* of constraints on 2 borders iso-V of order IORDRV. */
/* KEYWORDS : */
/* ----------- */
/* TOUS, AB_SPECIFI::CONTRAINTE&, DISCRETISATION, &POINT */
/* INPUT ARGUMENTS : */
/* ------------------ */
/* NDIMEN: Dimension of the space. */
/* NBPNTU: Nb of INTERNAL parameters of discretisation by U. */
/* This is also the nb of root of Legendre polynom where discretization is done. */
/* UROOTL: Table of parameters of discretisation ON (-1,1) by U.
*/
/* NBPNTV: Nb of INTERNAL parameters of discretisation by V. */
/* This is also the nb of root of Legendre polynom where discretization is done. */
/* VROOTL: Table of discretization parameters on (-1,1) by V. */
/* IORDRV: Order of constraint imposed at the extremities of iso-V */
/* = 0, calculate the extremities of iso-V */
/* = 1, calculate, additionally, the 1st derivative in the direction of iso-V */
/* = 2, calculate, additionally, the 2nd derivative in the direction of iso-V */
/* SOTBV1: Table of NBPNTV/2 sums of 2 index points */
/* NBPNTV-II+1 and II, for II = 1, NBPNTV/2 on iso-V0. */
/* SOTBV2: Table of NBPNTV/2 sums of 2 index points */
/* NBPNTV-II+1 and II, for II = 1, NBPNTV/2 on iso-V1. */
/* DITBV1: Table of NBPNTV/2 differences of 2 index points */
/* NBPNTV-II+1 and II, for II = 1, NBPNTV/2 on iso-V0. */
/* DITBV2: Table of NBPNTV/2 differences of 2 index points */
/* NBPNTV-II+1 and II, for II = 1, NBPNTV/2 on iso-V1. */
/* SOSOTB: Preinitialized table (input/output argument). */
/* DISOTB: Preinitialized table (input/output argument). */
/* SODITB: Preinitialized table (input/output argument). */
/* DIDITB: Preinitialized table (input/output argument) */
/* OUTPUT ARGUMENTS : */
/* ------------------- */
/* FPNTAB: Auxiliary table. */
/* VHERMT: Table of 2*(IORDRV+1) coeff. of 2*(IORDRV+1) polynoms of Hermite. */
/* SOSOTB: Table where the terms of constraints are added */
/* C(ui,vj) + C(ui,-vj) + C(-ui,vj) + C(-ui,-vj) */
/* with ui and vj positive roots of the Legendre polynom */
/* of degree NBPNTU and NBPNTV respectively. */
/* DISOTB: Table where the terms of constraints are added */
/* C(ui,vj) + C(ui,-vj) - C(-ui,vj) - C(-ui,-vj) */
/* with ui and vj positive roots of the polynom of Legendre */
/* of degree NBPNTU and NBPNTV respectively. */
/* SODITB: Table where the terms of constraints are added */
/* C(ui,vj) - C(ui,-vj) + C(-ui,vj) - C(-ui,-vj) */
/* with ui and vj positive roots of the polynom of Legendre */
/* of degree NBPNTU and NBPNTV respectively. */
/* DIDITB: Table where the terms of constraints are added */
/* C(ui,vj) - C(ui,-vj) - C(-ui,vj) + C(-ui,-vj) */
/* with ui and vj positive roots of the polynom of Legendre */
/* of degree NBPNTU and NBPNTV respectively. */
/* COMMONS USED : */
/* ---------------- */
/* REFERENCES CALLED : */
/* ----------------------- */
/* DESCRIPTION/NOTES/LIMITATIONS : */
/* ----------------------------------- */
/* > */
/* **********************************************************************
*/
/* Name of the routine */
/* Parameter adjustments */
diditb_dim1 = *nbpntu / 2 + 1;
diditb_dim2 = *nbpntv / 2 + 1;
diditb_offset = diditb_dim1 * diditb_dim2;
diditb -= diditb_offset;
disotb_dim1 = *nbpntu / 2;
disotb_dim2 = *nbpntv / 2;
disotb_offset = disotb_dim1 * (disotb_dim2 + 1) + 1;
disotb -= disotb_offset;
soditb_dim1 = *nbpntu / 2;
soditb_dim2 = *nbpntv / 2;
soditb_offset = soditb_dim1 * (soditb_dim2 + 1) + 1;
soditb -= soditb_offset;
sosotb_dim1 = *nbpntu / 2 + 1;
sosotb_dim2 = *nbpntv / 2 + 1;
sosotb_offset = sosotb_dim1 * sosotb_dim2;
sosotb -= sosotb_offset;
--vrootl;
vhermt_dim1 = (*iordrv << 1) + 2;
vhermt_offset = vhermt_dim1;
vhermt -= vhermt_offset;
fpntab_dim1 = *nbpntv;
fpntab_offset = fpntab_dim1 + 1;
fpntab -= fpntab_offset;
ditbv2_dim1 = *nbpntu / 2 + 1;
ditbv2_dim2 = *ndimen;
ditbv2_offset = ditbv2_dim1 * (ditbv2_dim2 + 1);
ditbv2 -= ditbv2_offset;
ditbv1_dim1 = *nbpntu / 2 + 1;
ditbv1_dim2 = *ndimen;
ditbv1_offset = ditbv1_dim1 * (ditbv1_dim2 + 1);
ditbv1 -= ditbv1_offset;
sotbv2_dim1 = *nbpntu / 2 + 1;
sotbv2_dim2 = *ndimen;
sotbv2_offset = sotbv2_dim1 * (sotbv2_dim2 + 1);
sotbv2 -= sotbv2_offset;
sotbv1_dim1 = *nbpntu / 2 + 1;
sotbv1_dim2 = *ndimen;
sotbv1_offset = sotbv1_dim1 * (sotbv1_dim2 + 1);
sotbv1 -= sotbv1_offset;
/* Function Body */
ibb = AdvApp2Var_SysBase::mnfndeb_();
if (ibb >= 3)
{
AdvApp2Var_SysBase::mgenmsg_("MMA2CD2", 7L);
}
/* ------------------- Discretization of Hermit polynoms -----------
*/
ncfhv = (*iordrv + 1) << 1;
i__1 = ncfhv;
for (ii = 1; ii <= i__1; ++ii)
{
i__2 = *nbpntv;
for (jj = 1; jj <= i__2; ++jj)
{
AdvApp2Var_MathBase::mmmpocur_(&ncfhv,
&c__1,
&ncfhv,
&vhermt[ii * vhermt_dim1],
&vrootl[jj],
&fpntab[jj + ii * fpntab_dim1]);
/* L60: */
}
/* L50: */
}
/* ---- The discretizations of polynoms of constraints are subtracted ----
*/
nuroo = *nbpntu / 2;
nvroo = *nbpntv / 2;
i__1 = *ndimen;
for (nd = 1; nd <= i__1; ++nd)
{
i__2 = *iordrv + 1;
for (ii = 1; ii <= i__2; ++ii)
{
i__3 = nuroo;
for (kk = 1; kk <= i__3; ++kk)
{
bid1 = sotbv1[kk + (nd + ii * sotbv1_dim2) * sotbv1_dim1];
bid2 = sotbv2[kk + (nd + ii * sotbv2_dim2) * sotbv2_dim1];
bid3 = ditbv1[kk + (nd + ii * ditbv1_dim2) * ditbv1_dim1];
bid4 = ditbv2[kk + (nd + ii * ditbv2_dim2) * ditbv2_dim1];
i__4 = nvroo;
for (jj = 1; jj <= i__4; ++jj)
{
jjp = (*nbpntv + 1) / 2 + jj;
jjm = nvroo - jj + 1;
sosotb[kk + (jj + nd * sosotb_dim2) * sosotb_dim1] =
sosotb[kk + (jj + nd * sosotb_dim2) * sosotb_dim1]
- bid1
* (fpntab[jjp + ((ii << 1) - 1) * fpntab_dim1]
+ fpntab[jjm + ((ii << 1) - 1) * fpntab_dim1])
- bid2
* (fpntab[jjp + (ii << 1) * fpntab_dim1] + fpntab[jjm + (ii << 1) * fpntab_dim1]);
disotb[kk + (jj + nd * disotb_dim2) * disotb_dim1] =
disotb[kk + (jj + nd * disotb_dim2) * disotb_dim1]
- bid3
* (fpntab[jjp + ((ii << 1) - 1) * fpntab_dim1]
+ fpntab[jjm + ((ii << 1) - 1) * fpntab_dim1])
- bid4
* (fpntab[jjp + (ii << 1) * fpntab_dim1] + fpntab[jjm + (ii << 1) * fpntab_dim1]);
soditb[kk + (jj + nd * soditb_dim2) * soditb_dim1] =
soditb[kk + (jj + nd * soditb_dim2) * soditb_dim1]
- bid1
* (fpntab[jjp + ((ii << 1) - 1) * fpntab_dim1]
- fpntab[jjm + ((ii << 1) - 1) * fpntab_dim1])
- bid2
* (fpntab[jjp + (ii << 1) * fpntab_dim1] - fpntab[jjm + (ii << 1) * fpntab_dim1]);
diditb[kk + (jj + nd * diditb_dim2) * diditb_dim1] =
diditb[kk + (jj + nd * diditb_dim2) * diditb_dim1]
- bid3
* (fpntab[jjp + ((ii << 1) - 1) * fpntab_dim1]
- fpntab[jjm + ((ii << 1) - 1) * fpntab_dim1])
- bid4
* (fpntab[jjp + (ii << 1) * fpntab_dim1] - fpntab[jjm + (ii << 1) * fpntab_dim1]);
/* L400: */
}
/* L300: */
}
/* L200: */
}
/* ------------ Case when the discretization is done only on the roots */
/* ---------- of Legendre polynom of uneven degree, 0 is root */
if (*nbpntv % 2 == 1)
{
i__2 = *iordrv + 1;
for (ii = 1; ii <= i__2; ++ii)
{
i__3 = nuroo;
for (kk = 1; kk <= i__3; ++kk)
{
bid1 = sotbv1[kk + (nd + ii * sotbv1_dim2) * sotbv1_dim1]
* fpntab[nvroo + 1 + ((ii << 1) - 1) * fpntab_dim1]
+ sotbv2[kk + (nd + ii * sotbv2_dim2) * sotbv2_dim1]
* fpntab[nvroo + 1 + (ii << 1) * fpntab_dim1];
sosotb[kk + nd * sosotb_dim2 * sosotb_dim1] -= bid1;
bid2 = ditbv1[kk + (nd + ii * ditbv1_dim2) * ditbv1_dim1]
* fpntab[nvroo + 1 + ((ii << 1) - 1) * fpntab_dim1]
+ ditbv2[kk + (nd + ii * ditbv2_dim2) * ditbv2_dim1]
* fpntab[nvroo + 1 + (ii << 1) * fpntab_dim1];
diditb[kk + nd * diditb_dim2 * diditb_dim1] -= bid2;
/* L550: */
}
/* L500: */
}
}
if (*nbpntu % 2 == 1)
{
i__2 = *iordrv + 1;
for (ii = 1; ii <= i__2; ++ii)
{
i__3 = nvroo;
for (jj = 1; jj <= i__3; ++jj)
{
jjp = (*nbpntv + 1) / 2 + jj;
jjm = nvroo - jj + 1;
bid1 =
sotbv1[(nd + ii * sotbv1_dim2) * sotbv1_dim1]
* (fpntab[jjp + ((ii << 1) - 1) * fpntab_dim1]
+ fpntab[jjm + ((ii << 1) - 1) * fpntab_dim1])
+ sotbv2[(nd + ii * sotbv2_dim2) * sotbv2_dim1]
* (fpntab[jjp + (ii << 1) * fpntab_dim1] + fpntab[jjm + (ii << 1) * fpntab_dim1]);
sosotb[(jj + nd * sosotb_dim2) * sosotb_dim1] -= bid1;
bid2 =
sotbv1[(nd + ii * sotbv1_dim2) * sotbv1_dim1]
* (fpntab[jjp + ((ii << 1) - 1) * fpntab_dim1]
- fpntab[jjm + ((ii << 1) - 1) * fpntab_dim1])
+ sotbv2[(nd + ii * sotbv2_dim2) * sotbv2_dim1]
* (fpntab[jjp + (ii << 1) * fpntab_dim1] - fpntab[jjm + (ii << 1) * fpntab_dim1]);
diditb[jj + nd * diditb_dim2 * diditb_dim1] -= bid2;
/* L650: */
}
/* L600: */
}
}
if (*nbpntu % 2 == 1 && *nbpntv % 2 == 1)
{
i__2 = *iordrv + 1;
for (ii = 1; ii <= i__2; ++ii)
{
bid1 = sotbv1[(nd + ii * sotbv1_dim2) * sotbv1_dim1]
* fpntab[nvroo + 1 + ((ii << 1) - 1) * fpntab_dim1]
+ sotbv2[(nd + ii * sotbv2_dim2) * sotbv2_dim1]
* fpntab[nvroo + 1 + (ii << 1) * fpntab_dim1];
sosotb[nd * sosotb_dim2 * sosotb_dim1] -= bid1;
/* L700: */
}
}
/* L100: */
}
goto L9999;
/* ------------------------------ The End -------------------------------
*/
L9999:
if (ibb >= 3)
{
AdvApp2Var_SysBase::mgsomsg_("MMA2CD2", 7L);
}
return 0;
} /* mma2cd2_ */
//=================================================================================================
int mma2cd3_(int* ndimen,
int* nbpntu,
double* urootl,
int* nbpntv,
int* iordru,
double* sotbu1,
double* sotbu2,
double* ditbu1,
double* ditbu2,
double* fpntab,
double* uhermt,
double* sosotb,
double* soditb,
double* disotb,
double* diditb)
{
int c__1 = 1;
/* System generated locals */
int sotbu1_dim1, sotbu1_dim2, sotbu1_offset, sotbu2_dim1, sotbu2_dim2, sotbu2_offset, ditbu1_dim1,
ditbu1_dim2, ditbu1_offset, ditbu2_dim1, ditbu2_dim2, ditbu2_offset, fpntab_dim1, fpntab_offset,
uhermt_dim1, uhermt_offset, sosotb_dim1, sosotb_dim2, sosotb_offset, diditb_dim1, diditb_dim2,
diditb_offset, soditb_dim1, soditb_dim2, soditb_offset, disotb_dim1, disotb_dim2, disotb_offset,
i__1, i__2, i__3, i__4;
/* Local variables */
int ncfhu, nuroo, nvroo, ii, nd, jj, kk, ibb, kkm, kkp;
double bid1, bid2, bid3, bid4;
/* **********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* Discretisation on the parameters of polynoms of interpolation */
/* of constraints on 2 borders iso-U of order IORDRU. */
/* KEYWORDS : */
/* ----------- */
/* TOUS, AB_SPECIFI::CONTRAINTE&, DISCRETISATION, &POINT */
/* INPUT ARGUMENTS : */
/* ------------------ */
/* NDIMEN: Dimension of the space. */
/* NBPNTU: Nb of INTERNAL parameters of discretisation by U. */
/* This is also the nb of root of Legendre polynom where discretization is done. */
/* UROOTL: Table of parameters of discretisation ON (-1,1) by U.
*/
/* NBPNTV: Nb of INTERNAL parameters of discretisation by V. */
/* This is also the nb of root of Legendre polynom where discretization is done. */
/* IORDRV: Order of constraint imposed at the extremities of iso-V */
/* = 0, calculate the extremities of iso-V */
/* = 1, calculate, additionally, the 1st derivative in the direction of iso-V */
/* = 2, calculate, additionally, the 2nd derivative in the direction of iso-V */
/* SOTBU1: Table of NBPNTU/2 sums of 2 index points */
/* NBPNTU-II+1 and II, for II = 1, NBPNTU/2 on iso-V0. */
/* SOTBU2: Table of NBPNTV/2 sums of 2 index points */
/* NBPNTU-II+1 and II, for II = 1, NBPNTU/2 on iso-V1. */
/* DITBU1: Table of NBPNTU/2 differences of 2 index points */
/* NBPNTU-II+1 and II, for II = 1, NBPNTU/2 on iso-V0. */
/* DITBU2: Table of NBPNTU/2 differences of 2 index points */
/* NBPNTU-II+1 and II, for II = 1, NBPNTU/2 on iso-V1. */
/* SOSOTB: Preinitialized table (input/output argument). */
/* DISOTB: Preinitialized table (input/output argument). */
/* SODITB: Preinitialized table (input/output argument). */
/* DIDITB: Preinitialized table (input/output argument) */
/* OUTPUT ARGUMENTS : */
/* ------------------- */
/* FPNTAB: Auxiliary table. */
/* UHERMT: Table of 2*(IORDRU+1) coeff. of 2*(IORDRU+1) polynoms of Hermite. */
/* SOSOTB: Table where the terms of constraints are added */
/* C(ui,vj) + C(ui,-vj) + C(-ui,vj) + C(-ui,-vj) */
/* with ui and vj positive roots of the Legendre polynom */
/* of degree NBPNTU and NBPNTV respectively. */
/* DISOTB: Table where the terms of constraints are added */
/* C(ui,vj) + C(ui,-vj) - C(-ui,vj) - C(-ui,-vj) */
/* with ui and vj positive roots of the polynom of Legendre */
/* of degree NBPNTU and NBPNTV respectively. */
/* SODITB: Table where the terms of constraints are added */
/* C(ui,vj) - C(ui,-vj) + C(-ui,vj) - C(-ui,-vj) */
/* with ui and vj positive roots of the polynom of Legendre */
/* of degree NBPNTU and NBPNTV respectively. */
/* DIDITB: Table where the terms of constraints are added */
/* C(ui,vj) - C(ui,-vj) - C(-ui,vj) + C(-ui,-vj) */
/* with ui and vj positive roots of the polynom of Legendre */
/* of degree NBPNTU and NBPNTV respectively. */
/* COMMONS USED : */
/* ---------------- */
/* REFERENCES CALLED : */
/* ----------------------- */
/* DESCRIPTION/NOTES/LIMITATIONS : */
/* ----------------------------------- */
/* $ HISTORIQUE DES MODIFICATIONS : */
/* -------------------------------- */
/* 08-08-1991: RBD; Creation. */
/* > */
/* **********************************************************************
*/
/* Name of the routine */
/* Parameter adjustments */
--urootl;
diditb_dim1 = *nbpntu / 2 + 1;
diditb_dim2 = *nbpntv / 2 + 1;
diditb_offset = diditb_dim1 * diditb_dim2;
diditb -= diditb_offset;
disotb_dim1 = *nbpntu / 2;
disotb_dim2 = *nbpntv / 2;
disotb_offset = disotb_dim1 * (disotb_dim2 + 1) + 1;
disotb -= disotb_offset;
soditb_dim1 = *nbpntu / 2;
soditb_dim2 = *nbpntv / 2;
soditb_offset = soditb_dim1 * (soditb_dim2 + 1) + 1;
soditb -= soditb_offset;
sosotb_dim1 = *nbpntu / 2 + 1;
sosotb_dim2 = *nbpntv / 2 + 1;
sosotb_offset = sosotb_dim1 * sosotb_dim2;
sosotb -= sosotb_offset;
uhermt_dim1 = (*iordru << 1) + 2;
uhermt_offset = uhermt_dim1;
uhermt -= uhermt_offset;
fpntab_dim1 = *nbpntu;
fpntab_offset = fpntab_dim1 + 1;
fpntab -= fpntab_offset;
ditbu2_dim1 = *nbpntv / 2 + 1;
ditbu2_dim2 = *ndimen;
ditbu2_offset = ditbu2_dim1 * (ditbu2_dim2 + 1);
ditbu2 -= ditbu2_offset;
ditbu1_dim1 = *nbpntv / 2 + 1;
ditbu1_dim2 = *ndimen;
ditbu1_offset = ditbu1_dim1 * (ditbu1_dim2 + 1);
ditbu1 -= ditbu1_offset;
sotbu2_dim1 = *nbpntv / 2 + 1;
sotbu2_dim2 = *ndimen;
sotbu2_offset = sotbu2_dim1 * (sotbu2_dim2 + 1);
sotbu2 -= sotbu2_offset;
sotbu1_dim1 = *nbpntv / 2 + 1;
sotbu1_dim2 = *ndimen;
sotbu1_offset = sotbu1_dim1 * (sotbu1_dim2 + 1);
sotbu1 -= sotbu1_offset;
/* Function Body */
ibb = AdvApp2Var_SysBase::mnfndeb_();
if (ibb >= 3)
{
AdvApp2Var_SysBase::mgenmsg_("MMA2CD3", 7L);
}
/* ------------------- Discretization of polynoms of Hermit -----------
*/
ncfhu = (*iordru + 1) << 1;
i__1 = ncfhu;
for (ii = 1; ii <= i__1; ++ii)
{
i__2 = *nbpntu;
for (kk = 1; kk <= i__2; ++kk)
{
AdvApp2Var_MathBase::mmmpocur_(&ncfhu,
&c__1,
&ncfhu,
&uhermt[ii * uhermt_dim1],
&urootl[kk],
&fpntab[kk + ii * fpntab_dim1]);
/* L60: */
}
/* L50: */
}
/* ---- The discretizations of polynoms of constraints are subtracted ----
*/
nvroo = *nbpntv / 2;
nuroo = *nbpntu / 2;
i__1 = *ndimen;
for (nd = 1; nd <= i__1; ++nd)
{
i__2 = *iordru + 1;
for (ii = 1; ii <= i__2; ++ii)
{
i__3 = nvroo;
for (jj = 1; jj <= i__3; ++jj)
{
bid1 = sotbu1[jj + (nd + ii * sotbu1_dim2) * sotbu1_dim1];
bid2 = sotbu2[jj + (nd + ii * sotbu2_dim2) * sotbu2_dim1];
bid3 = ditbu1[jj + (nd + ii * ditbu1_dim2) * ditbu1_dim1];
bid4 = ditbu2[jj + (nd + ii * ditbu2_dim2) * ditbu2_dim1];
i__4 = nuroo;
for (kk = 1; kk <= i__4; ++kk)
{
kkp = (*nbpntu + 1) / 2 + kk;
kkm = nuroo - kk + 1;
sosotb[kk + (jj + nd * sosotb_dim2) * sosotb_dim1] =
sosotb[kk + (jj + nd * sosotb_dim2) * sosotb_dim1]
- bid1
* (fpntab[kkp + ((ii << 1) - 1) * fpntab_dim1]
+ fpntab[kkm + ((ii << 1) - 1) * fpntab_dim1])
- bid2
* (fpntab[kkp + (ii << 1) * fpntab_dim1] + fpntab[kkm + (ii << 1) * fpntab_dim1]);
disotb[kk + (jj + nd * disotb_dim2) * disotb_dim1] =
disotb[kk + (jj + nd * disotb_dim2) * disotb_dim1]
- bid1
* (fpntab[kkp + ((ii << 1) - 1) * fpntab_dim1]
- fpntab[kkm + ((ii << 1) - 1) * fpntab_dim1])
- bid2
* (fpntab[kkp + (ii << 1) * fpntab_dim1] - fpntab[kkm + (ii << 1) * fpntab_dim1]);
soditb[kk + (jj + nd * soditb_dim2) * soditb_dim1] =
soditb[kk + (jj + nd * soditb_dim2) * soditb_dim1]
- bid3
* (fpntab[kkp + ((ii << 1) - 1) * fpntab_dim1]
+ fpntab[kkm + ((ii << 1) - 1) * fpntab_dim1])
- bid4
* (fpntab[kkp + (ii << 1) * fpntab_dim1] + fpntab[kkm + (ii << 1) * fpntab_dim1]);
diditb[kk + (jj + nd * diditb_dim2) * diditb_dim1] =
diditb[kk + (jj + nd * diditb_dim2) * diditb_dim1]
- bid3
* (fpntab[kkp + ((ii << 1) - 1) * fpntab_dim1]
- fpntab[kkm + ((ii << 1) - 1) * fpntab_dim1])
- bid4
* (fpntab[kkp + (ii << 1) * fpntab_dim1] - fpntab[kkm + (ii << 1) * fpntab_dim1]);
/* L400: */
}
/* L300: */
}
/* L200: */
}
/* ------------ Case when the discretization is done only on the roots */
/* ---------- of Legendre polynom of uneven degree, 0 is root */
if (*nbpntu % 2 == 1)
{
i__2 = *iordru + 1;
for (ii = 1; ii <= i__2; ++ii)
{
i__3 = nvroo;
for (jj = 1; jj <= i__3; ++jj)
{
bid1 = sotbu1[jj + (nd + ii * sotbu1_dim2) * sotbu1_dim1]
* fpntab[nuroo + 1 + ((ii << 1) - 1) * fpntab_dim1]
+ sotbu2[jj + (nd + ii * sotbu2_dim2) * sotbu2_dim1]
* fpntab[nuroo + 1 + (ii << 1) * fpntab_dim1];
sosotb[(jj + nd * sosotb_dim2) * sosotb_dim1] -= bid1;
bid2 = ditbu1[jj + (nd + ii * ditbu1_dim2) * ditbu1_dim1]
* fpntab[nuroo + 1 + ((ii << 1) - 1) * fpntab_dim1]
+ ditbu2[jj + (nd + ii * ditbu2_dim2) * ditbu2_dim1]
* fpntab[nuroo + 1 + (ii << 1) * fpntab_dim1];
diditb[(jj + nd * diditb_dim2) * diditb_dim1] -= bid2;
/* L550: */
}
/* L500: */
}
}
if (*nbpntv % 2 == 1)
{
i__2 = *iordru + 1;
for (ii = 1; ii <= i__2; ++ii)
{
i__3 = nuroo;
for (kk = 1; kk <= i__3; ++kk)
{
kkp = (*nbpntu + 1) / 2 + kk;
kkm = nuroo - kk + 1;
bid1 =
sotbu1[(nd + ii * sotbu1_dim2) * sotbu1_dim1]
* (fpntab[kkp + ((ii << 1) - 1) * fpntab_dim1]
+ fpntab[kkm + ((ii << 1) - 1) * fpntab_dim1])
+ sotbu2[(nd + ii * sotbu2_dim2) * sotbu2_dim1]
* (fpntab[kkp + (ii << 1) * fpntab_dim1] + fpntab[kkm + (ii << 1) * fpntab_dim1]);
sosotb[kk + nd * sosotb_dim2 * sosotb_dim1] -= bid1;
bid2 =
sotbu1[(nd + ii * sotbu1_dim2) * sotbu1_dim1]
* (fpntab[kkp + ((ii << 1) - 1) * fpntab_dim1]
- fpntab[kkm + ((ii << 1) - 1) * fpntab_dim1])
+ sotbu2[(nd + ii * sotbu2_dim2) * sotbu2_dim1]
* (fpntab[kkp + (ii << 1) * fpntab_dim1] - fpntab[kkm + (ii << 1) * fpntab_dim1]);
diditb[kk + nd * diditb_dim2 * diditb_dim1] -= bid2;
/* L650: */
}
/* L600: */
}
}
if (*nbpntu % 2 == 1 && *nbpntv % 2 == 1)
{
i__2 = *iordru + 1;
for (ii = 1; ii <= i__2; ++ii)
{
bid1 = sotbu1[(nd + ii * sotbu1_dim2) * sotbu1_dim1]
* fpntab[nuroo + 1 + ((ii << 1) - 1) * fpntab_dim1]
+ sotbu2[(nd + ii * sotbu2_dim2) * sotbu2_dim1]
* fpntab[nuroo + 1 + (ii << 1) * fpntab_dim1];
sosotb[nd * sosotb_dim2 * sosotb_dim1] -= bid1;
/* L700: */
}
}
/* L100: */
}
goto L9999;
/* ------------------------------ The End -------------------------------
*/
L9999:
if (ibb >= 3)
{
AdvApp2Var_SysBase::mgsomsg_("MMA2CD3", 7L);
}
return 0;
} /* mma2cd3_ */
//=================================================================================================
int AdvApp2Var_ApproxF2var::mma2cdi_(int* ndimen,
int* nbpntu,
double* urootl,
int* nbpntv,
double* vrootl,
int* iordru,
int* iordrv,
double* contr1,
double* contr2,
double* contr3,
double* contr4,
double* sotbu1,
double* sotbu2,
double* ditbu1,
double* ditbu2,
double* sotbv1,
double* sotbv2,
double* ditbv1,
double* ditbv2,
double* sosotb,
double* soditb,
double* disotb,
double* diditb,
int* iercod)
{
int c__8 = 8;
/* System generated locals */
int contr1_dim1, contr1_dim2, contr1_offset, contr2_dim1, contr2_dim2, contr2_offset, contr3_dim1,
contr3_dim2, contr3_offset, contr4_dim1, contr4_dim2, contr4_offset, sosotb_dim1, sosotb_dim2,
sosotb_offset, diditb_dim1, diditb_dim2, diditb_offset, soditb_dim1, soditb_dim2, soditb_offset,
disotb_dim1, disotb_dim2, disotb_offset;
/* Local variables */
int ilong;
intptr_t iofwr;
double* wrkar = nullptr;
double* wrkar_off;
int iszwr;
int ibb, ier = 0;
int isz1, isz2, isz3, isz4;
intptr_t ipt1, ipt2, ipt3;
/* **********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* Discretisation on the parameters of polynomes of interpolation */
/* of constraints of order IORDRE. */
/* KEYWORDS : */
/* ----------- */
/* TOUS, AB_SPECIFI::CONTRAINTE&, DISCRETISATION, &POINT */
//* INPUT ARGUMENTS : */
/* ------------------ */
/* NDIMEN: Dimension of the space. */
/* NBPNTU: Nb of INTERNAL parameters of discretisation by U. */
/* This is also the nb of root of Legendre polynom where discretization is done. */
/* UROOTL: Table of parameters of discretisation ON (-1,1) by U.
*/
/* NBPNTV: Nb of INTERNAL parameters of discretisation by V. */
/* This is also the nb of root of Legendre polynom where discretization is done. */
/* VROOTL: Table of parameters of discretisation ON (-1,1) by V.*/
/* IORDRV: Order of constraint imposed at the extremities of iso-U */
/* = 0, calculate the extremities of iso-U */
/* = 1, calculate, additionally, the 1st derivative in the direction of iso-U */
/* = 2, calculate, additionally, the 2nd derivative in the direction of iso-U */
/* IORDRU: Order of constraint imposed at the extremities of iso-V */
/* = 0, calculate the extremities of iso-V */
/* = 1, calculate, additionally, the 1st derivative in the direction of iso-V */
/* = 2, calculate, additionally, the 2nd derivative in the direction of iso-V */
/* CONTR1: Contains, if IORDRU and IORDRV>=0, the values at the */
/* extremities of F(U0,V0) and its derivatives. */
/* CONTR2: Contains, if IORDRU and IORDRV>=0, the values at the */
/* extremities of F(U1,V0) and its derivatives. */
/* CONTR3: Contains, if IORDRU and IORDRV>=0, the values at the */
/* extremities of F(U0,V1) and its derivatives. */
/* CONTR4: Contains, if IORDRU and IORDRV>=0, the values at the */
/* extremities of F(U1,V1) and its derivatives. */
/* SOTBU1: Table of NBPNTU/2 sums of 2 index points */
/* NBPNTU-II+1 and II, for II = 1, NBPNTU/2 on iso-V0. */
/* SOTBU2: Table of NBPNTV/2 sums of 2 index points */
/* NBPNTU-II+1 and II, for II = 1, NBPNTU/2 on iso-V1. */
/* DITBU1: Table of NBPNTU/2 differences of 2 index points */
/* NBPNTU-II+1 and II, for II = 1, NBPNTU/2 on iso-V0. */
/* DITBU2: Table of NBPNTU/2 differences of 2 index points */
/* NBPNTU-II+1 and II, for II = 1, NBPNTU/2 on iso-V1. */
/* SOTBV1: Table of NBPNTV/2 sums of 2 index points */
/* NBPNTV-II+1 and II, for II = 1, NBPNTV/2 on iso-V0. */
/* SOTBV2: Table of NBPNTV/2 sums of 2 index points */
/* NBPNTV-II+1 and II, for II = 1, NBPNTV/2 on iso-V1. */
/* DITBV1: Table of NBPNTV/2 differences of 2 index points */
/* NBPNTV-II+1 and II, for II = 1, NBPNTV/2 on iso-V0. */
/* DITBV2: Table of NBPNTV/2 differences of 2 index points */
/* NBPNTV-II+1 and II, for II = 1, NBPNTV/2 on iso-V1. */
/* SOSOTB: Preinitialized table (input/output argument). */
/* DISOTB: Preinitialized table (input/output argument). */
/* SODITB: Preinitialized table (input/output argument). */
/* DIDITB: Preinitialized table (input/output argument) */
/* ARGUMENTS DE SORTIE : */
/* ------------------- */
/* SOSOTB: Table where the terms of constraints are added */
/* C(ui,vj) + C(ui,-vj) + C(-ui,vj) + C(-ui,-vj) */
/* with ui and vj positive roots of the Legendre polynom */
/* of degree NBPNTU and NBPNTV respectively. */
/* DISOTB: Table where the terms of constraints are added */
/* C(ui,vj) + C(ui,-vj) - C(-ui,vj) - C(-ui,-vj) */
/* with ui and vj positive roots of the polynom of Legendre */
/* of degree NBPNTU and NBPNTV respectively. */
/* SODITB: Table where the terms of constraints are added */
/* C(ui,vj) - C(ui,-vj) + C(-ui,vj) - C(-ui,-vj) */
/* with ui and vj positive roots of the polynom of Legendre */
/* of degree NBPNTU and NBPNTV respectively. */
/* DIDITB: Table where the terms of constraints are added */
/* C(ui,vj) - C(ui,-vj) - C(-ui,vj) + C(-ui,-vj) */
/* with ui and vj positive roots of the polynom of Legendre */
/* of degree NBPNTU and NBPNTV respectively. */
/* IERCOD: = 0, OK, */
/* = 1, Value or IORDRV or IORDRU is out of allowed values. */
/* =13, Pb of dynamic allocation. */
/* COMMONS USED : */
/* ---------------- */
/* REFERENCES CALLED : */
/* -------------------- */
/* DESCRIPTION/NOTES/LIMITATIONS : */
/* ------------------------------- */
/* > */
/* **********************************************************************
*/
/* The name of the routine */
/* Parameter adjustments */
--urootl;
diditb_dim1 = *nbpntu / 2 + 1;
diditb_dim2 = *nbpntv / 2 + 1;
diditb_offset = diditb_dim1 * diditb_dim2;
diditb -= diditb_offset;
disotb_dim1 = *nbpntu / 2;
disotb_dim2 = *nbpntv / 2;
disotb_offset = disotb_dim1 * (disotb_dim2 + 1) + 1;
disotb -= disotb_offset;
soditb_dim1 = *nbpntu / 2;
soditb_dim2 = *nbpntv / 2;
soditb_offset = soditb_dim1 * (soditb_dim2 + 1) + 1;
soditb -= soditb_offset;
sosotb_dim1 = *nbpntu / 2 + 1;
sosotb_dim2 = *nbpntv / 2 + 1;
sosotb_offset = sosotb_dim1 * sosotb_dim2;
sosotb -= sosotb_offset;
--vrootl;
contr4_dim1 = *ndimen;
contr4_dim2 = *iordru + 2;
contr4_offset = contr4_dim1 * (contr4_dim2 + 1) + 1;
contr4 -= contr4_offset;
contr3_dim1 = *ndimen;
contr3_dim2 = *iordru + 2;
contr3_offset = contr3_dim1 * (contr3_dim2 + 1) + 1;
contr3 -= contr3_offset;
contr2_dim1 = *ndimen;
contr2_dim2 = *iordru + 2;
contr2_offset = contr2_dim1 * (contr2_dim2 + 1) + 1;
contr2 -= contr2_offset;
contr1_dim1 = *ndimen;
contr1_dim2 = *iordru + 2;
contr1_offset = contr1_dim1 * (contr1_dim2 + 1) + 1;
contr1 -= contr1_offset;
--sotbu1;
--sotbu2;
--ditbu1;
--ditbu2;
--sotbv1;
--sotbv2;
--ditbv1;
--ditbv2;
AdvApp2Var_SysBase anAdvApp2Var_SysBase;
/* Function Body */
ibb = AdvApp2Var_SysBase::mnfndeb_();
if (ibb >= 3)
{
AdvApp2Var_SysBase::mgenmsg_("MMA2CDI", 7L);
}
*iercod = 0;
iofwr = 0;
if (*iordru < -1 || *iordru > 2)
{
goto L9100;
}
if (*iordrv < -1 || *iordrv > 2)
{
goto L9100;
}
/* ------------------------- Set to zero --------------------------------
*/
ilong = (*nbpntu / 2 + 1) * (*nbpntv / 2 + 1) * *ndimen;
AdvApp2Var_SysBase::mvriraz_(&ilong, &sosotb[sosotb_offset]);
AdvApp2Var_SysBase::mvriraz_(&ilong, &diditb[diditb_offset]);
ilong = *nbpntu / 2 * (*nbpntv / 2) * *ndimen;
AdvApp2Var_SysBase::mvriraz_(&ilong, &soditb[soditb_offset]);
AdvApp2Var_SysBase::mvriraz_(&ilong, &disotb[disotb_offset]);
if (*iordru == -1 && *iordrv == -1)
{
goto L9999;
}
isz1 = ((*iordru + 1) << 2) * (*iordru + 1);
isz2 = ((*iordrv + 1) << 2) * (*iordrv + 1);
isz3 = ((*iordru + 1) << 1) * *nbpntu;
isz4 = ((*iordrv + 1) << 1) * *nbpntv;
iszwr = isz1 + isz2 + isz3 + isz4;
anAdvApp2Var_SysBase.mcrrqst_(&c__8, &iszwr, wrkar, &iofwr, &ier);
if (ier > 0)
{
goto L9013;
}
wrkar_off = reinterpret_cast<double*>(iofwr * sizeof(double));
ipt1 = isz1;
ipt2 = ipt1 + isz2;
ipt3 = ipt2 + isz3;
if (*iordru >= 0 && *iordru <= 2)
{
/* --- Return 2*(IORDRU+1) coeff of 2*(IORDRU+1) polynoms of Hermite
--- */
AdvApp2Var_ApproxF2var::mma1her_(iordru, wrkar_off, iercod);
if (*iercod > 0)
{
goto L9100;
}
/* ---- Subtract discretizations of polynoms of constraints
---- */
mma2cd3_(ndimen,
nbpntu,
&urootl[1],
nbpntv,
iordru,
&sotbu1[1],
&sotbu2[1],
&ditbu1[1],
&ditbu2[1],
&wrkar_off[ipt2],
wrkar_off,
&sosotb[sosotb_offset],
&soditb[soditb_offset],
&disotb[disotb_offset],
&diditb[diditb_offset]);
}
if (*iordrv >= 0 && *iordrv <= 2)
{
/* --- Return 2*(IORDRV+1) coeff of 2*(IORDRV+1) polynoms of Hermite
--- */
AdvApp2Var_ApproxF2var::mma1her_(iordrv, &wrkar_off[ipt1], iercod);
if (*iercod > 0)
{
goto L9100;
}
/* ---- Subtract discretisations of polynoms of constraint
---- */
mma2cd2_(ndimen,
nbpntu,
nbpntv,
&vrootl[1],
iordrv,
&sotbv1[1],
&sotbv2[1],
&ditbv1[1],
&ditbv2[1],
&wrkar_off[ipt3],
&wrkar_off[ipt1],
&sosotb[sosotb_offset],
&soditb[soditb_offset],
&disotb[disotb_offset],
&diditb[diditb_offset]);
}
/* --------------- Subtract constraints of corners ----------------
*/
if (*iordru >= 0 && *iordrv >= 0)
{
mma2cd1_(ndimen,
nbpntu,
&urootl[1],
nbpntv,
&vrootl[1],
iordru,
iordrv,
&contr1[contr1_offset],
&contr2[contr2_offset],
&contr3[contr3_offset],
&contr4[contr4_offset],
&wrkar_off[ipt2],
&wrkar_off[ipt3],
wrkar_off,
&wrkar_off[ipt1],
&sosotb[sosotb_offset],
&soditb[soditb_offset],
&disotb[disotb_offset],
&diditb[diditb_offset]);
}
goto L9999;
/* ------------------------------ The End -------------------------------
*/
/* --> IORDRE is not within the autorised diapason. */
L9100:
*iercod = 1;
goto L9999;
/* --> PB of dynamic allocation. */
L9013:
*iercod = 13;
goto L9999;
L9999:
if (iofwr != 0)
{
anAdvApp2Var_SysBase.mcrdelt_(&c__8, &iszwr, wrkar, &iofwr, &ier);
}
if (ier > 0)
{
*iercod = 13;
}
AdvApp2Var_SysBase::maermsg_("MMA2CDI", iercod, 7L);
if (ibb >= 3)
{
AdvApp2Var_SysBase::mgsomsg_("MMA2CDI", 7L);
}
return 0;
} /* mma2cdi_ */
//=================================================================================================
int AdvApp2Var_ApproxF2var::mma2ce1_(int* numdec,
int* ndimen,
int* nbsesp,
int* ndimse,
int* ndminu,
int* ndminv,
int* ndguli,
int* ndgvli,
int* ndjacu,
int* ndjacv,
int* iordru,
int* iordrv,
int* nbpntu,
int* nbpntv,
double* epsapr,
double* sosotb,
double* disotb,
double* soditb,
double* diditb,
double* patjac,
double* errmax,
double* errmoy,
int* ndegpu,
int* ndegpv,
int* itydec,
int* iercod)
{
int c__8 = 8;
/* System generated locals */
int sosotb_dim1, sosotb_dim2, sosotb_offset, disotb_dim1, disotb_dim2, disotb_offset, soditb_dim1,
soditb_dim2, soditb_offset, diditb_dim1, diditb_dim2, diditb_offset, patjac_dim1, patjac_dim2,
patjac_offset;
/* Local variables */
long ldbg;
intptr_t iofwr;
double* wrkar = nullptr;
double* wrkar_off;
int iszwr;
int ier;
int isz1, isz2, isz3, isz4, isz5, isz6, isz7;
intptr_t ipt1, ipt2, ipt3, ipt4, ipt5, ipt6;
/* **********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* Calculation of coefficients of polynomial approximation of degree */
/* (NDJACU,NDJACV) of a function F(u,v), starting from its */
/* discretization on roots of Legendre polynom of degree */
/* NBPNTU by U and NBPNTV by V. */
/* KEYWORDS : */
/* ----------- */
/* TOUS,AB_SPECIFI::FONCTION&,APPROXIMATION,&POLYNOME,&ERREUR */
/* INPUT ARGUMENTS : */
/* ------------------ */
/* NUMDEC: Indicates if it is POSSIBLE to cut function F(u,v). */
/* = 5, It is POSSIBLE to cut by U or by V or in both directions simultaneously. */
/* = 4, It is POSSIBLE to cut by U or by V BUT NOT in both */
/* directions simultaneously (cutting by V is preferable). */
/* = 3, It is POSSIBLE to cut by U or by V BUT NOT in both */
/* directions simultaneously (cutting by U is preferable). */
/* = 2, It is POSSIBLE to cut only by V (i.e. insert parameter */
/* of cutting Vj). */
/* = 1, It is POSSIBLE to cut only by U (i.e. insert parameter */
/* of cutting Ui). */
/* = 0, It is not POSSIBLE to cut anything */
/* NDIMEN: Dimension of the space. */
/* NBSESP: Nb of independent sub-spaces on which the errors are calculated. */
/* NDIMSE: Table of dimensions of each of sub-spaces. */
/* NDMINU: Minimum degree by U to be preserved for the approximation. */
/* NDMINV: Minimum degree by V to be preserved for the approximation. */
/* NDGULI: Limit of nb of coefficients by U of the solution. */
/* NDGVLI: Limit of nb of coefficients by V of the solution. */
/* NDJACU: Max degree of the polynom of approximation by U. */
/* The representation in the orthogonal base starts from degree */
/* 0 to degree NDJACU-2*(IORDRU+1). The polynomial base is the base of */
/* Jacobi of order -1 (Legendre), 0, 1 or 2. */
/* It is required that 2*IORDRU+1 <= NDMINU <= NDGULI < NDJACU */
/* NDJACV: Max degree of the polynom of approximation by V. */
/* The representation in the orthogonal base starts from degree */
/* 0 to degree NDJACV-2*(IORDRV+1). The polynomial base is */
/* the base of Jacobi of order -1 (Legendre), 0, 1 or 2 */
/* It is required that 2*IORDRV+1 <= NDMINV <= NDGVLI < NDJACV */
/* IORDRU: Order of the Jacobi base (-1,0,1 or 2) by U. Corresponds */
/* to the step of constraints C0, C1 or C2. */
/* IORDRV: Order of the Jacobi base (-1,0,1 or 2) by U. Corresponds */
/* to the step of constraints C0, C1 or C2. */
/* NBPNTU: Degree of Legendre polynom on the roots which of are */
/* calculated the coefficients of integration by u */
/* by Gauss method. It is required that NBPNTU = 30, 40, */
/* 50 or 61 and NDJACU-2*(IORDRU+1) < NBPNTU. */
/* NBPNTV: Degree of Legendre polynom on the roots which of are */
/* calculated the coefficients of integration by u */
/* by Gauss method. It is required that NBPNTV = 30, 40, */
/* 50 or 61 and NDJACV-2*(IORDRV+1) < NBPNTV. */
/* EPSAPR: Table of NBSESP tolerances imposed on each sub-spaces. */
/* SOSOTB: Table of F(ui,vj) + F(ui,-vj) + F(-ui,vj) + F(-ui,-vj) */
/* with ui and vj - positive roots of the Legendre polynom */
/* of degree NBPNTU and NBPNTV respectively. Additionally, */
/* table SOSOTB(0,j) contains F(0,vj) + F(0,-vj), */
/* table SOSOTB(i,0) contains F(ui,0) + F(-ui,0) and */
/* SOSOTB(0,0) contains F(0,0). */
/* DISOTB: Table of F(ui,vj) + F(ui,-vj) - F(-ui,vj) - F(-ui,-vj) */
/* with ui and vj positive roots of Legendre polynom */
/* of degree NBPNTU and NBPNTV respectively. */
/* SODITB: Table of F(ui,vj) - F(ui,-vj) + F(-ui,vj) - F(-ui,-vj) */
/* with ui and vj positive roots of Legendre polynom */
/* of degree NBPNTU and NBPNTV respectively. */
/* DIDITB: Table of F(ui,vj) - F(ui,-vj) - F(-ui,vj) + F(-ui,-vj) */
/* with ui and vj positive roots of Legendre polynom */
/* of degree NBPNTU and NBPNTV respectively. Additionally, */
/* table DIDITB(0,j) contains F(0,vj) - F(0,-vj), */
/* and table DIDITB(i,0) contains F(ui,0) - F(-ui,0). */
/* OUTPUT ARGUMENTS */
/* --------------- */
/* PATJAC: Table of coefficients of polynom P(u,v) of approximation */
/* of F(u,v) with eventually taking into account of */
/* constraints. P(u,v) is of degree (NDJACU,NDJACV). */
/* This table contains other coeff if ITYDEC = 0. */
/* ERRMAX: For 1<=i<=NBSESP, ERRMAX(i) contains max errors */
/* on each of sub-spaces SI ITYDEC = 0. */
/* ERRMOY: Contains average errors for each of NBSESP sub-spaces SI ITYDEC = 0. */
/* NDEGPU: Degree by U for square PATJAC. Valable if ITYDEC=0. */
/* NDEGPV: Degree by V for square PATJAC. Valable if ITYDEC=0. */
/* ITYDEC: Shows if it is NECESSARY to cut again function F(u,v). */
/* = 0, it is not NECESSARY to cut anything, PATJAC is OK. */
/* = 1, it is NECESSARY to cut only by U (i.e. insert parameter of cutting Ui). */
/* = 2, it is NECESSARY to cut only by V (i.e. insert parameter of cutting Vj). */
/* = 3, it is NECESSARY to cut both by U AND by V. */
/* IERCOD: Error code. */
/* = 0, Everything is OK. */
/* = -1, There is the best possible solution, but the */
/* user tolerance is not satisfactory (3*only) */
/* = 1, Incoherent entries. */
/* COMMONS USED : */
/* ---------------- */
/* REFERENCES CALLED : */
/* --------------------- */
/* DESCRIPTION/NOTES/LIMITATIONS : */
/* ------------------------------- */
/* > */
/* **********************************************************************
*/
/* Name of the routine */
/* --------------------------- Initialisations --------------------------
*/
/* Parameter adjustments */
--errmoy;
--errmax;
--epsapr;
--ndimse;
patjac_dim1 = *ndjacu + 1;
patjac_dim2 = *ndjacv + 1;
patjac_offset = patjac_dim1 * patjac_dim2;
patjac -= patjac_offset;
diditb_dim1 = *nbpntu / 2 + 1;
diditb_dim2 = *nbpntv / 2 + 1;
diditb_offset = diditb_dim1 * diditb_dim2;
diditb -= diditb_offset;
soditb_dim1 = *nbpntu / 2;
soditb_dim2 = *nbpntv / 2;
soditb_offset = soditb_dim1 * (soditb_dim2 + 1) + 1;
soditb -= soditb_offset;
disotb_dim1 = *nbpntu / 2;
disotb_dim2 = *nbpntv / 2;
disotb_offset = disotb_dim1 * (disotb_dim2 + 1) + 1;
disotb -= disotb_offset;
sosotb_dim1 = *nbpntu / 2 + 1;
sosotb_dim2 = *nbpntv / 2 + 1;
sosotb_offset = sosotb_dim1 * sosotb_dim2;
sosotb -= sosotb_offset;
/* Function Body */
ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
if (ldbg)
{
AdvApp2Var_SysBase::mgenmsg_("MMA2CE1", 7L);
}
*iercod = 0;
iofwr = 0;
isz1 = (*nbpntu / 2 + 1) * (*ndjacu - ((*iordru + 1) << 1) + 1);
isz2 = (*nbpntv / 2 + 1) * (*ndjacv - ((*iordrv + 1) << 1) + 1);
isz3 = (*nbpntv / 2 + 1) * (*ndjacu - ((*iordru + 1) << 1) + 1) * *ndimen;
isz4 = *nbpntv / 2 * (*ndjacu - ((*iordru + 1) << 1) + 1) * *ndimen;
isz5 = *ndjacu + 1 - ((*iordru + 1) << 1);
isz6 = *ndjacv + 1 - ((*iordrv + 1) << 1);
isz7 = *ndimen << 2;
iszwr = isz1 + isz2 + isz3 + isz4 + isz5 + isz6 + isz7;
AdvApp2Var_SysBase anAdvApp2Var_SysBase;
anAdvApp2Var_SysBase.mcrrqst_(&c__8, &iszwr, wrkar, &iofwr, &ier);
wrkar_off = reinterpret_cast<double*>(iofwr * sizeof(double));
if (ier > 0)
{
goto L9013;
}
ipt1 = isz1;
ipt2 = ipt1 + isz2;
ipt3 = ipt2 + isz3;
ipt4 = ipt3 + isz4;
ipt5 = ipt4 + isz5;
ipt6 = ipt5 + isz6;
/* ----------------- Return Gauss coefficients of integration ----------------
*/
AdvApp2Var_ApproxF2var::mmapptt_(ndjacu, nbpntu, iordru, wrkar_off, iercod);
if (*iercod > 0)
{
goto L9999;
}
AdvApp2Var_ApproxF2var::mmapptt_(ndjacv, nbpntv, iordrv, &wrkar_off[ipt1], iercod);
if (*iercod > 0)
{
goto L9999;
}
/* ------------------- Return max polynoms of Jacobi ------------
*/
AdvApp2Var_ApproxF2var::mma2jmx_(ndjacu, iordru, &wrkar_off[ipt4]);
AdvApp2Var_ApproxF2var::mma2jmx_(ndjacv, iordrv, &wrkar_off[ipt5]);
/* ------ Calculate the coefficients and their contribution to the error ----
*/
mma2ce2_(numdec,
ndimen,
nbsesp,
&ndimse[1],
ndminu,
ndminv,
ndguli,
ndgvli,
ndjacu,
ndjacv,
iordru,
iordrv,
nbpntu,
nbpntv,
&epsapr[1],
&sosotb[sosotb_offset],
&disotb[disotb_offset],
&soditb[soditb_offset],
&diditb[diditb_offset],
wrkar_off,
&wrkar_off[ipt1],
&wrkar_off[ipt4],
&wrkar_off[ipt5],
&wrkar_off[ipt6],
&wrkar_off[ipt2],
&wrkar_off[ipt3],
&patjac[patjac_offset],
&errmax[1],
&errmoy[1],
ndegpu,
ndegpv,
itydec,
iercod);
if (*iercod > 0)
{
goto L9999;
}
goto L9999;
/* ------------------------------ The end -------------------------------
*/
L9013:
*iercod = 13;
goto L9999;
L9999:
if (iofwr != 0)
{
anAdvApp2Var_SysBase.mcrdelt_(&c__8, &iszwr, wrkar, &iofwr, &ier);
}
if (ier > 0)
{
*iercod = 13;
}
AdvApp2Var_SysBase::maermsg_("MMA2CE1", iercod, 7L);
if (ldbg)
{
AdvApp2Var_SysBase::mgsomsg_("MMA2CE1", 7L);
}
return 0;
} /* mma2ce1_ */
//=================================================================================================
int mma2ce2_(int* numdec,
int* ndimen,
int* nbsesp,
int* ndimse,
int* ndminu,
int* ndminv,
int* ndguli,
int* ndgvli,
int* ndjacu,
int* ndjacv,
int* iordru,
int* iordrv,
int* nbpntu,
int* nbpntv,
double* epsapr,
double* sosotb,
double* disotb,
double* soditb,
double* diditb,
double* gssutb,
double* gssvtb,
double* xmaxju,
double* xmaxjv,
double* vecerr,
double* chpair,
double* chimpr,
double* patjac,
double* errmax,
double* errmoy,
int* ndegpu,
int* ndegpv,
int* itydec,
int* iercod)
{
/* System generated locals */
int sosotb_dim1, sosotb_dim2, sosotb_offset, disotb_dim1, disotb_dim2, disotb_offset, soditb_dim1,
soditb_dim2, soditb_offset, diditb_dim1, diditb_dim2, diditb_offset, gssutb_dim1, gssvtb_dim1,
chpair_dim1, chpair_dim2, chpair_offset, chimpr_dim1, chimpr_dim2, chimpr_offset, patjac_dim1,
patjac_dim2, patjac_offset, vecerr_dim1, vecerr_offset, i__1, i__2, i__3, i__4;
/* Local variables */
long ldbg;
int idim, igsu, minu, minv, maxu, maxv, igsv;
double vaux[3];
int i2rdu, i2rdv, ndses, nd, ii, jj, kk, nu, nv;
double zu, zv;
int nu1, nv1;
/* **********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* Calculation of coefficients of polynomial approximation of degree */
/* (NDJACU,NDJACV) of a function F(u,v), starting from its */
/* discretization on roots of Legendre polynom of degree */
/* NBPNTU by U and NBPNTV by V. */
/* KEYWORDS : */
/* ----------- */
/* TOUS,AB_SPECIFI::FONCTION&,APPROXIMATION,&COEFFICIENT,&POLYNOME */
/* INPUT ARGUMENTS : */
/* ------------------ */
/* NUMDEC: Indicates if it is POSSIBLE to cut function F(u,v). */
/* = 5, It is POSSIBLE to cut by U or by V or in both directions simultaneously. */
/* = 4, It is POSSIBLE to cut by U or by V BUT NOT in both */
/* directions simultaneously (cutting by V is preferable). */
/* = 3, It is POSSIBLE to cut by U or by V BUT NOT in both */
/* directions simultaneously (cutting by U is preferable). */
/* = 2, It is POSSIBLE to cut only by V (i.e. insert parameter */
/* of cutting Vj). */
/* = 1, It is POSSIBLE to cut only by U (i.e. insert parameter */
/* of cutting Ui). */
/* = 0, It is not POSSIBLE to cut anything */
/* NDIMEN: Total dimension of the space. */
/* NBSESP: Nb of independent sub-spaces on which the errors are calculated. */
/* NDIMSE: Table of dimensions of each of sub-spaces. */
/* NDMINU: Minimum degree by U to be preserved for the approximation. */
/* NDMINV: Minimum degree by V to be preserved for the approximation. */
/* NDGULI: Limit of nb of coefficients by U of the solution. */
/* NDGVLI: Limit of nb of coefficients by V of the solution. */
/* NDJACU: Max degree of the polynom of approximation by U. */
/* The representation in the orthogonal base starts from degree */
/* 0 to degree NDJACU-2*(IORDRU+1). The polynomial base is the base of */
/* Jacobi of order -1 (Legendre), 0, 1 or 2. */
/* It is required that 2*IORDRU+1 <= NDMINU <= NDGULI < NDJACU */
/* NDJACV: Max degree of the polynom of approximation by V. */
/* The representation in the orthogonal base starts from degree */
/* 0 to degree NDJACV-2*(IORDRV+1). The polynomial base is */
/* the base of Jacobi of order -1 (Legendre), 0, 1 or 2 */
/* It is required that 2*IORDRV+1 <= NDMINV <= NDGVLI < NDJACV */
/* IORDRU: Order of the Jacobi base (-1,0,1 or 2) by U. Corresponds */
/* to the step of constraints C0, C1 or C2. */
/* IORDRV: Order of the Jacobi base (-1,0,1 or 2) by U. Corresponds */
/* to the step of constraints C0, C1 or C2. */
/* NBPNTU: Degree of Legendre polynom on the roots which of are */
/* calculated the coefficients of integration by u */
/* by Gauss method. It is required that NBPNTU = 30, 40, */
/* 50 or 61 and NDJACU-2*(IORDRU+1) < NBPNTU. */
/* NBPNTV: Degree of Legendre polynom on the roots which of are */
/* calculated the coefficients of integration by u */
/* by Gauss method. It is required that NBPNTV = 30, 40, */
/* 50 or 61 and NDJACV-2*(IORDRV+1) < NBPNTV. */
/* EPSAPR: Table of NBSESP tolerances imposed on each sub-spaces. */
/* SOSOTB: Table of F(ui,vj) + F(ui,-vj) + F(-ui,vj) + F(-ui,-vj) */
/* with ui and vj - positive roots of the Legendre polynom */
/* of degree NBPNTU and NBPNTV respectively. Additionally, */
/* table SOSOTB(0,j) contains F(0,vj) + F(0,-vj), */
/* table SOSOTB(i,0) contains F(ui,0) + F(-ui,0) and */
/* SOSOTB(0,0) contains F(0,0). */
/* DISOTB: Table of F(ui,vj) + F(ui,-vj) - F(-ui,vj) - F(-ui,-vj) */
/* with ui and vj positive roots of Legendre polynom */
/* of degree NBPNTU and NBPNTV respectively. */
/* SODITB: Table of F(ui,vj) - F(ui,-vj) + F(-ui,vj) - F(-ui,-vj) */
/* with ui and vj positive roots of Legendre polynom */
/* of degree NBPNTU and NBPNTV respectively. */
/* DIDITB: Table of F(ui,vj) - F(ui,-vj) - F(-ui,vj) + F(-ui,-vj) */
/* with ui and vj positive roots of Legendre polynom */
/* of degree NBPNTU and NBPNTV respectively. Additionally, */
/* table DIDITB(0,j) contains F(0,vj) - F(0,-vj), */
/* and table DIDITB(i,0) contains F(ui,0) - F(-ui,0). */
/* GSSUTB: Table of coefficients of integration by Gauss method */
/* by U: i varies from 0 to NBPNTU/2 and k varies from 0 to */
/* NDJACU-2*(IORDRU+1). */
/* GSSVTB: Table of coefficients of integration by Gauss method */
/* by V: i varies from 0 to NBPNTV/2 and k varies from 0 to */
/* NDJACV-2*(IORDRV+1). */
/* XMAXJU: Maximum value of Jacobi polynoms of order IORDRU, */
/* from degree 0 to degree NDJACU - 2*(IORDRU+1) */
/* XMAXJV: Maximum value of Jacobi polynoms of order IORDRV, */
/* from degree 0 to degree NDJACV - 2*(IORDRV+1) */
/* OUTPUT ARGUMENTS : */
/* ------------------- */
/* VECERR: Auxiliary table. */
/* CHPAIR: Auxiliary table of terms connected to degree NDJACU by U */
/* to calculate the coeff. of approximation of EVEN degree by V. */
/* CHIMPR: Auxiliary table of terms connected to degree NDJACU by U */
/* to calculate the coeff. of approximation of UNEVEN degree by V. */
/* PATJAC: Table of coefficients of polynom P(u,v) of approximation */
/* of F(u,v) with eventually taking into account of */
/* constraints. P(u,v) is of degree (NDJACU,NDJACV). */
/* This table contains other coeff if ITYDEC = 0. */
/* ERRMAX: For 1<=i<=NBSESP, ERRMAX(i) contains max errors */
/* on each of sub-spaces SI ITYDEC = 0. */
/* ERRMOY: Contains average errors for each of NBSESP sub-spaces SI ITYDEC = 0. */
/* NDEGPU: Degree by U for square PATJAC. Valable if ITYDEC=0. */
/* NDEGPV: Degree by V for square PATJAC. Valable if ITYDEC=0. */
/* ITYDEC: Shows if it is NECESSARY to cut again function F(u,v). */
/* = 0, it is not NECESSARY to cut anything, PATJAC is OK. */
/* = 1, it is NECESSARY to cut only by U (i.e. insert parameter of cutting Ui). */
/* = 2, it is NECESSARY to cut only by V (i.e. insert parameter of cutting Vj). */
/* = 3, it is NECESSARY to cut both by U AND by V. */
/* IERCOD: Error code. */
/* = 0, Everything is OK. */
/* = -1, There is the best possible solution, but the */
/* user tolerance is not satisfactory (3*only) */
/* = 1, Incoherent entries. */
/* COMMONS USED : */
/* ---------------- */
/* REFERENCES CALLED : */
/* --------------------- */
/* DESCRIPTION/NOTES/LIMITATIONS : */
/* > */
/* **********************************************************************
*/
/* Name of the routine */
/* --------------------------- Initialisations --------------------------
*/
/* Parameter adjustments */
vecerr_dim1 = *ndimen;
vecerr_offset = vecerr_dim1 + 1;
vecerr -= vecerr_offset;
--errmoy;
--errmax;
--epsapr;
--ndimse;
patjac_dim1 = *ndjacu + 1;
patjac_dim2 = *ndjacv + 1;
patjac_offset = patjac_dim1 * patjac_dim2;
patjac -= patjac_offset;
gssutb_dim1 = *nbpntu / 2 + 1;
chimpr_dim1 = *nbpntv / 2;
chimpr_dim2 = *ndjacu - ((*iordru + 1) << 1) + 1;
chimpr_offset = chimpr_dim1 * chimpr_dim2 + 1;
chimpr -= chimpr_offset;
chpair_dim1 = *nbpntv / 2 + 1;
chpair_dim2 = *ndjacu - ((*iordru + 1) << 1) + 1;
chpair_offset = chpair_dim1 * chpair_dim2;
chpair -= chpair_offset;
gssvtb_dim1 = *nbpntv / 2 + 1;
diditb_dim1 = *nbpntu / 2 + 1;
diditb_dim2 = *nbpntv / 2 + 1;
diditb_offset = diditb_dim1 * diditb_dim2;
diditb -= diditb_offset;
soditb_dim1 = *nbpntu / 2;
soditb_dim2 = *nbpntv / 2;
soditb_offset = soditb_dim1 * (soditb_dim2 + 1) + 1;
soditb -= soditb_offset;
disotb_dim1 = *nbpntu / 2;
disotb_dim2 = *nbpntv / 2;
disotb_offset = disotb_dim1 * (disotb_dim2 + 1) + 1;
disotb -= disotb_offset;
sosotb_dim1 = *nbpntu / 2 + 1;
sosotb_dim2 = *nbpntv / 2 + 1;
sosotb_offset = sosotb_dim1 * sosotb_dim2;
sosotb -= sosotb_offset;
/* Function Body */
ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
if (ldbg)
{
AdvApp2Var_SysBase::mgenmsg_("MMA2CE2", 7L);
}
/* --> A priori everything is OK */
*iercod = 0;
/* --> test of inputs */
if (*numdec < 0 || *numdec > 5)
{
goto L9001;
}
if ((*iordru << 1) + 1 > *ndminu)
{
goto L9001;
}
if (*ndminu > *ndguli)
{
goto L9001;
}
if (*ndguli >= *ndjacu)
{
goto L9001;
}
if ((*iordrv << 1) + 1 > *ndminv)
{
goto L9001;
}
if (*ndminv > *ndgvli)
{
goto L9001;
}
if (*ndgvli >= *ndjacv)
{
goto L9001;
}
/* --> A priori, no cuts to be done */
*itydec = 0;
/* --> Min. degrees to return: NDMINU,NDMINV */
*ndegpu = *ndminu;
*ndegpv = *ndminv;
/* --> For the moment, max errors are null */
AdvApp2Var_SysBase::mvriraz_(nbsesp, &errmax[1]);
nd = *ndimen << 2;
AdvApp2Var_SysBase::mvriraz_(&nd, &vecerr[vecerr_offset]);
/* --> and the square, too. */
nd = (*ndjacu + 1) * (*ndjacv + 1) * *ndimen;
AdvApp2Var_SysBase::mvriraz_(&nd, &patjac[patjac_offset]);
i2rdu = (*iordru + 1) << 1;
i2rdv = (*iordrv + 1) << 1;
/* **********************************************************************
*/
/* -------------------- HERE IT IS POSSIBLE TO CUT ----------------------
*/
/* **********************************************************************
*/
if (*numdec > 0 && *numdec <= 5)
{
/* ******************************************************************
**** */
/* ---------------------- Calculate coeff of zone 4 -------------
---- */
minu = *ndguli + 1;
maxu = *ndjacu;
minv = *ndgvli + 1;
maxv = *ndjacv;
if (minu > maxu)
{
goto L9001;
}
if (minv > maxv)
{
goto L9001;
}
/* ---------------- Calculate the terms connected to degree by U ---------
---- */
i__1 = *ndimen;
for (nd = 1; nd <= i__1; ++nd)
{
i__2 = maxu;
for (kk = minu; kk <= i__2; ++kk)
{
igsu = kk - i2rdu;
mma2cfu_(&kk,
nbpntu,
nbpntv,
&sosotb[nd * sosotb_dim2 * sosotb_dim1],
&disotb[(nd * disotb_dim2 + 1) * disotb_dim1 + 1],
&soditb[(nd * soditb_dim2 + 1) * soditb_dim1 + 1],
&diditb[nd * diditb_dim2 * diditb_dim1],
&gssutb[igsu * gssutb_dim1],
&chpair[(igsu + nd * chpair_dim2) * chpair_dim1],
&chimpr[(igsu + nd * chimpr_dim2) * chimpr_dim1 + 1]);
/* L110: */
}
/* L100: */
}
/* ------------------- Calculate the coefficients of PATJAC ------------
---- */
igsu = minu - i2rdu;
i__1 = maxv;
for (jj = minv; jj <= i__1; ++jj)
{
igsv = jj - i2rdv;
i__2 = *ndimen;
for (nd = 1; nd <= i__2; ++nd)
{
mma2cfv_(&jj,
&minu,
&maxu,
nbpntv,
&gssvtb[igsv * gssvtb_dim1],
&chpair[(igsu + nd * chpair_dim2) * chpair_dim1],
&chimpr[(igsu + nd * chimpr_dim2) * chimpr_dim1 + 1],
&patjac[minu + (jj + nd * patjac_dim2) * patjac_dim1]);
/* L130: */
}
/* ----- Contribution of calculated terms to the approximation error */
/* for terms (I,J) with MINU <= I <= MAXU, J fixe. */
idim = 1;
i__2 = *nbsesp;
for (nd = 1; nd <= i__2; ++nd)
{
ndses = ndimse[nd];
mma2er1_(ndjacu,
ndjacv,
&ndses,
&minu,
&maxu,
&jj,
&jj,
iordru,
iordrv,
xmaxju,
xmaxjv,
&patjac[idim * patjac_dim2 * patjac_dim1],
&vecerr[vecerr_dim1 + 1],
&vecerr[nd + (vecerr_dim1 << 2)]);
if (vecerr[nd + (vecerr_dim1 << 2)] > epsapr[nd])
{
goto L9300;
}
idim += ndses;
/* L140: */
}
/* L120: */
}
/* ******************************************************************
**** */
/* ---------------------- Calculate the coeff of zone 2 -------------
---- */
minu = (*iordru + 1) << 1;
maxu = *ndguli;
minv = *ndgvli + 1;
maxv = *ndjacv;
/* --> If zone 2 is empty, pass to zone 3. */
/* VECERR(ND,2) was already set to zero. */
if (minu > maxu)
{
goto L300;
}
/* ---------------- Calculate the terms connected to degree by U ------------
---- */
i__1 = *ndimen;
for (nd = 1; nd <= i__1; ++nd)
{
i__2 = maxu;
for (kk = minu; kk <= i__2; ++kk)
{
igsu = kk - i2rdu;
mma2cfu_(&kk,
nbpntu,
nbpntv,
&sosotb[nd * sosotb_dim2 * sosotb_dim1],
&disotb[(nd * disotb_dim2 + 1) * disotb_dim1 + 1],
&soditb[(nd * soditb_dim2 + 1) * soditb_dim1 + 1],
&diditb[nd * diditb_dim2 * diditb_dim1],
&gssutb[igsu * gssutb_dim1],
&chpair[(igsu + nd * chpair_dim2) * chpair_dim1],
&chimpr[(igsu + nd * chimpr_dim2) * chimpr_dim1 + 1]);
/* L210: */
}
/* L200: */
}
/* ------------------- Calculate the coefficients of PATJAC ------------
---- */
igsu = minu - i2rdu;
i__1 = maxv;
for (jj = minv; jj <= i__1; ++jj)
{
igsv = jj - i2rdv;
i__2 = *ndimen;
for (nd = 1; nd <= i__2; ++nd)
{
mma2cfv_(&jj,
&minu,
&maxu,
nbpntv,
&gssvtb[igsv * gssvtb_dim1],
&chpair[(igsu + nd * chpair_dim2) * chpair_dim1],
&chimpr[(igsu + nd * chimpr_dim2) * chimpr_dim1 + 1],
&patjac[minu + (jj + nd * patjac_dim2) * patjac_dim1]);
/* L230: */
}
/* L220: */
}
/* -----Contribution of calculated terms to the approximation error */
/* for terms (I,J) with MINU <= I <= MAXU, MINV <= J <= MAXV */
idim = 1;
i__1 = *nbsesp;
for (nd = 1; nd <= i__1; ++nd)
{
ndses = ndimse[nd];
mma2er1_(ndjacu,
ndjacv,
&ndses,
&minu,
&maxu,
&minv,
&maxv,
iordru,
iordrv,
xmaxju,
xmaxjv,
&patjac[idim * patjac_dim2 * patjac_dim1],
&vecerr[vecerr_dim1 + 1],
&vecerr[nd + (vecerr_dim1 << 1)]);
idim += ndses;
/* L240: */
}
/* ******************************************************************
**** */
/* ---------------------- Calculation of coeff of zone 3 -------------
---- */
L300:
minu = *ndguli + 1;
maxu = *ndjacu;
minv = (*iordrv + 1) << 1;
maxv = *ndgvli;
/* -> If zone 3 is empty, pass to the test of cutting. */
/* VECERR(ND,3) was already set to zero */
if (minv > maxv)
{
goto L400;
}
/* ----------- The terms connected to the degree by U are already calculated -----
---- */
/* ------------------- Calculation of coefficients of PATJAC ------------
---- */
igsu = minu - i2rdu;
i__1 = maxv;
for (jj = minv; jj <= i__1; ++jj)
{
igsv = jj - i2rdv;
i__2 = *ndimen;
for (nd = 1; nd <= i__2; ++nd)
{
mma2cfv_(&jj,
&minu,
&maxu,
nbpntv,
&gssvtb[igsv * gssvtb_dim1],
&chpair[(igsu + nd * chpair_dim2) * chpair_dim1],
&chimpr[(igsu + nd * chimpr_dim2) * chimpr_dim1 + 1],
&patjac[minu + (jj + nd * patjac_dim2) * patjac_dim1]);
/* L330: */
}
/* L320: */
}
/* ----- Contribution of calculated terms to the approximation error */
/* for terms (I,J) with MINU <= I <= MAXU, MINV <= J <= MAXV. */
idim = 1;
i__1 = *nbsesp;
for (nd = 1; nd <= i__1; ++nd)
{
ndses = ndimse[nd];
mma2er1_(ndjacu,
ndjacv,
&ndses,
&minu,
&maxu,
&minv,
&maxv,
iordru,
iordrv,
xmaxju,
xmaxjv,
&patjac[idim * patjac_dim2 * patjac_dim1],
&vecerr[vecerr_dim1 + 1],
&vecerr[nd + vecerr_dim1 * 3]);
idim += ndses;
/* L340: */
}
/* ******************************************************************
**** */
/* --------------------------- Tests of cutting ---------------------
---- */
L400:
i__1 = *nbsesp;
for (nd = 1; nd <= i__1; ++nd)
{
vaux[0] = vecerr[nd + (vecerr_dim1 << 1)];
vaux[1] = vecerr[nd + (vecerr_dim1 << 2)];
vaux[2] = vecerr[nd + vecerr_dim1 * 3];
ii = 3;
errmax[nd] = AdvApp2Var_MathBase::mzsnorm_(&ii, vaux);
if (errmax[nd] > epsapr[nd])
{
ii = 2;
zv = AdvApp2Var_MathBase::mzsnorm_(&ii, vaux);
zu = AdvApp2Var_MathBase::mzsnorm_(&ii, &vaux[1]);
if (zu > epsapr[nd] && zv > epsapr[nd])
{
goto L9300;
}
if (zu > zv)
{
goto L9100;
}
else
{
goto L9200;
}
}
/* L410: */
}
/* ******************************************************************
**** */
/* --- OK, the square is valid, the coeff of zone 1 are calculated
---- */
minu = (*iordru + 1) << 1;
maxu = *ndguli;
minv = (*iordrv + 1) << 1;
maxv = *ndgvli;
/* --> If zone 1 is empty, pass to the calculation of Max and Average error. */
if (minu > maxu || minv > maxv)
{
goto L600;
}
/* ----------- The terms connected to degree by U are already calculated -----
---- */
/* ------------------- Calculate the coefficients of PATJAC ------------
---- */
igsu = minu - i2rdu;
i__1 = maxv;
for (jj = minv; jj <= i__1; ++jj)
{
igsv = jj - i2rdv;
i__2 = *ndimen;
for (nd = 1; nd <= i__2; ++nd)
{
mma2cfv_(&jj,
&minu,
&maxu,
nbpntv,
&gssvtb[igsv * gssvtb_dim1],
&chpair[(igsu + nd * chpair_dim2) * chpair_dim1],
&chimpr[(igsu + nd * chimpr_dim2) * chimpr_dim1 + 1],
&patjac[minu + (jj + nd * patjac_dim2) * patjac_dim1]);
/* L530: */
}
/* L520: */
}
/* --------------- Now the degree is maximally lowered --------
---- */
L600:
/* Computing MAX */
i__1 = 1, i__2 = (*iordru << 1) + 1, i__1 = std::max(i__1, i__2);
minu = std::max(i__1, *ndminu);
maxu = *ndguli;
/* Computing MAX */
i__1 = 1, i__2 = (*iordrv << 1) + 1, i__1 = std::max(i__1, i__2);
minv = std::max(i__1, *ndminv);
maxv = *ndgvli;
idim = 1;
i__1 = *nbsesp;
for (nd = 1; nd <= i__1; ++nd)
{
ndses = ndimse[nd];
if (maxu >= (*iordru + 1) << 1 && maxv >= (*iordrv + 1) << 1)
{
mma2er2_(ndjacu,
ndjacv,
&ndses,
&minu,
&maxu,
&minv,
&maxv,
iordru,
iordrv,
xmaxju,
xmaxjv,
&patjac[idim * patjac_dim2 * patjac_dim1],
&epsapr[nd],
&vecerr[vecerr_dim1 + 1],
&errmax[nd],
&nu,
&nv);
}
else
{
nu = maxu;
nv = maxv;
}
nu1 = nu + 1;
nv1 = nv + 1;
/* --> Calculate the average error. */
mma2moy_(ndjacu,
ndjacv,
&ndses,
&nu1,
ndjacu,
&nv1,
ndjacv,
iordru,
iordrv,
&patjac[idim * patjac_dim2 * patjac_dim1],
&errmoy[nd]);
/* --> Set to 0.D0 the rejected coeffs. */
i__2 = idim + ndses - 1;
for (ii = idim; ii <= i__2; ++ii)
{
i__3 = *ndjacv;
for (jj = nv1; jj <= i__3; ++jj)
{
i__4 = *ndjacu;
for (kk = nu1; kk <= i__4; ++kk)
{
patjac[kk + (jj + ii * patjac_dim2) * patjac_dim1] = 0.;
/* L640: */
}
/* L630: */
}
/* L620: */
}
/* --> Return the nb of coeffs of approximation. */
*ndegpu = std::max(*ndegpu, nu);
*ndegpv = std::max(*ndegpv, nv);
idim += ndses;
/* L610: */
}
/* ******************************************************************
**** */
/* -------------------- IT IS NOT POSSIBLE TO CUT -------------------
---- */
/* ******************************************************************
**** */
}
else
{
minu = (*iordru + 1) << 1;
maxu = *ndjacu;
minv = (*iordrv + 1) << 1;
maxv = *ndjacv;
/* ---------------- Calculate the terms connected to the degree by U ------------
---- */
i__1 = *ndimen;
for (nd = 1; nd <= i__1; ++nd)
{
i__2 = maxu;
for (kk = minu; kk <= i__2; ++kk)
{
igsu = kk - i2rdu;
mma2cfu_(&kk,
nbpntu,
nbpntv,
&sosotb[nd * sosotb_dim2 * sosotb_dim1],
&disotb[(nd * disotb_dim2 + 1) * disotb_dim1 + 1],
&soditb[(nd * soditb_dim2 + 1) * soditb_dim1 + 1],
&diditb[nd * diditb_dim2 * diditb_dim1],
&gssutb[igsu * gssutb_dim1],
&chpair[(igsu + nd * chpair_dim2) * chpair_dim1],
&chimpr[(igsu + nd * chimpr_dim2) * chimpr_dim1 + 1]);
/* L710: */
}
/* ---------------------- Calculate all coefficients -------
-------- */
igsu = minu - i2rdu;
i__2 = maxv;
for (jj = minv; jj <= i__2; ++jj)
{
igsv = jj - i2rdv;
mma2cfv_(&jj,
&minu,
&maxu,
nbpntv,
&gssvtb[igsv * gssvtb_dim1],
&chpair[(igsu + nd * chpair_dim2) * chpair_dim1],
&chimpr[(igsu + nd * chimpr_dim2) * chimpr_dim1 + 1],
&patjac[minu + (jj + nd * patjac_dim2) * patjac_dim1]);
/* L720: */
}
/* L700: */
}
/* ----- Contribution of calculated terms to the approximation error */
/* for terms (I,J) with MINU <= I <= MAXU, MINV <= J <= MAXV */
idim = 1;
i__1 = *nbsesp;
for (nd = 1; nd <= i__1; ++nd)
{
ndses = ndimse[nd];
minu = (*iordru + 1) << 1;
maxu = *ndjacu;
minv = *ndgvli + 1;
maxv = *ndjacv;
mma2er1_(ndjacu,
ndjacv,
&ndses,
&minu,
&maxu,
&minv,
&maxv,
iordru,
iordrv,
xmaxju,
xmaxjv,
&patjac[idim * patjac_dim2 * patjac_dim1],
&vecerr[vecerr_dim1 + 1],
&errmax[nd]);
minu = *ndguli + 1;
maxu = *ndjacu;
minv = (*iordrv + 1) << 1;
maxv = *ndgvli;
if (minv <= maxv)
{
mma2er1_(ndjacu,
ndjacv,
&ndses,
&minu,
&maxu,
&minv,
&maxv,
iordru,
iordrv,
xmaxju,
xmaxjv,
&patjac[idim * patjac_dim2 * patjac_dim1],
&vecerr[vecerr_dim1 + 1],
&errmax[nd]);
}
/* ---------------------------- IF ERRMAX > EPSAPR, stop --------
-------- */
if (errmax[nd] > epsapr[nd])
{
*iercod = -1;
nu = *ndguli;
nv = *ndgvli;
/* ------------- Otherwise, try to remove again the coeff
------------ */
}
else
{
/* Computing MAX */
i__2 = 1, i__3 = (*iordru << 1) + 1, i__2 = std::max(i__2, i__3);
minu = std::max(i__2, *ndminu);
maxu = *ndguli;
/* Computing MAX */
i__2 = 1, i__3 = (*iordrv << 1) + 1, i__2 = std::max(i__2, i__3);
minv = std::max(i__2, *ndminv);
maxv = *ndgvli;
if (maxu >= (*iordru + 1) << 1 && maxv >= (*iordrv + 1) << 1)
{
mma2er2_(ndjacu,
ndjacv,
&ndses,
&minu,
&maxu,
&minv,
&maxv,
iordru,
iordrv,
xmaxju,
xmaxjv,
&patjac[idim * patjac_dim2 * patjac_dim1],
&epsapr[nd],
&vecerr[vecerr_dim1 + 1],
&errmax[nd],
&nu,
&nv);
}
else
{
nu = maxu;
nv = maxv;
}
}
/* --------------------- Calculate the average error -------------
-------- */
nu1 = nu + 1;
nv1 = nv + 1;
mma2moy_(ndjacu,
ndjacv,
&ndses,
&nu1,
ndjacu,
&nv1,
ndjacv,
iordru,
iordrv,
&patjac[idim * patjac_dim2 * patjac_dim1],
&errmoy[nd]);
/* --------------------- Set to 0.D0 the rejected coeffs ----------
-------- */
i__2 = idim + ndses - 1;
for (ii = idim; ii <= i__2; ++ii)
{
i__3 = *ndjacv;
for (jj = nv1; jj <= i__3; ++jj)
{
i__4 = *ndjacu;
for (kk = nu1; kk <= i__4; ++kk)
{
patjac[kk + (jj + ii * patjac_dim2) * patjac_dim1] = 0.;
/* L760: */
}
/* L750: */
}
/* L740: */
}
/* --------------- Return the nb of coeff of approximation ---
-------- */
*ndegpu = std::max(*ndegpu, nu);
*ndegpv = std::max(*ndegpv, nv);
idim += ndses;
/* L730: */
}
}
goto L9999;
/* ------------------------------ The end -------------------------------
*/
/* --> Error in inputs */
L9001:
*iercod = 1;
goto L9999;
/* --------- Management of cuts, it is required 0 < NUMDEC <= 5 -------
*/
/* --> Here it is possible and necessary to cut, choose by U if it is possible */
L9100:
if (*numdec <= 0 || *numdec > 5)
{
goto L9001;
}
if (*numdec != 2)
{
*itydec = 1;
}
else
{
*itydec = 2;
}
goto L9999;
/* --> Here it is possible and necessary to cut, choose by U if it is possible */
L9200:
if (*numdec <= 0 || *numdec > 5)
{
goto L9001;
}
if (*numdec != 1)
{
*itydec = 2;
}
else
{
*itydec = 1;
}
goto L9999;
/* --> Here it is possible and necessary to cut, choose by 4 if it is possible */
L9300:
if (*numdec <= 0 || *numdec > 5)
{
goto L9001;
}
if (*numdec == 5)
{
*itydec = 3;
}
else if (*numdec == 2 || *numdec == 4)
{
*itydec = 2;
}
else if (*numdec == 1 || *numdec == 3)
{
*itydec = 1;
}
else
{
goto L9001;
}
goto L9999;
L9999:
AdvApp2Var_SysBase::maermsg_("MMA2CE2", iercod, 7L);
if (ldbg)
{
AdvApp2Var_SysBase::mgsomsg_("MMA2CE2", 7L);
}
return 0;
} /* mma2ce2_ */
//=================================================================================================
int mma2cfu_(int* ndujac,
int* nbpntu,
int* nbpntv,
double* sosotb,
double* disotb,
double* soditb,
double* diditb,
double* gssutb,
double* chpair,
double* chimpr)
{
/* System generated locals */
int sosotb_dim1, disotb_dim1, disotb_offset, soditb_dim1, soditb_offset, diditb_dim1, i__1, i__2;
/* Local variables */
long ldbg;
int nptu2, nptv2, ii, jj;
double bid0, bid1, bid2;
/* **********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* Calculate the terms connected to degree NDUJAC by U of the polynomial approximation */
/* of function F(u,v), starting from its discretisation */
/* on the roots of Legendre polynom of degree */
/* NBPNTU by U and NBPNTV by V. */
/* KEYWORDS : */
/* ----------- */
/* FONCTION,APPROXIMATION,COEFFICIENT,POLYNOME */
/* INPUT ARGUMENTSE : */
/* ------------------ */
/* NDUJAC: Fixed degree by U for which the terms */
/* allowing to obtain the Legendre or Jacobi coeff*/
/* of even or uneven degree by V are calculated. */
/* NBPNTU: Degree of Legendre polynom on the roots which of */
/* the coefficients of integration by U are calculated */
/* by Gauss method. It is required that NBPNTU = 30, 40, 50 or 61. */
/* NBPNTV: Degree of Legendre polynom on the roots which of */
/* the coefficients of integration by V are calculated */
/* by Gauss method. It is required that NBPNTV = 30, 40, 50 or 61. */
/* SOSOTB: Table of F(ui,vj) + F(ui,-vj) + F(-ui,vj) + F(-ui,-vj) */
/* with ui and vj positive roots of Legendre polynom */
/* of degree NBPNTU and NBPNTV respectively. Moreover, */
/* table SOSOTB(0,j) contains F(0,vj) + F(0,-vj), */
/* table SOSOTB(i,0) contains F(ui,0) + F(-ui,0) and */
/* SOSOTB(0,0) contains F(0,0). */
/* DISOTB: Table of F(ui,vj) + F(ui,-vj) - F(-ui,vj) - F(-ui,-vj) */
/* with ui and vj positive roots of Legendre polynom */
/* of degree NBPNTU and NBPNTV respectively. */
/* SODITB: Table of F(ui,vj) - F(ui,-vj) + F(-ui,vj) - F(-ui,-vj) */
/* with ui and vj positive roots of Legendre polynom */
/* of degree NBPNTU and NBPNTV respectively. */
/* DIDITB: Table of F(ui,vj) - F(ui,-vj) - F(-ui,vj) + F(-ui,-vj) */
/* avec ui and vj positive roots of Legendre polynom */
/* of degree NBPNTU and NBPNTV respectively. Moreover, */
/* table DIDITB(0,j) contains F(0,vj) - F(0,-vj), */
/* and table DIDITB(i,0) contains F(ui,0) - F(-ui,0). */
/* GSSUTB: Table of coefficients of integration by Gauss method */
/* Gauss by U for fixed NDUJAC : i varies from 0 to NBPNTU/2. */
/* OUTPUT ARGUMENTS : */
/* ------------------- */
/* CHPAIR: Table of terms connected to degree NDUJAC by U to calculate the */
/* coeff. of the approximation of EVEN degree by V. */
/* CHIMPR: Table of terms connected to degree NDUJAC by U to calculate */
/* the coeff. of approximation of UNEVEN degree by V. */
/* COMMONS USED : */
/* ---------------- */
/* REFERENCES CALLED : */
/* ----------------------- */
/* DESCRIPTION/NOTES/LIMITATIONS : */
/* ----------------------------------- */
/* > */
/* **********************************************************************
*/
/* Name of the routine */
/* --------------------------- Initialisations --------------------------
*/
/* Parameter adjustments */
--chimpr;
diditb_dim1 = *nbpntu / 2 + 1;
soditb_dim1 = *nbpntu / 2;
soditb_offset = soditb_dim1 + 1;
soditb -= soditb_offset;
disotb_dim1 = *nbpntu / 2;
disotb_offset = disotb_dim1 + 1;
disotb -= disotb_offset;
sosotb_dim1 = *nbpntu / 2 + 1;
/* Function Body */
ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
if (ldbg)
{
AdvApp2Var_SysBase::mgenmsg_("MMA2CFU", 7L);
}
nptu2 = *nbpntu / 2;
nptv2 = *nbpntv / 2;
/* **********************************************************************
*/
/* CALCULATE COEFFICIENTS BY U */
/* ----------------- Calculate coefficients of even degree --------------
*/
if (*ndujac % 2 == 0)
{
i__1 = nptv2;
for (jj = 1; jj <= i__1; ++jj)
{
bid1 = 0.;
bid2 = 0.;
i__2 = nptu2;
for (ii = 1; ii <= i__2; ++ii)
{
bid0 = gssutb[ii];
bid1 += sosotb[ii + jj * sosotb_dim1] * bid0;
bid2 += soditb[ii + jj * soditb_dim1] * bid0;
/* L200: */
}
chpair[jj] = bid1;
chimpr[jj] = bid2;
/* L100: */
}
/* --------------- Calculate coefficients of uneven degree ----------
---- */
}
else
{
i__1 = nptv2;
for (jj = 1; jj <= i__1; ++jj)
{
bid1 = 0.;
bid2 = 0.;
i__2 = nptu2;
for (ii = 1; ii <= i__2; ++ii)
{
bid0 = gssutb[ii];
bid1 += disotb[ii + jj * disotb_dim1] * bid0;
bid2 += diditb[ii + jj * diditb_dim1] * bid0;
/* L250: */
}
chpair[jj] = bid1;
chimpr[jj] = bid2;
/* L150: */
}
}
/* ------- Add terms connected to the supplementary root (0.D0) ------ */
/* ----------- of Legendre polynom of uneven degree NBPNTU -----------
*/
/* --> Only even NDUJAC terms are modified as GSSUTB(0) = 0 */
/* when NDUJAC is uneven. */
if (*nbpntu % 2 != 0 && *ndujac % 2 == 0)
{
bid0 = gssutb[0];
i__1 = nptv2;
for (jj = 1; jj <= i__1; ++jj)
{
chpair[jj] += sosotb[jj * sosotb_dim1] * bid0;
chimpr[jj] += diditb[jj * diditb_dim1] * bid0;
/* L300: */
}
}
/* ------ Calculate the terms connected to supplementary roots (0.D0) ------
*/
/* ----------- of Legendre polynom of uneven degree NBPNTV -----------
*/
if (*nbpntv % 2 != 0)
{
/* --> Only CHPAIR terms are calculated as GSSVTB(0,IH-IDEBV)=0
*/
/* when IH is uneven (see MMA2CFV). */
if (*ndujac % 2 == 0)
{
bid1 = 0.;
i__1 = nptu2;
for (ii = 1; ii <= i__1; ++ii)
{
bid1 += sosotb[ii] * gssutb[ii];
/* L400: */
}
chpair[0] = bid1;
}
else
{
bid1 = 0.;
i__1 = nptu2;
for (ii = 1; ii <= i__1; ++ii)
{
bid1 += diditb[ii] * gssutb[ii];
/* L500: */
}
chpair[0] = bid1;
}
if (*nbpntu % 2 != 0)
{
chpair[0] += sosotb[0] * gssutb[0];
}
}
/* ------------------------------ The end -------------------------------
*/
if (ldbg)
{
AdvApp2Var_SysBase::mgsomsg_("MMA2CFU", 7L);
}
return 0;
} /* mma2cfu_ */
//=================================================================================================
int mma2cfv_(int* ndvjac,
int* mindgu,
int* maxdgu,
int* nbpntv,
double* gssvtb,
double* chpair,
double* chimpr,
double* patjac)
{
/* System generated locals */
int chpair_dim1, chpair_offset, chimpr_dim1, chimpr_offset, patjac_offset, i__1, i__2;
/* Local variables */
long ldbg;
int nptv2, ii, jj;
double bid1;
/* **********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* Calculate the coefficients of polynomial approximation of F(u,v) */
/* of degree NDVJAC by V and of degree by U varying from MINDGU to MAXDGU.
*/
/* Keywords : */
/* ----------- */
/* FONCTION,APPROXIMATION,COEFFICIENT,POLYNOME */
/* INPUT ARGUMENTS : */
/* ------------------ */
/* NDVJAC: Degree of the polynom of approximation by V. */
/* The representation in the orthogonal base starts from degre 0. */
/* The polynomial base is the base of Jacobi of order -1 */
/* (Legendre), 0, 1 or 2 */
/* MINDGU: Degree minimum by U of coeff. to calculate. */
/* MAXDGU: Degree maximum by U of coeff. to calculate. */
/* NBPNTV: Degree of the Legendre polynom on the roots which of */
/* the coefficients of integration by V are calculated */
/* by Gauss method. It is required that NBPNTV = 30, 40, 50 or 61 and NDVJAC < NBPNTV.
*/
/* GSSVTB: Table of coefficients of integration by Gauss method */
/* by V for NDVJAC fixed: j varies from 0 to NBPNTV/2. */
/* CHPAIR: Table of terms connected to degrees from MINDGU to MAXDGU by U to */
/* calculate the coeff. of approximation of EVEN degree NDVJAC by V. */
/* CHIMPR: Table of terms connected to degrees from MINDGU to MAXDGU by U to */
/* calculate the coeff. of approximation of UNEVEN degree NDVJAC by V. */
/* OUTPUT ARGUMENTS : */
/* ------------------- */
/* PATJAC: Table of coefficients by U of the polynom of approximation */
/* P(u,v) of degree MINDGU to MAXDGU by U and NDVJAC by V. */
/* COMMONS USED : */
/* -------------- */
/* REFERENCES CALLED : */
/* --------------------- */
/* DESCRIPTION/NOTES/LIMITATIONS : */
/* ------------------------------- */
/* > */
/* **********************************************************************
*/
/* Name of the routine */
/* --------------------------- Initialisations --------------------------
*/
/* Parameter adjustments */
patjac_offset = *mindgu;
patjac -= patjac_offset;
chimpr_dim1 = *nbpntv / 2;
chimpr_offset = chimpr_dim1 * *mindgu + 1;
chimpr -= chimpr_offset;
chpair_dim1 = *nbpntv / 2 + 1;
chpair_offset = chpair_dim1 * *mindgu;
chpair -= chpair_offset;
/* Function Body */
ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
if (ldbg)
{
AdvApp2Var_SysBase::mgenmsg_("MMA2CFV", 7L);
}
nptv2 = *nbpntv / 2;
/* --------- Calculate the coefficients for even degree NDVJAC ----------
*/
if (*ndvjac % 2 == 0)
{
i__1 = *maxdgu;
for (ii = *mindgu; ii <= i__1; ++ii)
{
bid1 = 0.;
i__2 = nptv2;
for (jj = 1; jj <= i__2; ++jj)
{
bid1 += chpair[jj + ii * chpair_dim1] * gssvtb[jj];
/* L200: */
}
patjac[ii] = bid1;
/* L100: */
}
/* -------- Calculate the coefficients for uneven degree NDVJAC -----
---- */
}
else
{
i__1 = *maxdgu;
for (ii = *mindgu; ii <= i__1; ++ii)
{
bid1 = 0.;
i__2 = nptv2;
for (jj = 1; jj <= i__2; ++jj)
{
bid1 += chimpr[jj + ii * chimpr_dim1] * gssvtb[jj];
/* L250: */
}
patjac[ii] = bid1;
/* L150: */
}
}
/* ------- Add terms connected to the supplementary root (0.D0) ----- */
/* --------of the Legendre polynom of uneven degree NBPNTV --------- */
if (*nbpntv % 2 != 0 && *ndvjac % 2 == 0)
{
bid1 = gssvtb[0];
i__1 = *maxdgu;
for (ii = *mindgu; ii <= i__1; ++ii)
{
patjac[ii] += bid1 * chpair[ii * chpair_dim1];
/* L300: */
}
}
/* ------------------------------ The end -------------------------------
*/
if (ldbg)
{
AdvApp2Var_SysBase::mgsomsg_("MMA2CFV", 7L);
}
return 0;
} /* mma2cfv_ */
//=================================================================================================
int AdvApp2Var_ApproxF2var::mma2ds1_(int* ndimen,
double* uintfn,
double* vintfn,
const AdvApp2Var_EvaluatorFunc2Var& foncnp,
int* nbpntu,
int* nbpntv,
double* urootb,
double* vrootb,
int* isofav,
double* sosotb,
double* disotb,
double* soditb,
double* diditb,
double* fpntab,
double* ttable,
int* iercod)
{
/* System generated locals */
int sosotb_dim1, sosotb_dim2, sosotb_offset, disotb_dim1, disotb_dim2, disotb_offset, soditb_dim1,
soditb_dim2, soditb_offset, diditb_dim1, diditb_dim2, diditb_offset, fpntab_dim1, fpntab_offset,
i__1;
/* Local variables */
long ldbg;
int ibid1, ibid2, iuouv, nd;
int isz1, isz2;
/* **********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* Discretisation of function F(u,v) on the roots of Legendre polynoms. */
/* KEYWORDS : */
/* ----------- */
/* FONCTION&,DISCRETISATION,&POINT */
/* INPUT ARGUMENTS : */
/* ------------------ */
/* NDIMEN: Dimension of the space. */
/* UINTFN: Limits of the interval of definition by u of the function */
/* to be processed: (UINTFN(1),UINTFN(2)). */
/* VINTFN: Limits of the interval of definition by v of the function */
/* to be processed: (VINTFN(1),VINTFN(2)). */
/* FONCNP: The NAME of the non-polynomial function to be processed. */
/* NBPNTU: The degree of Legendre polynom on the roots which of */
/* FONCNP is discretized by u. */
/* NBPNTV: The degree of Legendre polynom on the roots which of */
/* FONCNP is discretized by v. */
/* UROOTB: Table of STRICTLY POSITIVE roots of the polynom */
/* of Legendre of degree NBPNTU defined on (-1,1). */
/* VROOTB: Table of STRICTLY POSITIVE roots of the polynom */
/* of Legendre of degree NBPNTV defined on (-1,1). */
/* ISOFAV: Shows the type of iso of F(u,v) to be extracted to improve */
/* the rapidity of calculation (has no influence on the form */
/* of result) */
/* = 1, shows that it is necessary to calculate the points of F(u,v) */
/* with fixed u (with NBPNTV values different from v). */
/* = 2, shows that it is necessaty to calculate the points of F(u,v) */
/* with fixed v (with NBPNTU values different from u). */
/* SOSOTB: Preinitialized table (input/output argument). */
/* DISOTB: Preinitialized table (input/output argument). */
/* SODITB: Preinitialized table (input/output argument). */
/* DIDITB: Preinitialized table (input/output argument). */
/* OUTPUT ARGUMENTS : */
/* ------------------- */
/* SOSOTB: Table where the terms */
/* F(ui,vj) + F(ui,-vj) + F(-ui,vj) + F(-ui,-vj) */
/* are added with ui and vj positive roots of Legendre polynom */
/* of degree NBPNTU and NBPNTV respectively. */
/* DISOTB: Table where the terms */
/* F(ui,vj) + F(ui,-vj) - F(-ui,vj) - F(-ui,-vj) */
/* are added with ui and vj positive roots of Legendre polynom */
/* of degree NBPNTU and NBPNTV respectively. */
/* SODITB: Table where the terms */
/* F(ui,vj) - F(ui,-vj) + F(-ui,vj) - F(-ui,-vj) */
/* are added with ui and vj positive roots of Legendre polynom */
/* of degree NBPNTU and NBPNTV respectively. */
/* DIDITB: Table where the terms */
/* F(ui,vj) - F(ui,-vj) - F(-ui,vj) + F(-ui,-vj) */
/* are added with ui and vj positive roots of Legendre polynom */
/* of degree NBPNTU and NBPNTV respectively. */
/* FPNTAB: Auxiliary table. */
/* TTABLE: Auxiliary table. */
/* IERCOD: Error code >100 Pb in the evaluation of FONCNP, */
/* the returned error code is equal to error code of FONCNP + 100. */
/* COMMONS USED : */
/* ---------------- */
/* REFERENCES CALLED : */
/* --------------------- */
/* DESCRIPTION/NOTES/LIMITATIONS : */
/* ----------------------------------- */
/* --> The external function created by the caller of MA2F1K, MA2FDK */
/* where MA2FXK should be in the following form : */
/* SUBROUTINE FONCNP(NDIMEN,UINTFN,VINTFN,ISOFAV,TCONST,NBPTAB */
/* ,TTABLE,IDERIU,IDERIV,PPNTAB,IERCOD) */
/* with the following input arguments : */
/* - NDIMEN is int defined as the sum of dimensions of */
/* sub-spaces (i.e. total dimension of the problem). */
/* - UINTFN(2) is a table of 2 reals containing the interval */
/* by u where the function to be approximated is defined */
/* (so it is equal to UIFONC). */
/* - VINTFN(2) is a table of 2 reals containing the interval */
/* by v where the function to be approximated is defined */
/* (so it is equal to VIFONC). */
/* - ISOFAV, is 1 if it is necessary to calculate points with constant u, */
/* is 2 if it is necessary to calculate points with constant v. */
/* Any other value is an error. */
/* - TCONST, float, value of the fixed parameter. Takes values */
/* in (UIFONC(1),UIFONC(2)) if ISOFAV = 1 or */
/* ins (VIFONC(1),VIFONC(2)) if ISOFAV = 2. */
/* - NBPTAB, int. Shows the number of points to be calculated. */
/* - TTABLE, a table of reals NBPTAB. These are the values of */
/* 'free' parameter of discretization (v if IISOFAV=1, */
/* u if IISOFAV=2). */
/* - IDERIU, int, takes values between 0 (position) */
/* and IORDRE(1) (partial derivative of the function by u */
/* of order IORDRE(1) if IORDRE(1) > 0). */
/* - IDERIV, int, takes values between 0 (position) */
/* and IORDRE(2) (partial derivative of the function by v */
/* of order IORDRE(2) if IORDRE(2) > 0). */
/* If IDERIU=i and IDERIV=j, FONCNP should calculate the */
/* points of the derivative : */
/* i+j */
/* d F(u,v) */
/* -------- */
/* i j */
/* du dv */
/* and the output arguments aret : */
/* - FPNTAB(NDIMEN,NBPTAB) contains, at output, the table of */
/* NBPTAB points calculated in FONCNP. */
/* - IERCOD is, at output the error code of FONCNP. This code */
/* (int) should be strictly positive if there is a problem. */
/* The input arguments SHOULD NOT be modified under FONCNP.
*/
/* -->As FONCNP is not forcedly defined in (-1,1)*(-1,1), the */
/* values of UROOTB and VROOTB are consequently modified. */
/* -->The results of discretisation are ranked in 4 tables */
/* SOSOTB, DISOTB, SODITB and DIDITB to earn time */
/* during the calculation of coefficients of the polynom of approximation. */
/* When NBPNTU is uneven : */
/* table SOSOTB(0,j) contains F(0,vj) + F(0,-vj), */
/* table DIDITB(0,j) contains F(0,vj) - F(0,-vj), */
/* When NBPNTV is uneven : */
/* table SOSOTB(i,0) contains F(ui,0) + F(-ui,0), */
/* table DIDITB(i,0) contains F(ui,0) - F(-ui,0), */
/* When NBPNTU and NBPNTV are uneven : */
/* term SOSOTB(0,0) contains F(0,0). */
/* > */
/* **********************************************************************
*/
/* Name of the routine */
/* --------------------------- Initialization --------------------------
*/
/* Parameter adjustments */
fpntab_dim1 = *ndimen;
fpntab_offset = fpntab_dim1 + 1;
fpntab -= fpntab_offset;
--uintfn;
--vintfn;
--urootb;
diditb_dim1 = *nbpntu / 2 + 1;
diditb_dim2 = *nbpntv / 2 + 1;
diditb_offset = diditb_dim1 * diditb_dim2;
diditb -= diditb_offset;
soditb_dim1 = *nbpntu / 2;
soditb_dim2 = *nbpntv / 2;
soditb_offset = soditb_dim1 * (soditb_dim2 + 1) + 1;
soditb -= soditb_offset;
disotb_dim1 = *nbpntu / 2;
disotb_dim2 = *nbpntv / 2;
disotb_offset = disotb_dim1 * (disotb_dim2 + 1) + 1;
disotb -= disotb_offset;
sosotb_dim1 = *nbpntu / 2 + 1;
sosotb_dim2 = *nbpntv / 2 + 1;
sosotb_offset = sosotb_dim1 * sosotb_dim2;
sosotb -= sosotb_offset;
--vrootb;
--ttable;
/* Function Body */
ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
if (ldbg)
{
AdvApp2Var_SysBase::mgenmsg_("MMA2DS1", 7L);
}
*iercod = 0;
if (*isofav < 1 || *isofav > 2)
{
iuouv = 2;
}
else
{
iuouv = *isofav;
}
/* **********************************************************************
*/
/* --------- Discretization by U on the roots of the polynom of ------ */
/* --------------- Legendre of degree NBPNTU, iso-V by iso-V --------- */
/* **********************************************************************
*/
if (iuouv == 2)
{
mma2ds2_(ndimen,
&uintfn[1],
&vintfn[1],
foncnp,
nbpntu,
nbpntv,
&urootb[1],
&vrootb[1],
&iuouv,
&sosotb[sosotb_offset],
&disotb[disotb_offset],
&soditb[soditb_offset],
&diditb[diditb_offset],
&fpntab[fpntab_offset],
&ttable[1],
iercod);
/* ******************************************************************
**** */
/* --------- Discretization by V on the roots of the polynom of ------ */
/* --------------- Legendre of degree NBPNTV, iso-V by iso-V --------- */
/* ******************************************************************
**** */
}
else
{
/* --> Inversion of indices of tables */
i__1 = *ndimen;
for (nd = 1; nd <= i__1; ++nd)
{
isz1 = *nbpntu / 2 + 1;
isz2 = *nbpntv / 2 + 1;
AdvApp2Var_MathBase::mmfmtb1_(&isz1,
&sosotb[nd * sosotb_dim2 * sosotb_dim1],
&isz1,
&isz2,
&isz2,
&sosotb[nd * sosotb_dim2 * sosotb_dim1],
&ibid1,
&ibid2,
iercod);
if (*iercod > 0)
{
goto L9999;
}
AdvApp2Var_MathBase::mmfmtb1_(&isz1,
&diditb[nd * diditb_dim2 * diditb_dim1],
&isz1,
&isz2,
&isz2,
&diditb[nd * diditb_dim2 * diditb_dim1],
&ibid1,
&ibid2,
iercod);
if (*iercod > 0)
{
goto L9999;
}
isz1 = *nbpntu / 2;
isz2 = *nbpntv / 2;
AdvApp2Var_MathBase::mmfmtb1_(&isz1,
&soditb[(nd * soditb_dim2 + 1) * soditb_dim1 + 1],
&isz1,
&isz2,
&isz2,
&soditb[(nd * soditb_dim2 + 1) * soditb_dim1 + 1],
&ibid1,
&ibid2,
iercod);
if (*iercod > 0)
{
goto L9999;
}
AdvApp2Var_MathBase::mmfmtb1_(&isz1,
&disotb[(nd * disotb_dim2 + 1) * disotb_dim1 + 1],
&isz1,
&isz2,
&isz2,
&disotb[(nd * disotb_dim2 + 1) * disotb_dim1 + 1],
&ibid1,
&ibid2,
iercod);
if (*iercod > 0)
{
goto L9999;
}
/* L100: */
}
mma2ds2_(ndimen,
&vintfn[1],
&uintfn[1],
foncnp,
nbpntv,
nbpntu,
&vrootb[1],
&urootb[1],
&iuouv,
&sosotb[sosotb_offset],
&soditb[soditb_offset],
&disotb[disotb_offset],
&diditb[diditb_offset],
&fpntab[fpntab_offset],
&ttable[1],
iercod);
/* --> Inversion of indices of tables */
i__1 = *ndimen;
for (nd = 1; nd <= i__1; ++nd)
{
isz1 = *nbpntv / 2 + 1;
isz2 = *nbpntu / 2 + 1;
AdvApp2Var_MathBase::mmfmtb1_(&isz1,
&sosotb[nd * sosotb_dim2 * sosotb_dim1],
&isz1,
&isz2,
&isz2,
&sosotb[nd * sosotb_dim2 * sosotb_dim1],
&ibid1,
&ibid2,
iercod);
if (*iercod > 0)
{
goto L9999;
}
AdvApp2Var_MathBase::mmfmtb1_(&isz1,
&diditb[nd * diditb_dim2 * diditb_dim1],
&isz1,
&isz2,
&isz2,
&diditb[nd * diditb_dim2 * diditb_dim1],
&ibid1,
&ibid2,
iercod);
if (*iercod > 0)
{
goto L9999;
}
isz1 = *nbpntv / 2;
isz2 = *nbpntu / 2;
AdvApp2Var_MathBase::mmfmtb1_(&isz1,
&soditb[(nd * soditb_dim2 + 1) * soditb_dim1 + 1],
&isz1,
&isz2,
&isz2,
&soditb[(nd * soditb_dim2 + 1) * soditb_dim1 + 1],
&ibid1,
&ibid2,
iercod);
if (*iercod > 0)
{
goto L9999;
}
AdvApp2Var_MathBase::mmfmtb1_(&isz1,
&disotb[(nd * disotb_dim2 + 1) * disotb_dim1 + 1],
&isz1,
&isz2,
&isz2,
&disotb[(nd * disotb_dim2 + 1) * disotb_dim1 + 1],
&ibid1,
&ibid2,
iercod);
if (*iercod > 0)
{
goto L9999;
}
/* L200: */
}
}
/* ------------------------------ The end -------------------------------
*/
L9999:
if (*iercod > 0)
{
*iercod += 100;
AdvApp2Var_SysBase::maermsg_("MMA2DS1", iercod, 7L);
}
if (ldbg)
{
AdvApp2Var_SysBase::mgsomsg_("MMA2DS1", 7L);
}
return 0;
} /* mma2ds1_ */
//=================================================================================================
int mma2ds2_(int* ndimen,
double* uintfn,
double* vintfn,
const AdvApp2Var_EvaluatorFunc2Var& foncnp,
int* nbpntu,
int* nbpntv,
double* urootb,
double* vrootb,
int* iiuouv,
double* sosotb,
double* disotb,
double* soditb,
double* diditb,
double* fpntab,
double* ttable,
int* iercod)
{
int c__0 = 0;
/* System generated locals */
int sosotb_dim1, sosotb_dim2, sosotb_offset, disotb_dim1, disotb_dim2, disotb_offset, soditb_dim1,
soditb_dim2, soditb_offset, diditb_dim1, diditb_dim2, diditb_offset, fpntab_dim1, fpntab_offset,
i__1, i__2, i__3;
/* Local variables */
int jdec;
long ldbg;
double alinu, blinu, alinv, blinv, tcons;
double dbfn1[2], dbfn2[2];
int nuroo, nvroo, id, iu, iv;
double um, up;
/* **********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* Discretization of function F(u,v) on the roots of polynoms of Legendre. */
/* KEYWORDS : */
/* ----------- */
/* FONCTION&,DISCRETISATION,&POINT */
/* INPUT ARGUMENTS : */
/* ------------------ */
/* NDIMEN: Dimension of the space. */
/* UINTFN: Limits of the interval of definition by u of the function */
/* to be processed: (UINTFN(1),UINTFN(2)). */
/* VINTFN: Limits of the interval of definition by v of the function */
/* to be processed: (VINTFN(1),VINTFN(2)). */
/* FONCNP: The NAME of the non-polynomial function to be processed. */
/* NBPNTU: The degree of Legendre polynom on the roots which of */
/* FONCNP is discretized by u. */
/* NBPNTV: The degree of Legendre polynom on the roots which of */
/* FONCNP is discretized by v. */
/* UROOTB: Table of STRICTLY POSITIVE roots of the polynom */
/* of Legendre of degree NBPNTU defined on (-1,1). */
/* VROOTB: Table of STRICTLY POSITIVE roots of the polynom */
/* of Legendre of degree NBPNTV defined on (-1,1). */
/* IIUOUV: Shows the type of iso of F(u,v) tom be extracted to improve the */
/* rapidity of calculation (has no influence on the form of result) */
/* = 1, shows that it is necessary to calculate the points of F(u,v) */
/* with fixed u (so with NBPNTV values different from v). */
/* = 2, shows that it is necessary to calculate the points of F(u,v) */
/* with fixed v (so with NBPNTV values different from u). */
/* SOSOTB: Preinitialized table (input/output argument). */
/* DISOTB: Preinitialized table (input/output argument). */
/* SODITB: Preinitialized table (input/output argument). */
/* DIDITB: Preinitialized table (input/output argument). */
/* OUTPUT ARGUMENTS : */
/* ------------------- */
/* SOSOTB: Table where the terms */
/* F(ui,vj) + F(ui,-vj) + F(-ui,vj) + F(-ui,-vj) */
/* are added with ui and vj positive roots of Legendre polynom */
/* of degree NBPNTU and NBPNTV respectively. */
/* DISOTB: Table where the terms */
/* F(ui,vj) + F(ui,-vj) - F(-ui,vj) - F(-ui,-vj) */
/* are added with ui and vj positive roots of Legendre polynom */
/* of degree NBPNTU and NBPNTV respectively. */
/* SODITB: Table where the terms */
/* F(ui,vj) - F(ui,-vj) + F(-ui,vj) - F(-ui,-vj) */
/* are added with ui and vj positive roots of Legendre polynom */
/* of degree NBPNTU and NBPNTV respectively. */
/* DIDITB: Table where the terms */
/* F(ui,vj) - F(ui,-vj) - F(-ui,vj) + F(-ui,-vj) */
/* are added with ui and vj positive roots of Legendre polynom */
/* of degree NBPNTU and NBPNTV respectively. */
/* FPNTAB: Auxiliary table. */
/* TTABLE: Auxiliary table. */
/* IERCOD: Error code >100 Pb in the evaluation of FONCNP, */
/* the returned error code is equal to error code of FONCNP + 100. */
/* COMMONS USED : */
/* ---------------- */
/* REFERENCES CALLED : */
/* --------------------- */
/* DESCRIPTION/NOTES/LIMITATIONS : */
/* ----------------------------------- */
/* --> The external function created by the caller of MA2F1K, MA2FDK */
/* where MA2FXK should be in the following form : */
/* SUBROUTINE FONCNP(NDIMEN,UINTFN,VINTFN,IIIUOUV,TCONST,NBPTAB */
/* ,TTABLE,IDERIU,IDERIV,PPNTAB,IERCOD) */
/* with the following input arguments : */
/* - NDIMEN is int defined as the sum of dimensions of */
/* sub-spaces (i.e. total dimension of the problem). */
/* - UINTFN(2) is a table of 2 reals containing the interval */
/* by u where the function to be approximated is defined */
/* (so it is equal to UIFONC). */
/* - VINTFN(2) is a table of 2 reals containing the interval */
/* by v where the function to be approximated is defined */
/* (so it is equal to VIFONC). */
/* - IIIUOUV, is 1 if it is necessary to calculate points with constant u, */
/* is 2 if it is necessary to calculate points with constant v. */
/* Any other value is an error. */
/* - TCONST, float, value of the fixed parameter. Takes values */
/* in (UIFONC(1),UIFONC(2)) if ISOFAV = 1 or */
/* ins (VIFONC(1),VIFONC(2)) if ISOFAV = 2. */
/* - NBPTAB, int. Shows the number of points to be calculated. */
/* - TTABLE, a table of reals NBPTAB. These are the values of */
/* 'free' parameter of discretization (v if IIIUOUV=1, */
/* u if IIIUOUV=2). */
/* - IDERIU, int, takes values between 0 (position) */
/* and IORDRE(1) (partial derivative of the function by u */
/* of order IORDRE(1) if IORDRE(1) > 0). */
/* - IDERIV, int, takes values between 0 (position) */
/* and IORDRE(2) (partial derivative of the function by v */
/* of order IORDRE(2) if IORDRE(2) > 0). */
/* If IDERIU=i and IDERIV=j, FONCNP should calculate the */
/* points of the derivative : */
/* i+j */
/* d F(u,v) */
/* -------- */
/* i j */
/* du dv */
/* and the output arguments aret : */
/* - FPNTAB(NDIMEN,NBPTAB) contains, at output, the table of */
/* NBPTAB points calculated in FONCNP. */
/* - IERCOD is, at output the error code of FONCNP. This code */
/* (int) should be strictly positive if there is a problem. */
/* The input arguments SHOULD NOT be modified under FONCNP.
*/
/* -->As FONCNP is not forcedly defined in (-1,1)*(-1,1), the */
/* values of UROOTB and VROOTB are consequently modified. */
/* -->The results of discretisation are ranked in 4 tables */
/* SOSOTB, DISOTB, SODITB and DIDITB to earn time */
/* during the calculation of coefficients of the polynom of approximation. */
/* When NBPNTU is uneven : */
/* table SOSOTB(0,j) contains F(0,vj) + F(0,-vj), */
/* table DIDITB(0,j) contains F(0,vj) - F(0,-vj), */
/* When NBPNTV is uneven : */
/* table SOSOTB(i,0) contains F(ui,0) + F(-ui,0), */
/* table DIDITB(i,0) contains F(ui,0) - F(-ui,0), */
/* When NBPNTU and NBPNTV are uneven : */
/* term SOSOTB(0,0) contains F(0,0). */
/* ATTENTION: These 4 tables are filled by varying the */
/* 1st index first. So, the discretizations */
/* of F(...,t) (for IIUOUV = 2) or of F(t,...) (IIUOUV = 1) */
/* are stored in SOSOTB(...,t), SODITB(...,t), etc... */
/* (this allows to gain important time). */
/* It is required that the caller, in case of IIUOUV=1, */
/* invert the roles of u and v, of SODITB and DISOTB BEFORE the */
/* > */
/* **********************************************************************
*/
/* Name of the routine */
/* --> Indices of loops. */
/* --------------------------- Initialization --------------------------
*/
/* Parameter adjustments */
--uintfn;
--vintfn;
--ttable;
fpntab_dim1 = *ndimen;
fpntab_offset = fpntab_dim1 + 1;
fpntab -= fpntab_offset;
--urootb;
diditb_dim1 = *nbpntu / 2 + 1;
diditb_dim2 = *nbpntv / 2 + 1;
diditb_offset = diditb_dim1 * diditb_dim2;
diditb -= diditb_offset;
soditb_dim1 = *nbpntu / 2;
soditb_dim2 = *nbpntv / 2;
soditb_offset = soditb_dim1 * (soditb_dim2 + 1) + 1;
soditb -= soditb_offset;
disotb_dim1 = *nbpntu / 2;
disotb_dim2 = *nbpntv / 2;
disotb_offset = disotb_dim1 * (disotb_dim2 + 1) + 1;
disotb -= disotb_offset;
sosotb_dim1 = *nbpntu / 2 + 1;
sosotb_dim2 = *nbpntv / 2 + 1;
sosotb_offset = sosotb_dim1 * sosotb_dim2;
sosotb -= sosotb_offset;
--vrootb;
/* Function Body */
ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
if (ldbg)
{
AdvApp2Var_SysBase::mgenmsg_("MMA2DS2", 7L);
}
*iercod = 0;
alinu = (uintfn[2] - uintfn[1]) / 2.;
blinu = (uintfn[2] + uintfn[1]) / 2.;
alinv = (vintfn[2] - vintfn[1]) / 2.;
blinv = (vintfn[2] + vintfn[1]) / 2.;
if (*iiuouv == 1)
{
dbfn1[0] = vintfn[1];
dbfn1[1] = vintfn[2];
dbfn2[0] = uintfn[1];
dbfn2[1] = uintfn[2];
}
else
{
dbfn1[0] = uintfn[1];
dbfn1[1] = uintfn[2];
dbfn2[0] = vintfn[1];
dbfn2[1] = vintfn[2];
}
/* **********************************************************************
*/
/* -------- Discretization by U on the roots of Legendre polynom -------- */
/* ---------------- of degree NBPNTU, with Vj fixed -------------------- */
/* **********************************************************************
*/
nuroo = *nbpntu / 2;
nvroo = *nbpntv / 2;
jdec = (*nbpntu + 1) / 2;
/* ----------- Loading of parameters of discretization by U ------------- */
i__1 = *nbpntu;
for (iu = 1; iu <= i__1; ++iu)
{
ttable[iu] = blinu + alinu * urootb[iu];
/* L100: */
}
/* -------------- For Vj fixed, negative root of Legendre ------------- */
i__1 = nvroo;
for (iv = 1; iv <= i__1; ++iv)
{
tcons = blinv + alinv * vrootb[iv];
(*const_cast<AdvApp2Var_EvaluatorFunc2Var*>(&foncnp))
.Evaluate(ndimen,
dbfn1,
dbfn2,
iiuouv,
&tcons,
nbpntu,
&ttable[1],
&c__0,
&c__0,
&fpntab[fpntab_offset],
iercod);
if (*iercod > 0)
{
goto L9999;
}
i__2 = *ndimen;
for (id = 1; id <= i__2; ++id)
{
i__3 = nuroo;
for (iu = 1; iu <= i__3; ++iu)
{
up = fpntab[id + (iu + jdec) * fpntab_dim1];
um = fpntab[id + (nuroo - iu + 1) * fpntab_dim1];
sosotb[iu + (nvroo - iv + 1 + id * sosotb_dim2) * sosotb_dim1] =
sosotb[iu + (nvroo - iv + 1 + id * sosotb_dim2) * sosotb_dim1] + up + um;
disotb[iu + (nvroo - iv + 1 + id * disotb_dim2) * disotb_dim1] =
disotb[iu + (nvroo - iv + 1 + id * disotb_dim2) * disotb_dim1] + up - um;
soditb[iu + (nvroo - iv + 1 + id * soditb_dim2) * soditb_dim1] =
soditb[iu + (nvroo - iv + 1 + id * soditb_dim2) * soditb_dim1] - up - um;
diditb[iu + (nvroo - iv + 1 + id * diditb_dim2) * diditb_dim1] =
diditb[iu + (nvroo - iv + 1 + id * diditb_dim2) * diditb_dim1] - up + um;
/* L220: */
}
if (*nbpntu % 2 != 0)
{
up = fpntab[id + jdec * fpntab_dim1];
sosotb[(nvroo - iv + 1 + id * sosotb_dim2) * sosotb_dim1] += up;
diditb[(nvroo - iv + 1 + id * diditb_dim2) * diditb_dim1] -= up;
}
/* L210: */
}
/* L200: */
}
/* --------- For Vj = 0 (uneven NBPNTV), discretization by U ----------- */
if (*nbpntv % 2 != 0)
{
tcons = blinv;
(*const_cast<AdvApp2Var_EvaluatorFunc2Var*>(&foncnp))
.Evaluate(ndimen,
dbfn1,
dbfn2,
iiuouv,
&tcons,
nbpntu,
&ttable[1],
&c__0,
&c__0,
&fpntab[fpntab_offset],
iercod);
if (*iercod > 0)
{
goto L9999;
}
i__1 = *ndimen;
for (id = 1; id <= i__1; ++id)
{
i__2 = nuroo;
for (iu = 1; iu <= i__2; ++iu)
{
up = fpntab[id + (jdec + iu) * fpntab_dim1];
um = fpntab[id + (nuroo - iu + 1) * fpntab_dim1];
sosotb[iu + id * sosotb_dim2 * sosotb_dim1] =
sosotb[iu + id * sosotb_dim2 * sosotb_dim1] + up + um;
diditb[iu + id * diditb_dim2 * diditb_dim1] =
diditb[iu + id * diditb_dim2 * diditb_dim1] + up - um;
/* L310: */
}
if (*nbpntu % 2 != 0)
{
up = fpntab[id + jdec * fpntab_dim1];
sosotb[id * sosotb_dim2 * sosotb_dim1] += up;
}
/* L300: */
}
}
/* -------------- For Vj fixed, positive root of Legendre ------------- */
i__1 = nvroo;
for (iv = 1; iv <= i__1; ++iv)
{
tcons = alinv * vrootb[(*nbpntv + 1) / 2 + iv] + blinv;
(*const_cast<AdvApp2Var_EvaluatorFunc2Var*>(&foncnp))
.Evaluate(ndimen,
dbfn1,
dbfn2,
iiuouv,
&tcons,
nbpntu,
&ttable[1],
&c__0,
&c__0,
&fpntab[fpntab_offset],
iercod);
if (*iercod > 0)
{
goto L9999;
}
i__2 = *ndimen;
for (id = 1; id <= i__2; ++id)
{
i__3 = nuroo;
for (iu = 1; iu <= i__3; ++iu)
{
up = fpntab[id + (iu + jdec) * fpntab_dim1];
um = fpntab[id + (nuroo - iu + 1) * fpntab_dim1];
sosotb[iu + (iv + id * sosotb_dim2) * sosotb_dim1] =
sosotb[iu + (iv + id * sosotb_dim2) * sosotb_dim1] + up + um;
disotb[iu + (iv + id * disotb_dim2) * disotb_dim1] =
disotb[iu + (iv + id * disotb_dim2) * disotb_dim1] + up - um;
soditb[iu + (iv + id * soditb_dim2) * soditb_dim1] =
soditb[iu + (iv + id * soditb_dim2) * soditb_dim1] + up + um;
diditb[iu + (iv + id * diditb_dim2) * diditb_dim1] =
diditb[iu + (iv + id * diditb_dim2) * diditb_dim1] + up - um;
/* L420: */
}
if (*nbpntu % 2 != 0)
{
up = fpntab[id + jdec * fpntab_dim1];
sosotb[(iv + id * sosotb_dim2) * sosotb_dim1] += up;
diditb[(iv + id * diditb_dim2) * diditb_dim1] += up;
}
/* L410: */
}
/* L400: */
}
/* ------------------------------ The end -------------------------------
*/
L9999:
if (*iercod > 0)
{
*iercod += 100;
AdvApp2Var_SysBase::maermsg_("MMA2DS2", iercod, 7L);
}
if (ldbg)
{
AdvApp2Var_SysBase::mgsomsg_("MMA2DS2", 7L);
}
return 0;
} /* mma2ds2_ */
//=================================================================================================
int mma2er1_(int* ndjacu,
int* ndjacv,
int* ndimen,
int* mindgu,
int* maxdgu,
int* mindgv,
int* maxdgv,
int* iordru,
int* iordrv,
double* xmaxju,
double* xmaxjv,
double* patjac,
double* vecerr,
double* erreur)
{
/* System generated locals */
int patjac_dim1, patjac_dim2, patjac_offset, i__1, i__2, i__3;
double d__1;
/* Local variables */
long ldbg;
int minu, minv;
double vaux[2];
int ii, nd, jj;
double bid0, bid1;
/* **********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* Calculate max approximation error done when */
/* the coefficients of PATJAC such that the degree by U varies between */
/* MINDGU and MAXDGU and the degree by V varies between MINDGV and MAXDGV are removed. */
/* KEYWORDS : */
/* ----------- */
/* TOUS,AB_SPECIFI:: CARREAU&,CALCUL,&ERREUR */
/* INPUT ARGUMENTS : */
/* ------------------ */
/* NDJACU: Dimension by U of table PATJAC. */
/* NDJACV: Dimension by V of table PATJAC. */
/* NDIMEN: Dimension of the space. */
/* MINDGU: Lower limit of index by U of coeff. of PATJAC to be taken into account. */
/* MAXDGU: Upper limit of index by U of coeff. of PATJAC to be taken into account. */
/* MINDGV: Lower limit of index by V of coeff. of PATJAC to be taken into account. */
/* MAXDGV: Upper limit of index by V of coeff. of PATJAC to be taken into account. */
/* IORDRU: Order of continuity by U provided by square PATJAC (from -1 to 2) */
/* IORDRV: Order of continuity by U provided by square PATJAC (from -1 to 2) */
/* XMAXJU: Maximum value of Jacobi polynoms of order IORDRU, */
/* from degree 0 to MAXDGU - 2*(IORDU+1) */
/* XMAXJV: Maximum value of Jacobi polynoms of order IORDRV, */
/* from degree 0 to MAXDGV - 2*(IORDV+1) */
/* PATJAC: Table of coeff. of square of approximation with */
/* constraints of order IORDRU by U and IORDRV by V. */
/* VECERR: Auxiliary vector. */
/* ERREUR: MAX Error committed during removal of ALREADY CALCULATED coeff of PATJAC */
/* OUTPUT ARGUMENTS : */
/* ------------------- */
/* ERREUR: MAX Error committed during removal of coeff of PATJAC */
/* of indices from MINDGU to MAXDGU by U and from MINDGV to MAXDGV by V */
/* THEN the already calculated error. */
/* COMMONS USED : */
/* ---------------- */
/* REFERENCES CALLED : */
/* --------------------- */
/* DESCRIPTION/NOTES/LIMITATIONS : */
/* ----------------------------------- */
/* Table PATJAC is the place of storage of coeff. Cij of the square of */
/* approximation of F(U,V). The indices i and j show the degree */
/* by U and by V of base polynoms. These polynoms have the form: */
/* ((1 - U*U)**(IORDRU+1)).J(i-2*(IORDRU+1)(U), where */
/* polynom J(i-2*(IORDU+1)(U) is the Jacobi polynom of order */
/* IORDRU+1 (the same by V by replacing U u V in the expression above). */
/* The contribution to the error of term Cij when it is */
/* removed from PATJAC is increased by: */
/* DABS(Cij)*XMAXJU(i-2*(IORDRU+1))*XMAXJV(J-2*(IORDRV+1)) where */
/* XMAXJU(i-2*(IORDRU+1) = ((1 - U*U)**(IORDRU+1)).J(i-2*(IORDRU+1)(U),
*/
/* XMAXJV(i-2*(IORDRV+1) = ((1 - V*V)**(IORDRV+1)).J(j-2*(IORDRV+1)(V).
*/
/* > */
/* ***********************************************************************
*/
/* Name of the routine */
/* ----------------------------- Initialisations ------------------------
*/
/* Parameter adjustments */
--vecerr;
patjac_dim1 = *ndjacu + 1;
patjac_dim2 = *ndjacv + 1;
patjac_offset = patjac_dim1 * patjac_dim2;
patjac -= patjac_offset;
/* Function Body */
ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
if (ldbg)
{
AdvApp2Var_SysBase::mgenmsg_("MMA2ER1", 7L);
}
minu = (*iordru + 1) << 1;
minv = (*iordrv + 1) << 1;
/* ------------------- Calculate the increment of the max error --------------- */
/* ----- during the removal of the coeffs of indices from MINDGU to MAXDGU ---- */
/* ---------------- by U and indices from MINDGV to MAXDGV by V --------------- */
i__1 = *ndimen;
for (nd = 1; nd <= i__1; ++nd)
{
bid1 = 0.;
i__2 = *maxdgv;
for (jj = *mindgv; jj <= i__2; ++jj)
{
bid0 = 0.;
i__3 = *maxdgu;
for (ii = *mindgu; ii <= i__3; ++ii)
{
bid0 += (d__1 = patjac[ii + (jj + nd * patjac_dim2) * patjac_dim1], std::abs(d__1))
* xmaxju[ii - minu];
/* L300: */
}
bid1 = bid0 * xmaxjv[jj - minv] + bid1;
/* L200: */
}
vecerr[nd] = bid1;
/* L100: */
}
/* ----------------------- Calculate the max error ----------------------*/
bid1 = AdvApp2Var_MathBase::mzsnorm_(ndimen, &vecerr[1]);
vaux[0] = *erreur;
vaux[1] = bid1;
nd = 2;
*erreur = AdvApp2Var_MathBase::mzsnorm_(&nd, vaux);
/* ------------------------- The end ------------------------------------
*/
if (ldbg)
{
AdvApp2Var_SysBase::mgsomsg_("MMA2ER1", 7L);
}
return 0;
} /* mma2er1_ */
//=================================================================================================
int mma2er2_(int* ndjacu,
int* ndjacv,
int* ndimen,
int* mindgu,
int* maxdgu,
int* mindgv,
int* maxdgv,
int* iordru,
int* iordrv,
double* xmaxju,
double* xmaxjv,
double* patjac,
double* epmscut,
double* vecerr,
double* erreur,
int* newdgu,
int* newdgv)
{
/* System generated locals */
int patjac_dim1, patjac_dim2, patjac_offset, i__1, i__2;
double d__1;
/* Local variables */
long ldbg;
double vaux[2];
int i2rdu, i2rdv;
double errnu, errnv;
int ii, nd, jj, nu, nv;
/* **********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* Remove coefficients of PATJAC to obtain the minimum degree */
/* by U and V checking the imposed tolerance. */
/* KEYWORDS : */
/* ----------- */
/* TOUS,AB_SPECIFI:: CARREAU&,CALCUL,&ERREUR */
/* INPUT ARGUMENTS : */
/* ------------------ */
/* NDJACU: Degree by U of table PATJAC. */
/* NDJACV: Degree by V of table PATJAC. */
/* NDIMEN: Dimension of the space. */
/* MINDGU: Limit of index by U of coeff. of PATJAC to be PRESERVED (should be >=0). */
/* MAXDGU: Upper limit of index by U of coeff. of PATJAC to be taken into account. */
/* MINDGV: Limit of index by V of coeff. of PATJAC to be PRESERVED (should be >=0). */
/* MAXDGV: Upper limit of index by V of coeff. of PATJAC to be taken into account. */
/* IORDRU: Order of continuity by U provided by square PATJAC (from -1 to 2) */
/* IORDRV: Order of continuity by U provided by square PATJAC (from -1 to 2) */
/* XMAXJU: Maximum value of Jacobi polynoms of order IORDRU, */
/* from degree 0 to MAXDGU - 2*(IORDU+1) */
/* XMAXJV: Maximum value of Jacobi polynoms of order IORDRV, */
/* from degree 0 to MAXDGV - 2*(IORDV+1) */
/* PATJAC: Table of coeff. of square of approximation with */
/* constraints of order IORDRU by U and IORDRV by V. */
/* EPMSCUT: Tolerance of approximation. */
/* VECERR: Auxiliary vector. */
/* ERREUR: MAX Error committed ALREADY CALCULATED */
/* OUTPUT ARGUMENTS : */
/* ------------------- */
/* ERREUR: MAX Error committed by preserving only coeff of PATJAC */
/* of indices from 0 to NEWDGU by U and from 0 to NEWDGV by V */
/* PLUS the already calculated error. */
/* NEWDGU: Min. Degree by U such as the square of approximation */
/* could check the tolerance. There is always NEWDGU >= MINDGU >= 0. */
/* NEWDGV: Min. Degree by V such as the square of approximation */
/* could check the tolerance. There is always NEWDGV >= MINDGV >= 0. */
/* COMMONS USED : */
/* ---------------- */
/* REFERENCES CALLED : */
/* --------------------- */
/* DESCRIPTION/NOTES/LIMITATIONS : */
/* ----------------------------------- */
/* Table PATJAC is the place of storage of coeff. Cij of the square of */
/* approximation of F(U,V). The indices i and j show the degree */
/* by U and by V of base polynoms. These polynoms have the form: */
/* ((1 - U*U)**(IORDRU+1)).J(i-2*(IORDRU+1)(U), where */
/* polynom J(i-2*(IORDU+1)(U) is the Jacobi polynom of order */
/* IORDRU+1 (the same by V by replacing U u V in the expression above). */
/* The contribution to the error of term Cij when it is */
/* removed from PATJAC is increased by: */
/* DABS(Cij)*XMAXJU(i-2*(IORDRU+1))*XMAXJV(J-2*(IORDRV+1)) where */
/* XMAXJU(i-2*(IORDRU+1) = ((1 - U*U)**(IORDRU+1)).J(i-2*(IORDRU+1)(U),
*/
/* XMAXJV(i-2*(IORDRV+1) = ((1 - V*V)**(IORDRV+1)).J(j-2*(IORDRV+1)(V).
*/
/* > */
/* **********************************************************************
*/
/* Name of the routine */
/* ----------------------------- Initialisations ------------------------
*/
/* Parameter adjustments */
--vecerr;
patjac_dim1 = *ndjacu + 1;
patjac_dim2 = *ndjacv + 1;
patjac_offset = patjac_dim1 * patjac_dim2;
patjac -= patjac_offset;
/* Function Body */
ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
if (ldbg)
{
AdvApp2Var_SysBase::mgenmsg_("MMA2ER2", 7L);
}
i2rdu = (*iordru + 1) << 1;
i2rdv = (*iordrv + 1) << 1;
nu = *maxdgu;
nv = *maxdgv;
/* **********************************************************************
*/
/* -------------------- Cutting of oefficients ------------------------
*/
/* **********************************************************************
*/
L1001:
/* ------------------- Calculate the increment of max error --------------- */
/* ----- during the removal of coeff. of indices from MINDGU to MAXDGU ------ */
/* ---------------- by U, the degree by V is fixed to NV -----------------
*/
if (nv > *mindgv)
{
double bid0 = xmaxjv[nv - i2rdv];
i__1 = *ndimen;
for (nd = 1; nd <= i__1; ++nd)
{
double bid1 = 0.;
i__2 = nu;
for (ii = i2rdu; ii <= i__2; ++ii)
{
bid1 += (d__1 = patjac[ii + (nv + nd * patjac_dim2) * patjac_dim1], std::abs(d__1))
* xmaxju[ii - i2rdu] * bid0;
/* L200: */
}
vecerr[nd] = bid1;
/* L100: */
}
}
else
{
vecerr[1] = *epmscut * 2;
}
errnv = AdvApp2Var_MathBase::mzsnorm_(ndimen, &vecerr[1]);
/* ------------------- Calculate the increment of max error --------------- */
/* ----- during the removal of coeff. of indices from MINDGV to MAXDGV ------ */
/* ---------------- by V, the degree by U is fixed to NU -----------------
*/
if (nu > *mindgu)
{
double bid0 = xmaxju[nu - i2rdu];
i__1 = *ndimen;
for (nd = 1; nd <= i__1; ++nd)
{
double bid1 = 0.;
i__2 = nv;
for (jj = i2rdv; jj <= i__2; ++jj)
{
bid1 += (d__1 = patjac[nu + (jj + nd * patjac_dim2) * patjac_dim1], std::abs(d__1))
* xmaxjv[jj - i2rdv] * bid0;
/* L400: */
}
vecerr[nd] = bid1;
/* L300: */
}
}
else
{
vecerr[1] = *epmscut * 2;
}
errnu = AdvApp2Var_MathBase::mzsnorm_(ndimen, &vecerr[1]);
/* ----------------------- Calculate the max error ----------------------
*/
vaux[0] = *erreur;
vaux[1] = errnu;
nd = 2;
errnu = AdvApp2Var_MathBase::mzsnorm_(&nd, vaux);
vaux[1] = errnv;
errnv = AdvApp2Var_MathBase::mzsnorm_(&nd, vaux);
if (errnu > errnv)
{
if (errnv < *epmscut)
{
*erreur = errnv;
--nv;
}
else
{
goto L2001;
}
}
else
{
if (errnu < *epmscut)
{
*erreur = errnu;
--nu;
}
else
{
goto L2001;
}
}
goto L1001;
/* -------------------------- Return the degrees -------------------
*/
L2001:
*newdgu = std::max(nu, 1);
*newdgv = std::max(nv, 1);
/* ----------------------------------- The end --------------------------
*/
if (ldbg)
{
AdvApp2Var_SysBase::mgsomsg_("MMA2ER2", 7L);
}
return 0;
} /* mma2er2_ */
//=================================================================================================
int AdvApp2Var_ApproxF2var::mma2fnc_(int* ndimen,
int* nbsesp,
int* ndimse,
double* uvfonc,
const AdvApp2Var_EvaluatorFunc2Var& foncnp,
double* tconst,
int* isofav,
int* nbroot,
double* rootlg,
int* iordre,
int* ideriv,
int* ndgjac,
int* nbcrmx,
int* ncflim,
double* epsapr,
int* ncoeff,
double* courbe,
int* nbcrbe,
double* somtab,
double* diftab,
double* contr1,
double* contr2,
double* tabdec,
double* errmax,
double* errmoy,
int* iercod)
{
int c__8 = 8;
/* System generated locals */
int courbe_dim1, courbe_dim2, courbe_offset, somtab_dim1, somtab_dim2, somtab_offset, diftab_dim1,
diftab_dim2, diftab_offset, contr1_dim1, contr1_dim2, contr1_offset, contr2_dim1, contr2_dim2,
contr2_offset, errmax_dim1, errmax_offset, errmoy_dim1, errmoy_offset, i__1;
double d__1;
/* Local variables */
int ideb;
double tmil;
int ideb1, ibid1, ibid2, ncfja, ndgre, ilong, ndwrk;
double* wrkar = nullptr;
double* wrkar_off;
int nupil;
intptr_t iofwr;
double uvpav[4] /* was [2][2] */;
int nd, ii;
int ibb;
int ier = 0;
double uv11[4] /* was [2][2] */;
int ncb1;
double eps3;
int isz1, isz2, isz3, isz4, isz5;
intptr_t ipt1, ipt2, ipt3, ipt4, iptt, jptt;
/* **********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* Approximation of a limit of non polynomial function F(u,v) */
/* (in the space of dimension NDIMEN) by SEVERAL */
/* polynomial curves, by the method of least squares. The parameter of the function is preserved.
*/
/* KEYWORDS : */
/* ----------- */
/* TOUS, AB_SPECIFI :: FONCTION&,EXTREMITE&, APPROXIMATION, &COURBE. */
/* INPUT ARGUMENTS : */
/* ----------------- */
/* NDIMEN: Total Dimension of the space (sum of dimensions */
/* of sub-spaces) */
/* NBSESP: Number of "independent" sub-spaces. */
/* NDIMSE: Table of dimensions of sub-spaces. */
/* UVFONC: Limits of the interval (a,b)x(c,d) of definition of the */
/* function to be approached by U (UVFONC(*,1) contains (a,b)) */
/* and by V (UVFONC(*,2) contains (c,d)). */
/* FONCNP: External function of position on the non polynomial function to be approached. */
/* TCONST: Value of isoparameter of F(u,v) to be discretized. */
/* ISOFAV: Type of chosen iso, = 1, shose that discretization is with u */
/* fixed; = 2, shows that v is fixed. */
/* NBROOT: Nb of points of discretisation of the iso, extremities not included. */
/* ROOTLG: Table of roots of the polynom of Legendre defined on */
/* (-1,1), of degree NBROOT. */
/* IORDRE: Order of constraint at the extremities of the limit */
/* -1 = no constraints, */
/* 0 = constraints of passage to limits (i.e. C0), */
/* 1 = C0 + constraints of 1st derivatives (i.e. C1), */
/* 2 = C1 + constraints of 2nd derivatives (i.e. C2). */
/* IDERIV: Order of derivative of the limit. */
/* NDGJAC: Degree of serial development to be used for calculation in */
/* the Jacobi base. */
/* NBCRMX: Max Nb of curves to be created. */
/* NCFLIM: Max Nb of coeff of the polynomial curve */
/* of approximation (should be above or equal to */
/* 2*IORDRE+2 and below or equal to 50). */
/* EPSAPR: Table of required errors of approximation */
/* sub-space by sub-space. */
/* OUTPUT ARGUMENTS : */
/* ------------------- */
/* NCOEFF: Number of significative coeff of calculated curves. */
/* COURBE: Table of coeff. of calculated polynomial curves. */
/* Should be dimensioned in (NCFLIM,NDIMEN,NBCRMX). */
/* These curves are ALWAYS parametrized in (-1,1). */
/* NBCRBE: Nb of calculated curves. */
/* SOMTAB: For F defined on (-1,1) (otherwise rescale the */
/* parameters), this is the table of sums F(u,vj) + F(u,-vj)
*/
/* if ISOFAV = 1 (and IDERIV=0, otherwise the derivatives */
/* by u of order IDERIV are taken) or sumes F(ui,v) + F(-ui,v) if */
/* ISOFAV = 2 (and IDERIV=0, otherwise the derivatives by */
/* v of order IDERIV are taken). */
/* DIFTAB: For F defined on (-1,1) (otherwise rescale the */
/* parameters), this is the table of sums F(u,vj) - F(u,-vj)
*/
/* if ISOFAV = 1 (and IDERIV=0, otherwise the derivatives */
/* by u of order IDERIV are taken) or sumes F(ui,v) + F(-ui,v) if */
/* ISOFAV = 2 (and IDERIV=0, otherwise the derivatives by */
/* v of order IDERIV are taken). */
/* CONTR1: Contains the coordinates of the left extremity of the iso */
/* and of its derivatives till order IORDRE */
/* CONTR2: Contains the coordinates of the right extremity of the iso */
/* and of its derivatives till order IORDRE */
/* TABDEC: Table of NBCRBE+1 parameters of cut of UVFONC(1:2,1)
*/
/* if ISOFAV=2, or of UVFONC(1:2,2) if ISOFAV=1. */
/* ERRMAX: Table of MAX errors (sub-space by sub-space) */
/* committed in the approximation of FONCNP by NBCRBE curves. */
/* ERRMOY: Table of AVERAGE errors (sub-space by sub-space) */
/* committed in the approximation of FONCNP by NBCRBE curves. */
/* IERCOD: Error code: */
/* -1 = ERRMAX > EPSAPR for at least one sub-space. */
/* (the resulting curves of at least mathematic degree NCFLIM-1 */
/* are calculated). */
/* 0 = Everything is ok. */
/* 1 = Pb of incoherence of inputs. */
/* 10 = Pb of calculation of the interpolation of constraints. */
/* 13 = Pb in the dynamic allocation. */
/* 33 = Pb in the data retrieval from block data */
/* of coeff. of integration by GAUSS method. */
/* >100 Pb in the evaluation of FONCNP, the returned error code */
/* is equal to the error code of FONCNP + 100. */
/* COMMONS USED : */
/* ---------------- */
/* REFERENCES CALLED : */
/* ----------------------- */
/* DESCRIPTION/NOTES/LIMITATIONS : */
/* ----------------------------------- */
/* --> The approximation part is done in the space of dimension */
/* NDIMEN (the sum of dimensions of sub-spaces). For example : */
/* If NBSESP=2 and NDIMSE(1)=3, NDIMSE(2)=2, there is smoothing with */
/* NDIMEN=5. The result (in COURBE(NDIMEN,NCOEFF,i) ), will be */
/* composed of the result of smoothing of 3D function in */
/* COURBE(1:3,1:NCOEFF,i) and of smoothing of 2D function in */
/* COURBE(4:5,1:NCOEFF,i). */
/* --> Routine FONCNP should be declared EXTERNAL in the program */
/* calling MMA2FNC. */
/* --> Function FONCNP, declared externally, should be declared */
/* IMPERATIVELY in form : */
/* SUBROUTINE FONCNP(NDIMEN,UINTFN,VINTFN,IIUOUV,TCONST,NBPTAB */
/* ,TTABLE,IDERIU,IDERIV,IERCOD) */
/* where the input arguments are : */
/* - NDIMEN is int defined as the sum of dimensions of */
/* sub-spaces (i.e. total dimension of the problem). */
/* - UINTFN(2) is a table of 2 reals containing the interval */
/* by u where the function to be approximated is defined */
/* (so it is equal to UIFONC). */
/* - VINTFN(2) is a table of 2 reals containing the interval */
/* by v where the function to be approximated is defined */
/* (so it is equal to VIFONC). */
/* - IIUOUV, shows that the points to be calculated have a constant U */
/* (IIUOUV=1) or a constant V (IIUOUV=2). */
/* - TCONST, float, value of the fixed discretisation parameter. Takes values */
/* in (UINTFN(1),UINTFN(2)) if IIUOUV=1, */
/* or in (VINTFN(1),VINTFN(2)) if IIUOUV=2. */
/* - NBPTAB, the nb of point of discretisation following the free variable */
/* : V if IIUOUV=1 or U if IIUOUV = 2. */
/* - TTABLE, Table of NBPTAB parametres of discretisation. . */
/* - IDERIU, int, takes values between 0 (position) */
/* and IORDREU (partial derivative of the function by u */
/* of order IORDREU if IORDREU > 0). */
/* - IDERIV, int, takes values between 0 (position) */
/* and IORDREV (partial derivative of the function by v */
/* of order IORDREV if IORDREV > 0). */
/* and the output arguments are : */
/* - FPNTAB(NDIMEN,NBPTAB) contains, at output, the table of */
/* NBPTAB points calculated in FONCNP. */
/* - IERCOD is, at output the error code of FONCNP. This code */
/* (int) should be strictly positive if there is a problem. */
/* The input arguments SHOULD NOT BE modified under FONCNP.
*/
/* --> If IERCOD=-1, the required precision can't be reached (ERRMAX */
/* is above EPSAPR on at least one sub-space), but
*/
/* one gives the best possible result for NCFLIM and EPSAPR */
/* chosen by the user. In this case (and for IERCOD=0), there is a solution. */
/* > */
/* **********************************************************************
*/
/* Name of the routine */
/* Parameter adjustments */
--epsapr;
--ndimse;
uvfonc -= 3;
--rootlg;
errmoy_dim1 = *nbsesp;
errmoy_offset = errmoy_dim1 + 1;
errmoy -= errmoy_offset;
errmax_dim1 = *nbsesp;
errmax_offset = errmax_dim1 + 1;
errmax -= errmax_offset;
contr2_dim1 = *ndimen;
contr2_dim2 = *iordre + 2;
contr2_offset = contr2_dim1 * (contr2_dim2 + 1) + 1;
contr2 -= contr2_offset;
contr1_dim1 = *ndimen;
contr1_dim2 = *iordre + 2;
contr1_offset = contr1_dim1 * (contr1_dim2 + 1) + 1;
contr1 -= contr1_offset;
diftab_dim1 = *nbroot / 2 + 1;
diftab_dim2 = *ndimen;
diftab_offset = diftab_dim1 * (diftab_dim2 + 1);
diftab -= diftab_offset;
somtab_dim1 = *nbroot / 2 + 1;
somtab_dim2 = *ndimen;
somtab_offset = somtab_dim1 * (somtab_dim2 + 1);
somtab -= somtab_offset;
--ncoeff;
courbe_dim1 = *ncflim;
courbe_dim2 = *ndimen;
courbe_offset = courbe_dim1 * (courbe_dim2 + 1) + 1;
courbe -= courbe_offset;
AdvApp2Var_SysBase anAdvApp2Var_SysBase;
/* Function Body */
ibb = AdvApp2Var_SysBase::mnfndeb_();
if (ibb >= 1)
{
AdvApp2Var_SysBase::mgenmsg_("MMA2FNC", 7L);
}
*iercod = 0;
iofwr = 0;
/* ---------------- Set to zero the coefficients of CURVE --------------
*/
ilong = *ndimen * *ncflim * *nbcrmx;
AdvApp2Var_SysBase::mvriraz_(&ilong, &courbe[courbe_offset]);
/* **********************************************************************
*/
/* -------------------------- Checking of entries ------------------
*/
/* **********************************************************************
*/
AdvApp2Var_MathBase::mmveps3_(&eps3);
if ((d__1 = uvfonc[4] - uvfonc[3], std::abs(d__1)) < eps3)
{
goto L9100;
}
if ((d__1 = uvfonc[6] - uvfonc[5], std::abs(d__1)) < eps3)
{
goto L9100;
}
uv11[0] = -1.;
uv11[1] = 1.;
uv11[2] = -1.;
uv11[3] = 1.;
/* ********************************************************************** */
/* ------------- Preparation of parameters of discretisation ----------- */
/* **********************************************************************
*/
/* -- Allocation of a table of parameters and points of discretisation -- */
/* --> For the parameters of discretisation. */
isz1 = *nbroot + 2;
/* --> For the points of discretisation in MMA1FDI and MMA1CDI and
*/
/* the auxiliary curve for MMAPCMP */
ibid1 = *ndimen * (*nbroot + 2);
ibid2 = ((*iordre + 1) << 1) * *nbroot;
isz2 = std::max(ibid1, ibid2);
ibid1 = (((*ncflim - 1) / 2 + 1) << 1) * *ndimen;
isz2 = std::max(ibid1, isz2);
/* --> To return the polynoms of hermit. */
isz3 = ((*iordre + 1) << 2) * (*iordre + 1);
/* --> For the Gauss coeff. of integration. */
isz4 = (*nbroot / 2 + 1) * (*ndgjac + 1 - ((*iordre + 1) << 1));
/* --> For the coeff of the curve in the base of Jacobi */
isz5 = (*ndgjac + 1) * *ndimen;
ndwrk = isz1 + isz2 + isz3 + isz4 + isz5;
anAdvApp2Var_SysBase.mcrrqst_(&c__8, &ndwrk, wrkar, &iofwr, &ier);
wrkar_off = reinterpret_cast<double*>(iofwr * sizeof(double));
if (ier > 0)
{
goto L9013;
}
/* --> For the parameters of discretisation (NBROOT+2 extremities). */
/* --> For the points of discretisation FPNTAB(NDIMEN,NBROOT+2), */
/* FPNTAB(NBROOT,2*(IORDRE+1)) and for WRKAR of MMAPCMP. */
ipt1 = isz1;
/* --> For the polynoms of Hermit */
ipt2 = ipt1 + isz2;
/* --> For the Gauss coeff of integration. */
ipt3 = ipt2 + isz3;
/* --> For the curve in Jacobi. */
ipt4 = ipt3 + isz4;
/* ------------------ Initialisation of management of cuts ---------
*/
if (*isofav == 1)
{
uvpav[0] = uvfonc[3];
uvpav[1] = uvfonc[4];
tabdec[0] = uvfonc[5];
tabdec[1] = uvfonc[6];
}
else if (*isofav == 2)
{
tabdec[0] = uvfonc[3];
tabdec[1] = uvfonc[4];
uvpav[2] = uvfonc[5];
uvpav[3] = uvfonc[6];
}
else
{
goto L9100;
}
nupil = 1;
*nbcrbe = 0;
/* **********************************************************************
*/
/* APPROXIMATION WITH CUTS */
/* **********************************************************************
*/
L1000:
/* --> When the top is reached, this is the end ! */
if (nupil - *nbcrbe == 0)
{
goto L9900;
}
ncb1 = *nbcrbe + 1;
if (*isofav == 1)
{
uvpav[2] = tabdec[*nbcrbe];
uvpav[3] = tabdec[*nbcrbe + 1];
}
else if (*isofav == 2)
{
uvpav[0] = tabdec[*nbcrbe];
uvpav[1] = tabdec[*nbcrbe + 1];
}
else
{
goto L9100;
}
/* -------------------- Normalization of parameters -------------------- */
mma1nop_(nbroot, &rootlg[1], uvpav, isofav, wrkar_off, &ier);
if (ier > 0)
{
goto L9100;
}
/* -------------------- Discretisation of FONCNP ------------------------ */
mma1fdi_(ndimen,
uvpav,
foncnp,
isofav,
tconst,
nbroot,
wrkar_off,
iordre,
ideriv,
&wrkar_off[ipt1],
&somtab[(ncb1 * somtab_dim2 + 1) * somtab_dim1],
&diftab[(ncb1 * diftab_dim2 + 1) * diftab_dim1],
&contr1[(ncb1 * contr1_dim2 + 1) * contr1_dim1 + 1],
&contr2[(ncb1 * contr2_dim2 + 1) * contr2_dim1 + 1],
iercod);
if (*iercod > 0)
{
goto L9900;
}
/* -----------Cut the discretisation of constraints ------------*/
if (*iordre >= 0)
{
mma1cdi_(ndimen,
nbroot,
&rootlg[1],
iordre,
&contr1[(ncb1 * contr1_dim2 + 1) * contr1_dim1 + 1],
&contr2[(ncb1 * contr2_dim2 + 1) * contr2_dim1 + 1],
&somtab[(ncb1 * somtab_dim2 + 1) * somtab_dim1],
&diftab[(ncb1 * diftab_dim2 + 1) * diftab_dim1],
&wrkar_off[ipt1],
&wrkar_off[ipt2],
&ier);
if (ier > 0)
{
goto L9100;
}
}
/* **********************************************************************
*/
/* -------------------- Calculate the curve of approximation -------------
*/
/* **********************************************************************
*/
mma1jak_(ndimen,
nbroot,
iordre,
ndgjac,
&somtab[(ncb1 * somtab_dim2 + 1) * somtab_dim1],
&diftab[(ncb1 * diftab_dim2 + 1) * diftab_dim1],
&wrkar_off[ipt3],
&wrkar_off[ipt4],
&ier);
if (ier > 0)
{
goto L9100;
}
/* **********************************************************************
*/
/* ---------------- Add polynom of interpolation -------------------
*/
/* **********************************************************************
*/
if (*iordre >= 0)
{
mma1cnt_(ndimen,
iordre,
&contr1[(ncb1 * contr1_dim2 + 1) * contr1_dim1 + 1],
&contr2[(ncb1 * contr2_dim2 + 1) * contr2_dim1 + 1],
&wrkar_off[ipt2],
ndgjac,
&wrkar_off[ipt4]);
}
/* **********************************************************************
*/
/* --------------- Calculate Max and Average error ----------------------
*/
/* **********************************************************************
*/
mma1fer_(ndimen,
nbsesp,
&ndimse[1],
iordre,
ndgjac,
&wrkar_off[ipt4],
ncflim,
&epsapr[1],
&wrkar_off[ipt1],
&errmax[ncb1 * errmax_dim1 + 1],
&errmoy[ncb1 * errmoy_dim1 + 1],
&ncoeff[ncb1],
&ier);
if (ier > 0)
{
goto L9100;
}
if (ier == 0 || (ier == -1 && nupil == *nbcrmx))
{
/* ******************************************************************
**** */
/* ----------------------- Result compression ------------------
---- */
/* ******************************************************************
**** */
if (ier == -1)
{
*iercod = -1;
}
ncfja = *ndgjac + 1;
/* -> Compression of result in WRKAR(IPT2) */
/*pkv f*/
/*
AdvApp2Var_MathBase::mmapcmp_(ndimen,
&ncfja, &ncoeff[ncb1], &wrkar[ipt5], &wrkar[ipt2]);
*/
AdvApp2Var_MathBase::mmapcmp_((int*)ndimen,
&ncfja,
&ncoeff[ncb1],
&wrkar_off[ipt4],
&wrkar_off[ipt1]);
/*pkv t*/
ilong = *ndimen * *ncflim;
AdvApp2Var_SysBase::mvriraz_(&ilong, &wrkar_off[ipt4]);
/* -> Passage to canonic base (-1,1) (result in WRKAR(IPT5)).
*/
ndgre = ncoeff[ncb1] - 1;
i__1 = *ndimen;
for (nd = 1; nd <= i__1; ++nd)
{
iptt = ipt1 + ((nd - 1) << 1) * (ndgre / 2 + 1);
jptt = ipt4 + (nd - 1) * ncoeff[ncb1];
AdvApp2Var_MathBase::mmjacan_(iordre, &ndgre, &wrkar_off[iptt], &wrkar_off[jptt]);
/* L400: */
}
/* -> Store the calculated curve */
ibid1 = 1;
AdvApp2Var_MathBase::mmfmca8_(&ncoeff[ncb1],
ndimen,
&ibid1,
ncflim,
ndimen,
&ibid1,
&wrkar_off[ipt4],
&courbe[(ncb1 * courbe_dim2 + 1) * courbe_dim1 + 1]);
/* -> Before normalization of constraints on (-1,1), recalculate */
/* the true constraints. */
i__1 = *iordre;
for (ii = 0; ii <= i__1; ++ii)
{
mma1noc_(uv11,
ndimen,
&ii,
&contr1[(ii + 1 + ncb1 * contr1_dim2) * contr1_dim1 + 1],
uvpav,
isofav,
ideriv,
&contr1[(ii + 1 + ncb1 * contr1_dim2) * contr1_dim1 + 1]);
mma1noc_(uv11,
ndimen,
&ii,
&contr2[(ii + 1 + ncb1 * contr2_dim2) * contr2_dim1 + 1],
uvpav,
isofav,
ideriv,
&contr2[(ii + 1 + ncb1 * contr2_dim2) * contr2_dim1 + 1]);
/* L200: */
}
ii = 0;
ibid1 = (*nbroot / 2 + 1) * *ndimen;
mma1noc_(uv11,
&ibid1,
&ii,
&somtab[(ncb1 * somtab_dim2 + 1) * somtab_dim1],
uvpav,
isofav,
ideriv,
&somtab[(ncb1 * somtab_dim2 + 1) * somtab_dim1]);
mma1noc_(uv11,
&ibid1,
&ii,
&diftab[(ncb1 * diftab_dim2 + 1) * diftab_dim1],
uvpav,
isofav,
ideriv,
&diftab[(ncb1 * diftab_dim2 + 1) * diftab_dim1]);
ii = 0;
i__1 = *ndimen;
for (nd = 1; nd <= i__1; ++nd)
{
mma1noc_(uv11,
&ncoeff[ncb1],
&ii,
&courbe[(nd + ncb1 * courbe_dim2) * courbe_dim1 + 1],
uvpav,
isofav,
ideriv,
&courbe[(nd + ncb1 * courbe_dim2) * courbe_dim1 + 1]);
/* L210: */
}
/* -> Update the nb of already created curves */
++(*nbcrbe);
/* -> ...otherwise try to cut the current interval in 2... */
}
else
{
tmil = (tabdec[*nbcrbe + 1] + tabdec[*nbcrbe]) / 2.;
ideb = *nbcrbe + 1;
ideb1 = ideb + 1;
ilong = (nupil - *nbcrbe) << 3;
AdvApp2Var_SysBase::mcrfill_(&ilong, &tabdec[ideb], &tabdec[ideb1]);
tabdec[ideb] = tmil;
++nupil;
}
/* ---------- Make approximation of the rest -----------
*/
goto L1000;
/* --------------------- Return code of error -----------------
*/
/* --> Pb with dynamic allocation */
L9013:
*iercod = 13;
goto L9900;
/* --> Inputs incoherent. */
L9100:
*iercod = 1;
goto L9900;
/* -------------------------- Dynamic desallocation -------------------
*/
L9900:
if (iofwr != 0)
{
anAdvApp2Var_SysBase.mcrdelt_(&c__8, &ndwrk, wrkar, &iofwr, &ier);
}
if (ier > 0)
{
*iercod = 13;
}
goto L9999;
/* ------------------------------ The end -------------------------------
*/
L9999:
if (*iercod != 0)
{
AdvApp2Var_SysBase::maermsg_("MMA2FNC", iercod, 7L);
}
if (ibb >= 2)
{
AdvApp2Var_SysBase::mgsomsg_("MMA2FNC", 7L);
}
return 0;
} /* mma2fnc_ */
//=================================================================================================
int AdvApp2Var_ApproxF2var::mma2fx6_(int* ncfmxu,
int* ncfmxv,
int* ndimen,
int* nbsesp,
int* ndimse,
int* nbupat,
int* nbvpat,
int* iordru,
int* iordrv,
double* epsapr,
double* epsfro,
double* patcan,
double* errmax,
int* ncoefu,
int* ncoefv)
{
/* System generated locals */
int epsfro_dim1, epsfro_offset, patcan_dim1, patcan_dim2, patcan_dim3, patcan_dim4, patcan_offset,
errmax_dim1, errmax_dim2, errmax_offset, ncoefu_dim1, ncoefu_offset, ncoefv_dim1, ncoefv_offset,
i__1, i__2, i__3, i__4, i__5;
double d__1, d__2;
/* Local variables */
int idim, ncfu, ncfv, id, ii, nd, jj, ku, kv, ns, ibb;
double bid;
double tol;
/* **********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* Reduction of degree when the squares are the squares of constraints. */
/* KEYWORDS : */
/* ----------- */
/* TOUS,AB_SPECIFI::CARREAU&,REDUCTION,&CARREAU */
/* INPUT ARGUMENTS : */
/* ------------------ */
/* NCFMXU: Max Nb of coeff by u of solution P(u,v) (table */
/* PATCAN). This argument serves only to declare the size of this table. */
/* NCFMXV: Max Nb of coeff by v of solution P(u,v) (table */
/* PATCAN). This argument serves only to declare the size of this table. */
/* NDIMEN: Total dimension of the space where the processed function */
/* takes its values.(sum of dimensions of sub-spaces) */
/* NBSESP: Nb of independent sub-spaces where the errors are measured. */
/* NDIMSE: Table of dimensions of NBSESP sub-spaces. */
/* NBUPAT: Nb of square solution by u. */
/* NBVPAT: Nb of square solution by v. */
/* IORDRU: Order of constraint imposed at the extremities of iso-V */
/* = 0, the extremities of iso-V are calculated */
/* = 1, additionally the 1st derivative in the direction of iso-V is calculated */
/* = 2, additionally the 2nd derivative in the direction of iso-V is calculated */
/* IORDRV: Order of constraint imposed at extremities of iso-U */
/* = 0, the extremities of iso-U are calculated. */
/* = 1, additionally the 1st derivative in the direction of iso-U is calculated */
/* = 2, additionally the 2nd derivative in the direction of iso-U is calculated */
/* EPSAPR: Table of imposed precisions, sub-space by sub-space. */
/* EPSFRO: Table of imposed precisions, sub-space by sub-space on the limits of squares. */
/* PATCAN: Table of coeff. in the canonic base of squares P(u,v) calculated for (u,v) in (-1,1).
*/
/* ERRMAX: Table of MAX errors (sub-space by sub-space) */
/* committed in the approximation of F(u,v) by P(u,v). */
/* NCOEFU: Table of Nb of significative coeffs. by u of calculated squares. */
/* NCOEFV: Table of Nb of significative coeffs. by v of calculated squares. */
/* OUTPUT ARGUMENTS : */
/* ------------------- */
/* NCOEFU: Table of Nb of significative coeffs. by u of calculated squares. */
/* NCOEFV: Table of Nb of significative coeffs. by v of calculated squares. */
/* COMMONS USED : */
/* ---------------- */
/* REFERENCES CALLED : */
/* --------------------- */
/* DESCRIPTION/NOTES/LIMITATIONS : */
/* ------------------------------- */
/* > */
/* **********************************************************************
*/
/* Name of the routine */
/* Parameter adjustments */
epsfro_dim1 = *nbsesp;
epsfro_offset = epsfro_dim1 * 5 + 1;
epsfro -= epsfro_offset;
--epsapr;
--ndimse;
ncoefv_dim1 = *nbupat;
ncoefv_offset = ncoefv_dim1 + 1;
ncoefv -= ncoefv_offset;
ncoefu_dim1 = *nbupat;
ncoefu_offset = ncoefu_dim1 + 1;
ncoefu -= ncoefu_offset;
errmax_dim1 = *nbsesp;
errmax_dim2 = *nbupat;
errmax_offset = errmax_dim1 * (errmax_dim2 + 1) + 1;
errmax -= errmax_offset;
patcan_dim1 = *ncfmxu;
patcan_dim2 = *ncfmxv;
patcan_dim3 = *ndimen;
patcan_dim4 = *nbupat;
patcan_offset = patcan_dim1 * (patcan_dim2 * (patcan_dim3 * (patcan_dim4 + 1) + 1) + 1) + 1;
patcan -= patcan_offset;
/* Function Body */
ibb = AdvApp2Var_SysBase::mnfndeb_();
if (ibb >= 3)
{
AdvApp2Var_SysBase::mgenmsg_("MMA2FX6", 7L);
}
i__1 = *nbvpat;
for (jj = 1; jj <= i__1; ++jj)
{
i__2 = *nbupat;
for (ii = 1; ii <= i__2; ++ii)
{
ncfu = ncoefu[ii + jj * ncoefu_dim1];
ncfv = ncoefv[ii + jj * ncoefv_dim1];
/* ********************************************************************** */
/* -------------------- Reduction of degree by U ------------------------- */
/* ********************************************************************** */
L200:
if (ncfu <= (*iordru + 1) << 1 && ncfu > 2)
{
idim = 0;
i__3 = *nbsesp;
for (ns = 1; ns <= i__3; ++ns)
{
tol = epsapr[ns];
/* Computing MIN */
d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 9];
tol = std::min(d__1, d__2);
/* Computing MIN */
d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 10];
tol = std::min(d__1, d__2);
/* Computing MIN */
d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 11];
tol = std::min(d__1, d__2);
/* Computing MIN */
d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 12];
tol = std::min(d__1, d__2);
if (ii == 1 || ii == *nbupat || jj == 1 || jj == *nbvpat)
{
/* Computing MIN */
d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 5];
tol = std::min(d__1, d__2);
/* Computing MIN */
d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 6];
tol = std::min(d__1, d__2);
/* Computing MIN */
d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 7];
tol = std::min(d__1, d__2);
/* Computing MIN */
d__1 = tol, d__2 = epsfro[ns + (epsfro_dim1 << 3)];
tol = std::min(d__1, d__2);
}
bid = 0.;
i__4 = ndimse[ns];
for (nd = 1; nd <= i__4; ++nd)
{
id = idim + nd;
i__5 = ncfv;
for (kv = 1; kv <= i__5; ++kv)
{
bid +=
(d__1 = patcan[ncfu
+ (kv + (id + (ii + jj * patcan_dim4) * patcan_dim3) * patcan_dim2)
* patcan_dim1],
std::abs(d__1));
/* L230: */
}
/* L220: */
}
if (bid > tol * 1e-6 || bid > errmax[ns + (ii + jj * errmax_dim2) * errmax_dim1])
{
goto L300;
}
idim += ndimse[ns];
/* L210: */
}
--ncfu;
goto L200;
}
/* ********************************************************************** */
/* -------------------- Reduction of degree by V ------------------------- */
/* ********************************************************************** */
L300:
if (ncfv <= (*iordrv + 1) << 1 && ncfv > 2)
{
idim = 0;
i__3 = *nbsesp;
for (ns = 1; ns <= i__3; ++ns)
{
tol = epsapr[ns];
/* Computing MIN */
d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 9];
tol = std::min(d__1, d__2);
/* Computing MIN */
d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 10];
tol = std::min(d__1, d__2);
/* Computing MIN */
d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 11];
tol = std::min(d__1, d__2);
/* Computing MIN */
d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 12];
tol = std::min(d__1, d__2);
if (ii == 1 || ii == *nbupat || jj == 1 || jj == *nbvpat)
{
/* Computing MIN */
d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 5];
tol = std::min(d__1, d__2);
/* Computing MIN */
d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 6];
tol = std::min(d__1, d__2);
/* Computing MIN */
d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 7];
tol = std::min(d__1, d__2);
/* Computing MIN */
d__1 = tol, d__2 = epsfro[ns + (epsfro_dim1 << 3)];
tol = std::min(d__1, d__2);
}
bid = 0.;
i__4 = ndimse[ns];
for (nd = 1; nd <= i__4; ++nd)
{
id = idim + nd;
i__5 = ncfu;
for (ku = 1; ku <= i__5; ++ku)
{
bid +=
(d__1 = patcan[ku
+ (ncfv + (id + (ii + jj * patcan_dim4) * patcan_dim3) * patcan_dim2)
* patcan_dim1],
std::abs(d__1));
/* L330: */
}
/* L320: */
}
if (bid > tol * 1e-6 || bid > errmax[ns + (ii + jj * errmax_dim2) * errmax_dim1])
{
goto L400;
}
idim += ndimse[ns];
/* L310: */
}
--ncfv;
goto L300;
}
/* --- Return the nbs of coeff. and pass to the next square --- */
L400:
ncoefu[ii + jj * ncoefu_dim1] = std::max(ncfu, 2);
ncoefv[ii + jj * ncoefv_dim1] = std::max(ncfv, 2);
/* L110: */
}
/* L100: */
}
/* ------------------------------ The End -------------------------------
*/
if (ibb >= 3)
{
AdvApp2Var_SysBase::mgsomsg_("MMA2FX6", 7L);
}
return 0;
} /* mma2fx6_ */
//=================================================================================================
int AdvApp2Var_ApproxF2var::mma2jmx_(int* ndgjac, int* iordre, double* xjacmx)
{
/* Initialized data */
static double xmax2[57] = {.9682458365518542212948163499456, .986013297183269340427888048593603,
1.07810420343739860362585159028115, 1.17325804490920057010925920756025,
1.26476561266905634732910520370741, 1.35169950227289626684434056681946,
1.43424378958284137759129885012494, 1.51281316274895465689402798226634,
1.5878364329591908800533936587012, 1.65970112228228167018443636171226,
1.72874345388622461848433443013543, 1.7952515611463877544077632304216,
1.85947199025328260370244491818047, 1.92161634324190018916351663207101,
1.98186713586472025397859895825157, 2.04038269834980146276967984252188,
2.09730119173852573441223706382076, 2.15274387655763462685970799663412,
2.20681777186342079455059961912859, 2.25961782459354604684402726624239,
2.31122868752403808176824020121524, 2.36172618435386566570998793688131,
2.41117852396114589446497298177554, 2.45964731268663657873849811095449,
2.50718840313973523778244737914028, 2.55385260994795361951813645784034,
2.59968631659221867834697883938297, 2.64473199258285846332860663371298,
2.68902863641518586789566216064557, 2.73261215675199397407027673053895,
2.77551570192374483822124304745691, 2.8177699459714315371037628127545,
2.85940333797200948896046563785957, 2.90044232019793636101516293333324,
2.94091151970640874812265419871976, 2.98083391718088702956696303389061,
3.02023099621926980436221568258656, 3.05912287574998661724731962377847,
3.09752842783622025614245706196447, 3.13546538278134559341444834866301,
3.17295042316122606504398054547289, 3.2099992681699613513775259670214,
3.24662674946606137764916854570219, 3.28284687953866689817670991319787,
3.31867291347259485044591136879087, 3.35411740487202127264475726990106,
3.38919225660177218727305224515862, 3.42390876691942143189170489271753,
3.45827767149820230182596660024454, 3.49230918177808483937957161007792,
3.5260130200285724149540352829756, 3.55939845146044235497103883695448,
3.59247431368364585025958062194665, 3.62524904377393592090180712976368,
3.65773070318071087226169680450936, 3.68992700068237648299565823810245,
3.72184531357268220291630708234186};
static double xmax4[55] = {1.1092649593311780079813740546678, 1.05299572648705464724876659688996,
1.0949715351434178709281698645813, 1.15078388379719068145021100764647,
1.2094863084718701596278219811869, 1.26806623151369531323304177532868,
1.32549784426476978866302826176202, 1.38142537365039019558329304432581,
1.43575531950773585146867625840552, 1.48850442653629641402403231015299,
1.53973611681876234549146350844736, 1.58953193485272191557448229046492,
1.63797820416306624705258190017418, 1.68515974143594899185621942934906,
1.73115699602477936547107755854868, 1.77604489805513552087086912113251,
1.81989256661534438347398400420601, 1.86276344480103110090865609776681,
1.90471563564740808542244678597105, 1.94580231994751044968731427898046,
1.98607219357764450634552790950067, 2.02556989246317857340333585562678,
2.06433638992049685189059517340452, 2.10240936014742726236706004607473,
2.13982350649113222745523925190532, 2.17661085564771614285379929798896,
2.21280102016879766322589373557048, 2.2484214321456956597803794333791,
2.28349755104077956674135810027654, 2.31805304852593774867640120860446,
2.35210997297725685169643559615022, 2.38568889602346315560143377261814,
2.41880904328694215730192284109322, 2.45148841120796359750021227795539,
2.48374387161372199992570528025315, 2.5155912654873773953959098501893,
2.54704548720896557684101746505398, 2.57812056037881628390134077704127,
2.60882970619319538196517982945269, 2.63918540521920497868347679257107,
2.66919945330942891495458446613851, 2.69888301230439621709803756505788,
2.72824665609081486737132853370048, 2.75730041251405791603760003778285,
2.78605380158311346185098508516203, 2.81451587035387403267676338931454,
2.84269522483114290814009184272637, 2.87060005919012917988363332454033,
2.89823818258367657739520912946934, 2.92561704377132528239806135133273,
2.95274375377994262301217318010209, 2.97962510678256471794289060402033,
3.00626759936182712291041810228171, 3.03267744830655121818899164295959,
3.05886060707437081434964933864149};
static double xmax6[53] = {1.21091229812484768570102219548814, 1.11626917091567929907256116528817,
1.1327140810290884106278510474203, 1.1679452722668028753522098022171,
1.20910611986279066645602153641334, 1.25228283758701572089625983127043,
1.29591971597287895911380446311508, 1.3393138157481884258308028584917,
1.3821288728999671920677617491385, 1.42420414683357356104823573391816,
1.46546895108549501306970087318319, 1.50590085198398789708599726315869,
1.54550385142820987194251585145013, 1.58429644271680300005206185490937,
1.62230484071440103826322971668038, 1.65955905239130512405565733793667,
1.69609056468292429853775667485212, 1.73193098017228915881592458573809,
1.7671112206990325429863426635397, 1.80166107681586964987277458875667,
1.83560897003644959204940535551721, 1.86898184653271388435058371983316,
1.90180515174518670797686768515502, 1.93410285411785808749237200054739,
1.96589749778987993293150856865539, 1.99721027139062501070081653790635,
2.02806108474738744005306947877164, 2.05846864831762572089033752595401,
2.08845055210580131460156962214748, 2.11802334209486194329576724042253,
2.14720259305166593214642386780469, 2.17600297710595096918495785742803,
2.20443832785205516555772788192013, 2.2325216999457379530416998244706,
2.2602654243075083168599953074345, 2.28768115912702794202525264301585,
2.3147799369092684021274946755348, 2.34157220782483457076721300512406,
2.36806787963276257263034969490066, 2.39427635443992520016789041085844,
2.42020656255081863955040620243062, 2.44586699364757383088888037359254,
2.47126572552427660024678584642791, 2.49641045058324178349347438430311,
2.52130850028451113942299097584818, 2.54596686772399937214920135190177,
2.5703922285006754089328998222275, 2.59459096001908861492582631591134,
2.61856915936049852435394597597773, 2.64233265984385295286445444361827,
2.66588704638685848486056711408168, 2.68923766976735295746679957665724,
2.71238965987606292679677228666411};
/* System generated locals */
int i__1;
/* Local variables */
long ldbg;
int numax, ii;
double bid;
/* **********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* Calculate the max of Jacobo polynoms multiplied by the weight on */
/* (-1,1) for order 0,4,6 or Legendre. */
/* KEYWORDSS : */
/* ----------- */
/* LEGENDRE,APPROXIMATION,ERREUR. */
/* INPUT ARGUMENTS : */
/* ------------------ */
/* NDGJAC: Nb of Jacobi coeff. of approximation. */
/* IORDRE: Order of continuity (from -1 to 2) */
/* OUTPUT ARGUMENTS : */
/* ------------------- */
/* XJACMX: Table of maximums of Jacobi polynoms. */
/* COMMONS USED : */
/* ---------------- */
/* REFERENCES CALLED : */
/* --------------------- */
/* DESCRIPTION/NOTES/LIMITATIONS : */
/* ----------------------------------- */
/* > */
/* ***********************************************************************
*/
/* Name of the routine */
/* ----------------------------- Initialisations ------------------------
*/
ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
if (ldbg)
{
AdvApp2Var_SysBase::mgenmsg_("MMA2JMX", 7L);
}
numax = *ndgjac - ((*iordre + 1) << 1);
if (*iordre == -1)
{
i__1 = numax;
for (ii = 0; ii <= i__1; ++ii)
{
bid = (ii * 2. + 1.) / 2.;
xjacmx[ii] = sqrt(bid);
/* L100: */
}
}
else if (*iordre == 0)
{
i__1 = numax;
for (ii = 0; ii <= i__1; ++ii)
{
xjacmx[ii] = xmax2[ii];
/* L200: */
}
}
else if (*iordre == 1)
{
i__1 = numax;
for (ii = 0; ii <= i__1; ++ii)
{
xjacmx[ii] = xmax4[ii];
/* L400: */
}
}
else if (*iordre == 2)
{
i__1 = numax;
for (ii = 0; ii <= i__1; ++ii)
{
xjacmx[ii] = xmax6[ii];
/* L600: */
}
}
/* ------------------------- The end ------------------------------------
*/
if (ldbg)
{
AdvApp2Var_SysBase::mgsomsg_("MMA2JMX", 7L);
}
return 0;
} /* mma2jmx_ */
//=================================================================================================
int mma2moy_(int* ndgumx,
int* ndgvmx,
int* ndimen,
int* mindgu,
int* maxdgu,
int* mindgv,
int* maxdgv,
int* iordru,
int* iordrv,
double* patjac,
double* errmoy)
{
/* System generated locals */
int patjac_dim1, patjac_dim2, patjac_offset, i__1, i__2, i__3;
/* Local variables */
long ldbg;
int minu, minv, idebu, idebv, ii, nd, jj;
double bid0, bid1;
/* **********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* Calculate the average approximation error made when only */
/* the coefficients of PATJAC of degree between */
/* 2*(IORDRU+1) and MINDGU by U and 2*(IORDRV+1) and MINDGV by V are preserved. */
/* KEYWORDS : */
/* ----------- */
/* LEGENDRE,APPROXIMATION, AVERAGE ERROR */
/* INPUT ARGUMENTS : */
/* ------------------ */
/* NDGUMX: Dimension by U of table PATJAC. */
/* NDGVMX: Dimension by V of table PATJAC. */
/* NDIMEN: Dimension of the space. */
/* MINDGU: Lower limit of the index by U of PATJAC coeff to be taken into account. */
/* MAXDGU: Upper limit of the index by U of PATJAC coeff to be taken into account. */
/* MINDGV: Lower limit of the index by V of PATJAC coeff to be taken into account. */
/* MAXDGV: Upper limit of the index by V of PATJAC coeff to be taken into account. */
/* IORDRU: Order of continuity by U provided by square PATJAC (from -1 to 2) */
/* IORDRV: Order of continuity by V provided by square PATJAC (from -1 to 2) */
/* PATJAC: Table of coeff. of the approximation square with */
/* constraints of order IORDRU by U and IORDRV by V. */
/* OUTPUT ARGUMENTS : */
/* ------------------- */
/* ERRMOY: Average error committed by preserving only the coeff of */
/* PATJAC 2*(IORDRU+1) in MINDGU by U and 2*(IORDRV+1) in MINDGV by V. */
/* COMMONS USED : */
/* ---------------- */
/* REFERENCES CALLED : */
/* --------------------- */
/* DESCRIPTION/NOTES/LIMITATIONS : */
/* ----------------------------------- */
/* Table PATJAC stores the coeff. Cij of */
/* approximation square F(U,V). Indexes i and j show the degree by */
/* U and by V of the base polynoms. These base polynoms are in the form: */
/* ((1 - U*U)**(IORDRU+1)).J(i-2*(IORDRU+1)(U), where */
/* polynom J(i-2*(IORDU+1)(U) is the Jacobi polynom of order */
/* IORDRU+1 (the same by V by replacing U by V in the above expression). */
/* The contribution to the average error of term Cij when */
/* it is removed from PATJAC is Cij*Cij. */
/* > */
/* ***********************************************************************
*/
/* Name of the routine */
/* ----------------------------- Initialisations ------------------------
*/
/* Parameter adjustments */
patjac_dim1 = *ndgumx + 1;
patjac_dim2 = *ndgvmx + 1;
patjac_offset = patjac_dim1 * patjac_dim2;
patjac -= patjac_offset;
/* Function Body */
ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
if (ldbg)
{
AdvApp2Var_SysBase::mgenmsg_("MMA2MOY", 7L);
}
idebu = (*iordru + 1) << 1;
idebv = (*iordrv + 1) << 1;
minu = std::max(idebu, *mindgu);
minv = std::max(idebv, *mindgv);
bid0 = 0.;
*errmoy = 0.;
/* ------------------ Calculation of the upper bound of the average error ------------ */
/* -------------------- when the coeff. of indexes from MINDGU to MAXDGU ------ */
/* ---------------- by U and of indexes from MINDGV to MAXDGV by V are removed -------------- */
i__1 = *ndimen;
for (nd = 1; nd <= i__1; ++nd)
{
i__2 = *maxdgv;
for (jj = minv; jj <= i__2; ++jj)
{
i__3 = *maxdgu;
for (ii = idebu; ii <= i__3; ++ii)
{
bid1 = patjac[ii + (jj + nd * patjac_dim2) * patjac_dim1];
bid0 += bid1 * bid1;
/* L300: */
}
/* L200: */
}
/* L100: */
}
i__1 = *ndimen;
for (nd = 1; nd <= i__1; ++nd)
{
i__2 = minv - 1;
for (jj = idebv; jj <= i__2; ++jj)
{
i__3 = *maxdgu;
for (ii = minu; ii <= i__3; ++ii)
{
bid1 = patjac[ii + (jj + nd * patjac_dim2) * patjac_dim1];
bid0 += bid1 * bid1;
/* L600: */
}
/* L500: */
}
/* L400: */
}
/* ----------------------- Calculation of the average error -------------
*/
bid0 /= 4;
*errmoy = sqrt(bid0);
/* ------------------------- The end ------------------------------------
*/
if (ldbg)
{
AdvApp2Var_SysBase::mgsomsg_("MMA2MOY", 7L);
}
return 0;
} /* mma2moy_ */
//=================================================================================================
int AdvApp2Var_ApproxF2var::mma2roo_(int* nbpntu, int* nbpntv, double* urootl, double* vrootl)
{
/* System generated locals */
int i__1;
/* Local variables */
int ii, ibb;
/* **********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* Return roots of Legendre for discretisations. */
/* KEYWORDS : */
/* ----------- */
/* TOUS, AB_SPECIFI::CONTRAINTE&, DISCRETISATION, &POINT */
/* INPUT ARGUMENTS : */
/* ------------------ */
/* NBPNTU: Nb of INTERNAL parameters of discretization BY U. */
/* This is also the nb of root of the Legendre polynom where the discretization is
* done. */
/* NBPNTV: Nb of INTERNAL parameters of discretization BY V. */
/* This is also the nb of root of the Legendre polynom where the discretization is
* done. */
/* OUTPUT ARGUMENTS : */
/* ------------------- */
/* UROOTL: Table of parameters of discretisation ON (-1,1) BY U.
*/
/* VROOTL: Table of parameters of discretisation ON (-1,1) BY V.
*/
/* COMMONS USED : */
/* ---------------- */
/* REFERENCES CALLED : */
/* --------------------- */
/* DESCRIPTION/NOTES/LIMITATIONS : */
/* ----------------------------------- */
/* > */
/* **********************************************************************
*/
/* Name of the routine */
/* Parameter adjustments */
--urootl;
--vrootl;
/* Function Body */
ibb = AdvApp2Var_SysBase::mnfndeb_();
if (ibb >= 3)
{
AdvApp2Var_SysBase::mgenmsg_("MMA2ROO", 7L);
}
/* ---------------- Return the POSITIVE roots on U ------------------
*/
AdvApp2Var_MathBase::mmrtptt_(nbpntu, &urootl[(*nbpntu + 1) / 2 + 1]);
i__1 = *nbpntu / 2;
for (ii = 1; ii <= i__1; ++ii)
{
urootl[ii] = -urootl[*nbpntu - ii + 1];
/* L100: */
}
if (*nbpntu % 2 == 1)
{
urootl[*nbpntu / 2 + 1] = 0.;
}
/* ---------------- Return the POSITIVE roots on V ------------------
*/
AdvApp2Var_MathBase::mmrtptt_(nbpntv, &vrootl[(*nbpntv + 1) / 2 + 1]);
i__1 = *nbpntv / 2;
for (ii = 1; ii <= i__1; ++ii)
{
vrootl[ii] = -vrootl[*nbpntv - ii + 1];
/* L110: */
}
if (*nbpntv % 2 == 1)
{
vrootl[*nbpntv / 2 + 1] = 0.;
}
/* ------------------------------ The End -------------------------------
*/
if (ibb >= 3)
{
AdvApp2Var_SysBase::mgsomsg_("MMA2ROO", 7L);
}
return 0;
} /* mma2roo_ */
//=================================================================================================
int mmmapcoe_(int* ndim,
int* ndgjac,
int* iordre,
int* nbpnts,
double* somtab,
double* diftab,
double* gsstab,
double* crvjac)
{
/* System generated locals */
int somtab_dim1, somtab_offset, diftab_dim1, diftab_offset, crvjac_dim1, crvjac_offset,
gsstab_dim1, i__1, i__2, i__3;
/* Local variables */
int igss, ikdeb;
double bidon;
int nd, ik, ir, nbroot, ibb;
/* **********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* Calculate the coefficients of polynomial approximation curve */
/* of degree NDGJAC by the method of smallest squares starting from */
/* the discretization of function on the roots of Legendre polynom */
/* of degree NBPNTS. */
/* KEYWORDS : */
/* ----------- */
/* FONCTION,APPROXIMATION,COEFFICIENT,POLYNOME */
/* INPUT ARGUMENTS : */
/* ------------------ */
/* NDIM : Dimension of the space. */
/* NDGJAC : Max Degree of the polynom of approximation. */
/* The representation in the orthogonal base starts from degree */
/* 0 to degree NDGJAC-2*(JORDRE+1). The polynomial base */
/* is the base of Jacobi of order -1 (Legendre), 0, 1 and 2 */
/* IORDRE : Order of the base of Jacobi (-1,0,1 or 2). Corresponds */
/* to step of constraints, C0,C1 or C2. */
/* NBPNTS : Degree of the polynom of Legendre on the roots which of */
/* are calculated the coefficients of integration by */
/* Gauss method. It is required to set NBPNTS=30,40,50 or 61 */
/* and NDGJAC < NBPNTS. */
/* SOMTAB : Table of F(ti)+F(-ti) with ti in ROOTAB. */
/* DIFTAB : Table of F(ti)-F(-ti) with ti in ROOTAB. */
/* GSSTAB(i,k) : Table of coefficients of integration by the Gauss method : */
/* i varies from 0 to NBPNTS and */
/* k varies from 0 to NDGJAC-2*(JORDRE+1). */
/* OUTPUT ARGUMENTSE : */
/* ------------------- */
/* CRVJAC : Curve of approximation of FONCNP with eventually */
/* taking into account of constraints at the extremities. */
/* This curve is of degree NDGJAC. */
/* COMMONS USED : */
/* ---------------- */
/* REFERENCES CALLED : */
/* --------------------- */
/* DESCRIPTION/NOTES/LIMITATIONS : */
/* ------------------------------- */
/* > */
/* **********************************************************************
*/
/* Name of the routine */
/* Parameter adjustments */
crvjac_dim1 = *ndgjac + 1;
crvjac_offset = crvjac_dim1;
crvjac -= crvjac_offset;
gsstab_dim1 = *nbpnts / 2 + 1;
diftab_dim1 = *nbpnts / 2 + 1;
diftab_offset = diftab_dim1;
diftab -= diftab_offset;
somtab_dim1 = *nbpnts / 2 + 1;
somtab_offset = somtab_dim1;
somtab -= somtab_offset;
/* Function Body */
ibb = AdvApp2Var_SysBase::mnfndeb_();
if (ibb >= 2)
{
AdvApp2Var_SysBase::mgenmsg_("MMMAPCO", 7L);
}
ikdeb = (*iordre + 1) << 1;
nbroot = *nbpnts / 2;
i__1 = *ndim;
for (nd = 1; nd <= i__1; ++nd)
{
/* ----------------- Calculate the coefficients of even degree ----------
---- */
i__2 = *ndgjac;
for (ik = ikdeb; ik <= i__2; ik += 2)
{
igss = ik - ikdeb;
bidon = 0.;
i__3 = nbroot;
for (ir = 1; ir <= i__3; ++ir)
{
bidon += somtab[ir + nd * somtab_dim1] * gsstab[ir + igss * gsstab_dim1];
/* L300: */
}
crvjac[ik + nd * crvjac_dim1] = bidon;
/* L200: */
}
/* --------------- Calculate the coefficients of uneven degree ----------
---- */
i__2 = *ndgjac;
for (ik = ikdeb + 1; ik <= i__2; ik += 2)
{
igss = ik - ikdeb;
bidon = 0.;
i__3 = nbroot;
for (ir = 1; ir <= i__3; ++ir)
{
bidon += diftab[ir + nd * diftab_dim1] * gsstab[ir + igss * gsstab_dim1];
/* L500: */
}
crvjac[ik + nd * crvjac_dim1] = bidon;
/* L400: */
}
/* L100: */
}
/* ------- Add terms connected to the supplementary root (0.D0) ------ */
/* ----------- of Legendre polynom of uneven degree NBPNTS -----------
*/
if (*nbpnts % 2 == 0)
{
goto L9999;
}
i__1 = *ndim;
for (nd = 1; nd <= i__1; ++nd)
{
i__2 = *ndgjac;
for (ik = ikdeb; ik <= i__2; ik += 2)
{
igss = ik - ikdeb;
crvjac[ik + nd * crvjac_dim1] += somtab[nd * somtab_dim1] * gsstab[igss * gsstab_dim1];
/* L700: */
}
/* L600: */
}
/* ------------------------------ The end -------------------------------
*/
L9999:
if (ibb >= 2)
{
AdvApp2Var_SysBase::mgsomsg_("MMMAPCO", 7L);
}
return 0;
} /* mmmapcoe_ */
//=================================================================================================
int mmaperm_(int* ncofmx,
int* ndim,
int* ncoeff,
int* iordre,
double* crvjac,
int* ncfnew,
double* errmoy)
{
/* System generated locals */
int crvjac_dim1, crvjac_offset, i__1, i__2;
/* Local variables */
double bidj;
int i__, ia, nd, ncfcut, ibb;
double bid;
/* **********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* Calculate the square root of the average quadratic error */
/* of approximation done when only the */
/* first NCFNEW coefficients of a curve of degree NCOEFF-1 */
/* written in NORMALIZED Jacobi base of order 2*(IORDRE+1) are preserved. */
/* KEYWORDS : */
/* ----------- */
/* LEGENDRE,POLYGONE,APPROXIMATION,ERREUR. */
/* INPUT ARGUMENTS : */
/* ------------------ */
/* NCOFMX : Maximum degree of the curve. */
/* NDIM : Dimension of the space. */
/* NCOEFF : Degree +1 of the curve. */
/* IORDRE : Order of constraint of continuity at the extremities. */
/* CRVJAC : The curve the degree which of will be lowered. */
/* NCFNEW : Degree +1 of the resulting polynom. */
/* OUTPUT ARGUMENTS : */
/* ------------------- */
/* ERRMOY : Average precision of approximation. */
/* COMMONS USED : */
/* ---------------- */
/* REFERENCES CALLED : */
/* ----------------------- */
/* DESCRIPTION/NOTES/LIMITATIONS : */
/* ----------------------------------- */
/* > */
/* ***********************************************************************
*/
/* Name of the routine */
/* Parameter adjustments */
crvjac_dim1 = *ncofmx;
crvjac_offset = crvjac_dim1 + 1;
crvjac -= crvjac_offset;
/* Function Body */
ibb = AdvApp2Var_SysBase::mnfndeb_();
if (ibb >= 2)
{
AdvApp2Var_SysBase::mgenmsg_("MMAPERM", 7L);
}
/* --------- Minimum degree that can be reached : Stop at 1 or IA -------
*/
ia = (*iordre + 1) << 1;
ncfcut = ia + 1;
if (*ncfnew + 1 > ncfcut)
{
ncfcut = *ncfnew + 1;
}
/* -------------- Elimination of coefficients of high degree ------------ */
/* ----------- Loop on the series of Jacobi :NCFCUT --> NCOEFF --------- */
*errmoy = 0.;
bid = 0.;
i__1 = *ndim;
for (nd = 1; nd <= i__1; ++nd)
{
i__2 = *ncoeff;
for (i__ = ncfcut; i__ <= i__2; ++i__)
{
bidj = crvjac[i__ + nd * crvjac_dim1];
bid += bidj * bidj;
/* L200: */
}
/* L100: */
}
/* ----------- Square Root of average quadratic error e -----------
*/
bid /= 2.;
*errmoy = sqrt(bid);
/* ------------------------------- The end ------------------------------
*/
if (ibb >= 2)
{
AdvApp2Var_SysBase::mgsomsg_("MMAPERM", 7L);
}
return 0;
} /* mmaperm_ */
//=================================================================================================
int AdvApp2Var_ApproxF2var::mmapptt_(const int* ndgjac,
const int* nbpnts,
const int* jordre,
double* cgauss,
int* iercod)
{
/* System generated locals */
int cgauss_dim1, i__1;
/* Local variables */
int kjac, iptt, ipdb0, infdg, iptdb, mxjac, ilong, ibb;
/* **********************************************************************
*/
/* FUNCTION : */
/* ---------- */
/* Load the elements required for integration by */
/* Gauss method to obtain the coefficients in the base of */
/* Legendre of the approximation by the least squares of a */
/* function. The elements are stored in commons MMAPGSS */
/* (case without constraint), MMAPGS0 (constraints C0), MMAPGS1 */
/* (constraints C1) and MMAPGS2 (constraints C2). */
/* KEYWORDS : */
/* ----------- */
/* INTEGRATION,GAUSS,JACOBI */
/* INPUT ARGUMENTS : */
/* ------------------ */
/* NDGJAC : Max degree of the polynom of approximation. */
/* The representation in orthogonal base goes from degree */
/* 0 to degree NDGJAC-2*(JORDRE+1). The polynomial base */
/* is the base of Jacobi of order -1 (Legendre), 0, 1 and 2 */
/* NBPNTS : Degree of the polynom of Legendre on the roots which of */
/* are calculated the coefficients of integration by the */
/* method of Gauss. It is required that NBPNTS=8,10,15,20,25, */
/* 30,40,50 or 61 and NDGJAC < NBPNTS. */
/* JORDRE : Order of the base of Jacobi (-1,0,1 or 2). Corresponds */
/* to step of constraints C0,C1 or C2. */
/* OUTPUT ARGUMENTS : */
/* ------------------- */
/* CGAUSS(i,k) : Table of coefficients of integration by */
/* Gauss method : i varies from 0 to the int part */
/* of NBPNTS/2 and k varies from 0 to NDGJAC-2*(JORDRE+1). */
/* These are the coeff. of integration associated to */
/* positive roots of the polynom of Legendre of degree */
/* NBPNTS. CGAUSS(0,k) contains coeff. */
/* of integration associated to root t = 0 when */
/* NBPNTS is uneven. */
/* IERCOD : Error code. */
/* = 0 OK, */
/* = 11 NBPNTS is not 8,10,15,20,25,30,40,50 or 61. */
/* = 21 JORDRE is not -1,0,1 or 2. */
/* = 31 NDGJAC is too great or too small. */
/* COMMONS USED : */
/* ---------------- */
/* MMAPGSS,MMAPGS0,MMAPGS1,MMAPGS2. */
/* ***********************************************************************
*/
/* Parameter adjustments */
cgauss_dim1 = *nbpnts / 2 + 1;
/* Function Body */
ibb = AdvApp2Var_SysBase::mnfndeb_();
if (ibb >= 2)
{
AdvApp2Var_SysBase::mgenmsg_("MMAPPTT", 7L);
}
*iercod = 0;
/* ------------------- Tests on the validity of inputs ----------------
*/
infdg = (*jordre + 1) << 1;
if (*nbpnts != 8 && *nbpnts != 10 && *nbpnts != 15 && *nbpnts != 20 && *nbpnts != 25
&& *nbpnts != 30 && *nbpnts != 40 && *nbpnts != 50 && *nbpnts != 61)
{
goto L9100;
}
if (*jordre < -1 || *jordre > 2)
{
goto L9200;
}
if (*ndgjac >= *nbpnts || *ndgjac < infdg)
{
goto L9300;
}
/* --------------- Calculation of the start pointer following NBPNTS -----------
*/
iptdb = 0;
if (*nbpnts > 8)
{
iptdb += (8 - infdg) << 2;
}
if (*nbpnts > 10)
{
iptdb += (10 - infdg) * 5;
}
if (*nbpnts > 15)
{
iptdb += (15 - infdg) * 7;
}
if (*nbpnts > 20)
{
iptdb += (20 - infdg) * 10;
}
if (*nbpnts > 25)
{
iptdb += (25 - infdg) * 12;
}
if (*nbpnts > 30)
{
iptdb += (30 - infdg) * 15;
}
if (*nbpnts > 40)
{
iptdb += (40 - infdg) * 20;
}
if (*nbpnts > 50)
{
iptdb += (50 - infdg) * 25;
}
ipdb0 = 1;
if (*nbpnts > 15)
{
ipdb0 = ipdb0 + (14 - infdg) / 2 + 1;
}
if (*nbpnts > 25)
{
ipdb0 = ipdb0 + (24 - infdg) / 2 + 1;
}
/* ------------------ Choice of the common depending on JORDRE -------------
*/
if (*jordre == -1)
{
goto L1000;
}
if (*jordre == 0)
{
goto L2000;
}
if (*jordre == 1)
{
goto L3000;
}
if (*jordre == 2)
{
goto L4000;
}
/* ---------------- Common MMAPGSS (case without constraints) ----------------
*/
L1000:
ilong = *nbpnts / 2 << 3;
i__1 = *ndgjac;
for (kjac = 0; kjac <= i__1; ++kjac)
{
iptt = iptdb + kjac * (*nbpnts / 2) + 1;
AdvApp2Var_SysBase::mcrfill_(&ilong,
&AdvApp2Var_Data::Getmmapgss().gslxjs[iptt - 1],
&cgauss[kjac * cgauss_dim1 + 1]);
/* L100: */
}
/* --> Case when the number of points is uneven. */
if (*nbpnts % 2 == 1)
{
iptt = ipdb0;
i__1 = *ndgjac;
for (kjac = 0; kjac <= i__1; kjac += 2)
{
cgauss[kjac * cgauss_dim1] = AdvApp2Var_Data::Getmmapgss().gsl0js[iptt - 1];
++iptt;
/* L150: */
}
i__1 = *ndgjac;
for (kjac = 1; kjac <= i__1; kjac += 2)
{
cgauss[kjac * cgauss_dim1] = 0.;
/* L160: */
}
}
goto L9999;
/* ---------------- Common MMAPGS0 (case with constraints C0) -------------
*/
L2000:
mxjac = *ndgjac - infdg;
ilong = *nbpnts / 2 << 3;
i__1 = mxjac;
for (kjac = 0; kjac <= i__1; ++kjac)
{
iptt = iptdb + kjac * (*nbpnts / 2) + 1;
AdvApp2Var_SysBase::mcrfill_(&ilong,
&AdvApp2Var_Data::Getmmapgs0().gslxj0[iptt - 1],
&cgauss[kjac * cgauss_dim1 + 1]);
/* L200: */
}
/* --> Case when the number of points is uneven. */
if (*nbpnts % 2 == 1)
{
iptt = ipdb0;
i__1 = mxjac;
for (kjac = 0; kjac <= i__1; kjac += 2)
{
cgauss[kjac * cgauss_dim1] = AdvApp2Var_Data::Getmmapgs0().gsl0j0[iptt - 1];
++iptt;
/* L250: */
}
i__1 = mxjac;
for (kjac = 1; kjac <= i__1; kjac += 2)
{
cgauss[kjac * cgauss_dim1] = 0.;
/* L260: */
}
}
goto L9999;
/* ---------------- Common MMAPGS1 (case with constraints C1) -------------
*/
L3000:
mxjac = *ndgjac - infdg;
ilong = *nbpnts / 2 << 3;
i__1 = mxjac;
for (kjac = 0; kjac <= i__1; ++kjac)
{
iptt = iptdb + kjac * (*nbpnts / 2) + 1;
AdvApp2Var_SysBase::mcrfill_(&ilong,
&AdvApp2Var_Data::Getmmapgs1().gslxj1[iptt - 1],
&cgauss[kjac * cgauss_dim1 + 1]);
/* L300: */
}
/* --> Case when the number of points is uneven. */
if (*nbpnts % 2 == 1)
{
iptt = ipdb0;
i__1 = mxjac;
for (kjac = 0; kjac <= i__1; kjac += 2)
{
cgauss[kjac * cgauss_dim1] = AdvApp2Var_Data::Getmmapgs1().gsl0j1[iptt - 1];
++iptt;
/* L350: */
}
i__1 = mxjac;
for (kjac = 1; kjac <= i__1; kjac += 2)
{
cgauss[kjac * cgauss_dim1] = 0.;
/* L360: */
}
}
goto L9999;
/* ---------------- Common MMAPGS2 (case with constraints C2) -------------
*/
L4000:
mxjac = *ndgjac - infdg;
ilong = *nbpnts / 2 << 3;
i__1 = mxjac;
for (kjac = 0; kjac <= i__1; ++kjac)
{
iptt = iptdb + kjac * (*nbpnts / 2) + 1;
AdvApp2Var_SysBase::mcrfill_(&ilong,
&AdvApp2Var_Data::Getmmapgs2().gslxj2[iptt - 1],
&cgauss[kjac * cgauss_dim1 + 1]);
/* L400: */
}
/* --> Cas of uneven number of points. */
if (*nbpnts % 2 == 1)
{
iptt = ipdb0;
i__1 = mxjac;
for (kjac = 0; kjac <= i__1; kjac += 2)
{
cgauss[kjac * cgauss_dim1] = AdvApp2Var_Data::Getmmapgs2().gsl0j2[iptt - 1];
++iptt;
/* L450: */
}
i__1 = mxjac;
for (kjac = 1; kjac <= i__1; kjac += 2)
{
cgauss[kjac * cgauss_dim1] = 0.;
/* L460: */
}
}
goto L9999;
/* ------------------------- Return the error code --------------
*/
/* --> NBPNTS is not OK */
L9100:
*iercod = 11;
goto L9999;
/* --> JORDRE is not OK */
L9200:
*iercod = 21;
goto L9999;
/* --> NDGJAC is not OK */
L9300:
*iercod = 31;
goto L9999;
/* -------------------------------- The end -----------------------------
*/
L9999:
if (*iercod > 0)
{
AdvApp2Var_SysBase::maermsg_("MMAPPTT", iercod, 7L);
}
if (ibb >= 2)
{
AdvApp2Var_SysBase::mgsomsg_("MMAPPTT", 7L);
}
return 0;
} /* mmapptt_ */
//=================================================================================================
int mmjacpt_(const int* ndimen,
const int* ncoefu,
const int* ncoefv,
const int* iordru,
const int* iordrv,
const double* ptclgd,
double* ptcaux,
double* ptccan)
{
/* System generated locals */
int ptccan_dim1, ptccan_dim2, ptccan_offset, ptclgd_dim1, ptclgd_dim2, ptclgd_offset, ptcaux_dim1,
ptcaux_dim2, ptcaux_dim3, ptcaux_offset, i__1, i__2, i__3;
/* Local variables */
int kdim, nd, ii, jj, ibb;
/* ***********************************************************************
*/
/* FONCTION : */
/* ---------- */
/* Passage from canonical to Jacobi base for a */
/* "square" in a space of arbitrary dimension. */
/* MOTS CLES : */
/* ----------- */
/* SMOOTHING,BASE,LEGENDRE */
/* INPUT ARGUMENTS : */
/* ------------------ */
/* NDIMEN : Dimension of the space. */
/* NCOEFU : Degree+1 by U. */
/* NCOEFV : Degree+1 by V. */
/* IORDRU : Order of Jacobi polynoms by U. */
/* IORDRV : Order of Jacobi polynoms by V. */
/* PTCLGD : The square in the Jacobi base. */
/* OUTPUT ARGUMENTS : */
/* ------------------- */
/* PTCAUX : Auxiliary space. */
/* PTCCAN : The square in the canonic base (-1,1) */
/* COMMONS USED : */
/* ---------------- */
/* APPLIED REFERENCES : */
/* ----------------------- */
/* DESCRIPTION/NOTES/LIMITATIONS : */
/* ----------------------------------- */
/* Cancels and replaces MJACPC */
/* *********************************************************************
*/
/* Name of the routine */
/* Parameter adjustments */
ptccan_dim1 = *ncoefu;
ptccan_dim2 = *ncoefv;
ptccan_offset = ptccan_dim1 * (ptccan_dim2 + 1) + 1;
ptccan -= ptccan_offset;
ptcaux_dim1 = *ncoefv;
ptcaux_dim2 = *ncoefu;
ptcaux_dim3 = *ndimen;
ptcaux_offset = ptcaux_dim1 * (ptcaux_dim2 * (ptcaux_dim3 + 1) + 1) + 1;
ptcaux -= ptcaux_offset;
ptclgd_dim1 = *ncoefu;
ptclgd_dim2 = *ncoefv;
ptclgd_offset = ptclgd_dim1 * (ptclgd_dim2 + 1) + 1;
ptclgd -= ptclgd_offset;
/* Function Body */
ibb = AdvApp2Var_SysBase::mnfndeb_();
if (ibb >= 3)
{
AdvApp2Var_SysBase::mgenmsg_("MMJACPT", 7L);
}
/* Passage into canonical by u. */
kdim = *ndimen * *ncoefv;
AdvApp2Var_MathBase::mmjaccv_(ncoefu,
&kdim,
iordru,
&ptclgd[ptclgd_offset],
&ptcaux[ptcaux_offset],
&ptccan[ptccan_offset]);
/* Swapping of u and v. */
i__1 = *ndimen;
for (nd = 1; nd <= i__1; ++nd)
{
i__2 = *ncoefv;
for (jj = 1; jj <= i__2; ++jj)
{
i__3 = *ncoefu;
for (ii = 1; ii <= i__3; ++ii)
{
ptcaux[jj + (ii + (nd + ptcaux_dim3) * ptcaux_dim2) * ptcaux_dim1] =
ptccan[ii + (jj + nd * ptccan_dim2) * ptccan_dim1];
/* L320: */
}
/* L310: */
}
/* L300: */
}
/* Passage into canonical by v. */
kdim = *ndimen * *ncoefu;
AdvApp2Var_MathBase::mmjaccv_(
ncoefv,
&kdim,
iordrv,
&ptcaux[((ptcaux_dim3 + 1) * ptcaux_dim2 + 1) * ptcaux_dim1 + 1],
&ptccan[ptccan_offset],
&ptcaux[(((ptcaux_dim3 << 1) + 1) * ptcaux_dim2 + 1) * ptcaux_dim1 + 1]);
/* Swapping of u and v. */
i__1 = *ndimen;
for (nd = 1; nd <= i__1; ++nd)
{
i__2 = *ncoefv;
for (jj = 1; jj <= i__2; ++jj)
{
i__3 = *ncoefu;
for (ii = 1; ii <= i__3; ++ii)
{
ptccan[ii + (jj + nd * ptccan_dim2) * ptccan_dim1] =
ptcaux[jj + (ii + (nd + (ptcaux_dim3 << 1)) * ptcaux_dim2) * ptcaux_dim1];
/* L420: */
}
/* L410: */
}
/* L400: */
}
/* ---------------------------- THAT'S ALL FOLKS ------------------------
*/
if (ibb >= 3)
{
AdvApp2Var_SysBase::mgsomsg_("MMJACPT", 7L);
}
return 0;
} /* mmjacpt_ */
Reference in New Issue View Git Blame Copy Permalink