mirror of
https://git.dev.opencascade.org/repos/occt.git
synced 2025-05-11 10:44:53 +03:00
8206 lines
264 KiB
C++
8206 lines
264 KiB
C++
// 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_f2c.hxx>
|
|
#include <AdvApp2Var_Data.hxx>
|
|
#include <AdvApp2Var_ApproxF2var.hxx>
|
|
|
|
#include <cmath>
|
|
|
|
static
|
|
int mmjacpt_(const integer *ndimen,
|
|
const integer *ncoefu,
|
|
const integer *ncoefv,
|
|
const integer *iordru,
|
|
const integer *iordrv,
|
|
const doublereal *ptclgd,
|
|
doublereal *ptcaux,
|
|
doublereal *ptccan);
|
|
|
|
|
|
|
|
static
|
|
int mma2ce2_(integer *numdec,
|
|
integer *ndimen,
|
|
integer *nbsesp,
|
|
integer *ndimse,
|
|
integer *ndminu,
|
|
integer *ndminv,
|
|
integer *ndguli,
|
|
integer *ndgvli,
|
|
integer *ndjacu,
|
|
integer *ndjacv,
|
|
integer *iordru,
|
|
integer *iordrv,
|
|
integer *nbpntu,
|
|
integer *nbpntv,
|
|
doublereal *epsapr,
|
|
doublereal *sosotb,
|
|
doublereal *disotb,
|
|
doublereal *soditb,
|
|
doublereal *diditb,
|
|
doublereal *gssutb,
|
|
doublereal *gssvtb,
|
|
doublereal *xmaxju,
|
|
doublereal *xmaxjv,
|
|
doublereal *vecerr,
|
|
doublereal *chpair,
|
|
doublereal *chimpr,
|
|
doublereal *patjac,
|
|
doublereal *errmax,
|
|
doublereal *errmoy,
|
|
integer *ndegpu,
|
|
integer *ndegpv,
|
|
integer *itydec,
|
|
integer *iercod);
|
|
|
|
static
|
|
int mma2cfu_(integer *ndujac,
|
|
integer *nbpntu,
|
|
integer *nbpntv,
|
|
doublereal *sosotb,
|
|
doublereal *disotb,
|
|
doublereal *soditb,
|
|
doublereal *diditb,
|
|
doublereal *gssutb,
|
|
doublereal *chpair,
|
|
doublereal *chimpr);
|
|
|
|
static
|
|
int mma2cfv_(integer *ndvjac,
|
|
integer *mindgu,
|
|
integer *maxdgu,
|
|
integer *nbpntv,
|
|
doublereal *gssvtb,
|
|
doublereal *chpair,
|
|
doublereal *chimpr,
|
|
doublereal *patjac);
|
|
|
|
static
|
|
int mma2er1_(integer *ndjacu,
|
|
integer *ndjacv,
|
|
integer *ndimen,
|
|
integer *mindgu,
|
|
integer *maxdgu,
|
|
integer *mindgv,
|
|
integer *maxdgv,
|
|
integer *iordru,
|
|
integer *iordrv,
|
|
doublereal *xmaxju,
|
|
doublereal *xmaxjv,
|
|
doublereal *patjac,
|
|
doublereal *vecerr,
|
|
doublereal *erreur);
|
|
|
|
static
|
|
int mma2er2_(integer *ndjacu,
|
|
integer *ndjacv,
|
|
integer *ndimen,
|
|
integer *mindgu,
|
|
integer *maxdgu,
|
|
integer *mindgv,
|
|
integer *maxdgv,
|
|
integer *iordru,
|
|
integer *iordrv,
|
|
doublereal *xmaxju,
|
|
doublereal *xmaxjv,
|
|
doublereal *patjac,
|
|
doublereal *epmscut,
|
|
doublereal *vecerr,
|
|
doublereal *erreur,
|
|
integer *newdgu,
|
|
integer *newdgv);
|
|
|
|
static
|
|
int mma2moy_(integer *ndgumx,
|
|
integer *ndgvmx,
|
|
integer *ndimen,
|
|
integer *mindgu,
|
|
integer *maxdgu,
|
|
integer *mindgv,
|
|
integer *maxdgv,
|
|
integer *iordru,
|
|
integer *iordrv,
|
|
doublereal *patjac,
|
|
doublereal *errmoy);
|
|
|
|
static
|
|
int mma2ds2_(integer *ndimen,
|
|
doublereal *uintfn,
|
|
doublereal *vintfn,
|
|
const AdvApp2Var_EvaluatorFunc2Var& foncnp,
|
|
integer *nbpntu,
|
|
integer *nbpntv,
|
|
doublereal *urootb,
|
|
doublereal *vrootb,
|
|
integer *iiuouv,
|
|
doublereal *sosotb,
|
|
doublereal *disotb,
|
|
doublereal *soditb,
|
|
doublereal *diditb,
|
|
doublereal *fpntab,
|
|
doublereal *ttable,
|
|
integer *iercod);
|
|
|
|
|
|
|
|
|
|
static
|
|
int mma1fdi_(integer *ndimen,
|
|
doublereal *uvfonc,
|
|
const AdvApp2Var_EvaluatorFunc2Var& foncnp,
|
|
integer *isofav,
|
|
doublereal *tconst,
|
|
integer *nbroot,
|
|
doublereal *ttable,
|
|
integer *iordre,
|
|
integer *ideriv,
|
|
doublereal *fpntab,
|
|
doublereal *somtab,
|
|
doublereal *diftab,
|
|
doublereal *contr1,
|
|
doublereal *contr2,
|
|
integer *iercod);
|
|
|
|
static
|
|
int mma1cdi_(integer *ndimen,
|
|
integer *nbroot,
|
|
doublereal *rootlg,
|
|
integer *iordre,
|
|
doublereal *contr1,
|
|
doublereal *contr2,
|
|
doublereal *somtab,
|
|
doublereal *diftab,
|
|
doublereal *fpntab,
|
|
doublereal *hermit,
|
|
integer *iercod);
|
|
static
|
|
int mma1jak_(integer *ndimen,
|
|
integer *nbroot,
|
|
integer *iordre,
|
|
integer *ndgjac,
|
|
doublereal *somtab,
|
|
doublereal *diftab,
|
|
doublereal *cgauss,
|
|
doublereal *crvjac,
|
|
integer *iercod);
|
|
static
|
|
int mma1cnt_(integer *ndimen,
|
|
integer *iordre,
|
|
doublereal *contr1,
|
|
doublereal *contr2,
|
|
doublereal *hermit,
|
|
integer *ndgjac,
|
|
doublereal *crvjac);
|
|
|
|
static
|
|
int mma1fer_(integer *ndimen,
|
|
integer *nbsesp,
|
|
integer *ndimse,
|
|
integer *iordre,
|
|
integer *ndgjac,
|
|
doublereal *crvjac,
|
|
integer *ncflim,
|
|
doublereal *epsapr,
|
|
doublereal *ycvmax,
|
|
doublereal *errmax,
|
|
doublereal *errmoy,
|
|
integer *ncoeff,
|
|
integer *iercod);
|
|
|
|
static
|
|
int mma1noc_(doublereal *dfuvin,
|
|
integer *ndimen,
|
|
integer *iordre,
|
|
doublereal *cntrin,
|
|
doublereal *duvout,
|
|
integer *isofav,
|
|
integer *ideriv,
|
|
doublereal *cntout);
|
|
|
|
|
|
static
|
|
int mmmapcoe_(integer *ndim,
|
|
integer *ndgjac,
|
|
integer *iordre,
|
|
integer *nbpnts,
|
|
doublereal *somtab,
|
|
doublereal *diftab,
|
|
doublereal *gsstab,
|
|
doublereal *crvjac);
|
|
|
|
static
|
|
int mmaperm_(integer *ncofmx,
|
|
integer *ndim,
|
|
integer *ncoeff,
|
|
integer *iordre,
|
|
doublereal *crvjac,
|
|
integer *ncfnew,
|
|
doublereal *errmoy);
|
|
|
|
|
|
#define mmapgss_1 mmapgss_
|
|
#define mmapgs0_1 mmapgs0_
|
|
#define mmapgs1_1 mmapgs1_
|
|
#define mmapgs2_1 mmapgs2_
|
|
|
|
//=======================================================================
|
|
//function : mma1cdi_
|
|
//purpose :
|
|
//=======================================================================
|
|
int mma1cdi_(integer *ndimen,
|
|
integer *nbroot,
|
|
doublereal *rootlg,
|
|
integer *iordre,
|
|
doublereal *contr1,
|
|
doublereal *contr2,
|
|
doublereal *somtab,
|
|
doublereal *diftab,
|
|
doublereal *fpntab,
|
|
doublereal *hermit,
|
|
integer *iercod)
|
|
{
|
|
integer c__1 = 1;
|
|
|
|
/* System generated locals */
|
|
integer 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 */
|
|
integer nroo2, ncfhe, nd, ii, kk;
|
|
integer ibb, kkm, kkp;
|
|
doublereal 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, Everythig 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_ */
|
|
|
|
//=======================================================================
|
|
//function : mma1cnt_
|
|
//purpose :
|
|
//=======================================================================
|
|
int mma1cnt_(integer *ndimen,
|
|
integer *iordre,
|
|
doublereal *contr1,
|
|
doublereal *contr2,
|
|
doublereal *hermit,
|
|
integer *ndgjac,
|
|
doublereal *crvjac)
|
|
{
|
|
/* System generated locals */
|
|
integer contr1_dim1, contr1_offset, contr2_dim1, contr2_offset,
|
|
hermit_dim1, hermit_offset, crvjac_dim1, crvjac_offset, i__1,
|
|
i__2, i__3;
|
|
|
|
/* Local variables */
|
|
integer nd, ii, jj, ibb;
|
|
doublereal 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_ */
|
|
|
|
//=======================================================================
|
|
//function : mma1fdi_
|
|
//purpose :
|
|
//=======================================================================
|
|
int mma1fdi_(integer *ndimen,
|
|
doublereal *uvfonc,
|
|
const AdvApp2Var_EvaluatorFunc2Var& foncnp,
|
|
integer *isofav,
|
|
doublereal *tconst,
|
|
integer *nbroot,
|
|
doublereal *ttable,
|
|
integer *iordre,
|
|
integer *ideriv,
|
|
doublereal *fpntab,
|
|
doublereal *somtab,
|
|
doublereal *diftab,
|
|
doublereal *contr1,
|
|
doublereal *contr2,
|
|
integer *iercod)
|
|
{
|
|
/* System generated locals */
|
|
integer fpntab_dim1, somtab_dim1, somtab_offset, diftab_dim1,
|
|
diftab_offset, contr1_dim1, contr1_offset, contr2_dim1,
|
|
contr2_offset, i__1, i__2;
|
|
doublereal d__1;
|
|
|
|
/* Local variables */
|
|
integer ideb, ifin, nroo2, ideru, iderv;
|
|
doublereal renor;
|
|
integer ii, nd, ibb, iim, nbp, iip;
|
|
doublereal 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 */
|
|
uvfonc -= 3;
|
|
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[4] - uvfonc[3]) / 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[6] - uvfonc[5]) / 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[3],
|
|
&uvfonc[5],
|
|
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[6] - uvfonc[5]) / 2.;
|
|
i__1 = *iordre;
|
|
for (iderv = 1; iderv <= i__1; ++iderv) {
|
|
(*const_cast <AdvApp2Var_EvaluatorFunc2Var*> (&foncnp)).Evaluate (
|
|
ndimen, &uvfonc[3], &uvfonc[5], 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[3], &uvfonc[5], 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[4] - uvfonc[3]) / 2.;
|
|
i__1 = *iordre;
|
|
for (ideru = 1; ideru <= i__1; ++ideru) {
|
|
(*const_cast <AdvApp2Var_EvaluatorFunc2Var*> (&foncnp)).Evaluate (
|
|
ndimen, &uvfonc[3], &uvfonc[5], 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[3], &uvfonc[5], 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_ */
|
|
|
|
//=======================================================================
|
|
//function : mma1fer_
|
|
//purpose :
|
|
//=======================================================================
|
|
int mma1fer_(integer *,//ndimen,
|
|
integer *nbsesp,
|
|
integer *ndimse,
|
|
integer *iordre,
|
|
integer *ndgjac,
|
|
doublereal *crvjac,
|
|
integer *ncflim,
|
|
doublereal *epsapr,
|
|
doublereal *ycvmax,
|
|
doublereal *errmax,
|
|
doublereal *errmoy,
|
|
integer *ncoeff,
|
|
integer *iercod)
|
|
{
|
|
/* System generated locals */
|
|
integer crvjac_dim1, crvjac_offset, i__1, i__2;
|
|
|
|
/* Local variables */
|
|
integer idim, ncfja, ncfnw, ndses, ii, kk, ibb, ier;
|
|
integer 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 + constraintes of 1st derivatives (i.e. C1), */
|
|
/* 2 = C1 + constraintes 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 = advapp_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 autorized 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_ */
|
|
|
|
|
|
//=======================================================================
|
|
//function : mma1her_
|
|
//purpose :
|
|
//=======================================================================
|
|
int AdvApp2Var_ApproxF2var::mma1her_(const integer *iordre,
|
|
doublereal *hermit,
|
|
integer *iercod)
|
|
{
|
|
/* System generated locals */
|
|
integer hermit_dim1, hermit_offset;
|
|
|
|
/* Local variables */
|
|
integer 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_ */
|
|
//=======================================================================
|
|
//function : mma1jak_
|
|
//purpose :
|
|
//=======================================================================
|
|
int mma1jak_(integer *ndimen,
|
|
integer *nbroot,
|
|
integer *iordre,
|
|
integer *ndgjac,
|
|
doublereal *somtab,
|
|
doublereal *diftab,
|
|
doublereal *cgauss,
|
|
doublereal *crvjac,
|
|
integer *iercod)
|
|
{
|
|
/* System generated locals */
|
|
integer somtab_dim1, somtab_offset, diftab_dim1, diftab_offset,
|
|
crvjac_dim1, crvjac_offset;
|
|
|
|
/* Local variables */
|
|
integer 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_ */
|
|
|
|
//=======================================================================
|
|
//function : mma1noc_
|
|
//purpose :
|
|
//=======================================================================
|
|
int mma1noc_(doublereal *dfuvin,
|
|
integer *ndimen,
|
|
integer *iordre,
|
|
doublereal *cntrin,
|
|
doublereal *duvout,
|
|
integer *isofav,
|
|
integer *ideriv,
|
|
doublereal *cntout)
|
|
{
|
|
/* System generated locals */
|
|
integer i__1;
|
|
doublereal d__1;
|
|
|
|
/* Local variables */
|
|
doublereal rider, riord;
|
|
integer nd, ibb;
|
|
doublereal 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: Ordre de derivee transverse a l'iso fixee (Si 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_ */
|
|
|
|
//=======================================================================
|
|
//function : mma1nop_
|
|
//purpose :
|
|
//=======================================================================
|
|
int mma1nop_(integer *nbroot,
|
|
doublereal *rootlg,
|
|
doublereal *uvfonc,
|
|
integer *isofav,
|
|
doublereal *ttable,
|
|
integer *iercod)
|
|
|
|
{
|
|
/* System generated locals */
|
|
integer i__1;
|
|
|
|
/* Local variables */
|
|
doublereal alinu, blinu, alinv, blinv;
|
|
integer 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_ */
|
|
|
|
//=======================================================================
|
|
//function : mma2ac1_
|
|
//purpose :
|
|
//=======================================================================
|
|
int AdvApp2Var_ApproxF2var::mma2ac1_(integer const *ndimen,
|
|
integer const *mxujac,
|
|
integer const *mxvjac,
|
|
integer const *iordru,
|
|
integer const *iordrv,
|
|
doublereal const *contr1,
|
|
doublereal const * contr2,
|
|
doublereal const *contr3,
|
|
doublereal const *contr4,
|
|
doublereal const *uhermt,
|
|
doublereal const *vhermt,
|
|
doublereal *patjac)
|
|
|
|
{
|
|
/* System generated locals */
|
|
integer 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 */
|
|
logical ldbg;
|
|
integer ndgu, ndgv;
|
|
doublereal bidu1, bidu2, bidv1, bidv2;
|
|
integer ioru1, iorv1, ii, nd, jj, ku, kv;
|
|
doublereal 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_ */
|
|
|
|
//=======================================================================
|
|
//function : mma2ac2_
|
|
//purpose :
|
|
//=======================================================================
|
|
int AdvApp2Var_ApproxF2var::mma2ac2_(const integer *ndimen,
|
|
const integer *mxujac,
|
|
const integer *mxvjac,
|
|
const integer *iordrv,
|
|
const integer *nclimu,
|
|
const integer *ncfiv1,
|
|
const doublereal *crbiv1,
|
|
const integer *ncfiv2,
|
|
const doublereal *crbiv2,
|
|
const doublereal *vhermt,
|
|
doublereal *patjac)
|
|
|
|
{
|
|
/* System generated locals */
|
|
integer 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 */
|
|
logical ldbg;
|
|
integer ndgv1, ndgv2, ii, jj, nd, kk;
|
|
doublereal 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_ */
|
|
|
|
|
|
//=======================================================================
|
|
//function : mma2ac3_
|
|
//purpose :
|
|
//=======================================================================
|
|
int AdvApp2Var_ApproxF2var::mma2ac3_(const integer *ndimen,
|
|
const integer *mxujac,
|
|
const integer *mxvjac,
|
|
const integer *iordru,
|
|
const integer *nclimv,
|
|
const integer *ncfiu1,
|
|
const doublereal * crbiu1,
|
|
const integer *ncfiu2,
|
|
const doublereal *crbiu2,
|
|
const doublereal *uhermt,
|
|
doublereal *patjac)
|
|
|
|
{
|
|
/* System generated locals */
|
|
integer 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 */
|
|
logical ldbg;
|
|
integer ndgu1, ndgu2, ii, jj, nd, kk;
|
|
doublereal 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_ */
|
|
|
|
//=======================================================================
|
|
//function : mma2can_
|
|
//purpose :
|
|
//=======================================================================
|
|
int AdvApp2Var_ApproxF2var::mma2can_(const integer *ncfmxu,
|
|
const integer *ncfmxv,
|
|
const integer *ndimen,
|
|
const integer *iordru,
|
|
const integer *iordrv,
|
|
const integer *ncoefu,
|
|
const integer *ncoefv,
|
|
const doublereal *patjac,
|
|
doublereal *pataux,
|
|
doublereal *patcan,
|
|
integer *iercod)
|
|
|
|
{
|
|
/* System generated locals */
|
|
integer patjac_dim1, patjac_dim2, patjac_offset, patcan_dim1, patcan_dim2,
|
|
patcan_offset, i__1, i__2;
|
|
|
|
/* Local variables */
|
|
logical ldbg;
|
|
integer 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_ */
|
|
|
|
//=======================================================================
|
|
//function : mma2cd1_
|
|
//purpose :
|
|
//=======================================================================
|
|
int mma2cd1_(integer *ndimen,
|
|
integer *nbpntu,
|
|
doublereal *urootl,
|
|
integer *nbpntv,
|
|
doublereal *vrootl,
|
|
integer *iordru,
|
|
integer *iordrv,
|
|
doublereal *contr1,
|
|
doublereal *contr2,
|
|
doublereal *contr3,
|
|
doublereal *contr4,
|
|
doublereal *fpntbu,
|
|
doublereal *fpntbv,
|
|
doublereal *uhermt,
|
|
doublereal *vhermt,
|
|
doublereal *sosotb,
|
|
doublereal *soditb,
|
|
doublereal *disotb,
|
|
doublereal *diditb)
|
|
|
|
{
|
|
integer c__1 = 1;
|
|
|
|
/* System generated locals */
|
|
integer 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 */
|
|
integer ncfhu, ncfhv, nuroo, nvroo, nd, ii, jj, kk, ll, ibb, kkm,
|
|
llm, kkp, llp;
|
|
doublereal bid1, bid2, bid3, bid4;
|
|
doublereal 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_ */
|
|
|
|
//=======================================================================
|
|
//function : mma2cd2_
|
|
//purpose :
|
|
//=======================================================================
|
|
int mma2cd2_(integer *ndimen,
|
|
integer *nbpntu,
|
|
integer *nbpntv,
|
|
doublereal *vrootl,
|
|
integer *iordrv,
|
|
doublereal *sotbv1,
|
|
doublereal *sotbv2,
|
|
doublereal *ditbv1,
|
|
doublereal *ditbv2,
|
|
doublereal *fpntab,
|
|
doublereal *vhermt,
|
|
doublereal *sosotb,
|
|
doublereal *soditb,
|
|
doublereal *disotb,
|
|
doublereal *diditb)
|
|
|
|
{
|
|
integer c__1 = 1;
|
|
/* System generated locals */
|
|
integer 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 */
|
|
integer ncfhv, nuroo, nvroo, ii, nd, jj, kk, ibb, jjm, jjp;
|
|
doublereal 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_ */
|
|
|
|
//=======================================================================
|
|
//function : mma2cd3_
|
|
//purpose :
|
|
//=======================================================================
|
|
int mma2cd3_(integer *ndimen,
|
|
integer *nbpntu,
|
|
doublereal *urootl,
|
|
integer *nbpntv,
|
|
integer *iordru,
|
|
doublereal *sotbu1,
|
|
doublereal *sotbu2,
|
|
doublereal *ditbu1,
|
|
doublereal *ditbu2,
|
|
doublereal *fpntab,
|
|
doublereal *uhermt,
|
|
doublereal *sosotb,
|
|
doublereal *soditb,
|
|
doublereal *disotb,
|
|
doublereal *diditb)
|
|
|
|
{
|
|
integer c__1 = 1;
|
|
|
|
/* System generated locals */
|
|
integer 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 */
|
|
integer ncfhu, nuroo, nvroo, ii, nd, jj, kk, ibb, kkm, kkp;
|
|
doublereal 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_ */
|
|
|
|
//=======================================================================
|
|
//function : mma2cdi_
|
|
//purpose :
|
|
//=======================================================================
|
|
int AdvApp2Var_ApproxF2var::mma2cdi_( integer *ndimen,
|
|
integer *nbpntu,
|
|
doublereal *urootl,
|
|
integer *nbpntv,
|
|
doublereal *vrootl,
|
|
integer *iordru,
|
|
integer *iordrv,
|
|
doublereal *contr1,
|
|
doublereal *contr2,
|
|
doublereal *contr3,
|
|
doublereal *contr4,
|
|
doublereal *sotbu1,
|
|
doublereal *sotbu2,
|
|
doublereal *ditbu1,
|
|
doublereal *ditbu2,
|
|
doublereal *sotbv1,
|
|
doublereal *sotbv2,
|
|
doublereal *ditbv1,
|
|
doublereal *ditbv2,
|
|
doublereal *sosotb,
|
|
doublereal *soditb,
|
|
doublereal *disotb,
|
|
doublereal *diditb,
|
|
integer *iercod)
|
|
|
|
{
|
|
integer c__8 = 8;
|
|
|
|
/* System generated locals */
|
|
integer 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 */
|
|
integer ilong;
|
|
intptr_t iofwr;
|
|
doublereal* wrkar = 0;
|
|
integer iszwr;
|
|
integer ibb, ier = 0;
|
|
integer isz1, isz2, isz3, isz4;
|
|
intptr_t ipt1, ipt2, ipt3, ipt4;
|
|
|
|
|
|
|
|
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
/* 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;
|
|
}
|
|
ipt1 = iofwr;
|
|
ipt2 = ipt1 + isz1;
|
|
ipt3 = ipt2 + isz2;
|
|
ipt4 = ipt3 + isz3;
|
|
|
|
if (*iordru >= 0 && *iordru <= 2) {
|
|
|
|
/* --- Return 2*(IORDRU+1) coeff of 2*(IORDRU+1) polynoms of Hermite
|
|
--- */
|
|
|
|
AdvApp2Var_ApproxF2var::mma1her_(iordru, &wrkar[ipt1], iercod);
|
|
if (*iercod > 0) {
|
|
goto L9100;
|
|
}
|
|
|
|
/* ---- Subract discretizations of polynoms of constraints
|
|
---- */
|
|
|
|
mma2cd3_(ndimen, nbpntu, &urootl[1], nbpntv, iordru, &sotbu1[1], &
|
|
sotbu2[1], &ditbu1[1], &ditbu2[1], &wrkar[ipt3], &wrkar[ipt1],
|
|
&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[ipt2], 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[ipt4], &wrkar[ipt2],
|
|
&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[ipt3], &
|
|
wrkar[ipt4], &wrkar[ipt1], &wrkar[ipt2], &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_ */
|
|
|
|
//=======================================================================
|
|
//function : mma2ce1_
|
|
//purpose :
|
|
//=======================================================================
|
|
int AdvApp2Var_ApproxF2var::mma2ce1_(integer *numdec,
|
|
integer *ndimen,
|
|
integer *nbsesp,
|
|
integer *ndimse,
|
|
integer *ndminu,
|
|
integer *ndminv,
|
|
integer *ndguli,
|
|
integer *ndgvli,
|
|
integer *ndjacu,
|
|
integer *ndjacv,
|
|
integer *iordru,
|
|
integer *iordrv,
|
|
integer *nbpntu,
|
|
integer *nbpntv,
|
|
doublereal *epsapr,
|
|
doublereal *sosotb,
|
|
doublereal *disotb,
|
|
doublereal *soditb,
|
|
doublereal *diditb,
|
|
doublereal *patjac,
|
|
doublereal *errmax,
|
|
doublereal *errmoy,
|
|
integer *ndegpu,
|
|
integer *ndegpv,
|
|
integer *itydec,
|
|
integer *iercod)
|
|
|
|
{
|
|
integer c__8 = 8;
|
|
|
|
/* System generated locals */
|
|
integer 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 */
|
|
logical ldbg;
|
|
intptr_t iofwr;
|
|
doublereal* wrkar = 0;
|
|
integer iszwr;
|
|
integer ier;
|
|
integer isz1, isz2, isz3, isz4, isz5, isz6, isz7;
|
|
intptr_t ipt1, ipt2, ipt3, ipt4, ipt5, ipt6, ipt7;
|
|
|
|
|
|
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
/* 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);
|
|
if (ier > 0) {
|
|
goto L9013;
|
|
}
|
|
ipt1 = iofwr;
|
|
ipt2 = ipt1 + isz1;
|
|
ipt3 = ipt2 + isz2;
|
|
ipt4 = ipt3 + isz3;
|
|
ipt5 = ipt4 + isz4;
|
|
ipt6 = ipt5 + isz5;
|
|
ipt7 = ipt6 + isz6;
|
|
|
|
/* ----------------- Return Gauss coefficients of integration ----------------
|
|
*/
|
|
|
|
AdvApp2Var_ApproxF2var::mmapptt_(ndjacu, nbpntu, iordru, &wrkar[ipt1], iercod);
|
|
if (*iercod > 0) {
|
|
goto L9999;
|
|
}
|
|
AdvApp2Var_ApproxF2var::mmapptt_(ndjacv, nbpntv, iordrv, &wrkar[ipt2], iercod);
|
|
if (*iercod > 0) {
|
|
goto L9999;
|
|
}
|
|
|
|
/* ------------------- Return max polynoms of Jacobi ------------
|
|
*/
|
|
|
|
AdvApp2Var_ApproxF2var::mma2jmx_(ndjacu, iordru, &wrkar[ipt5]);
|
|
AdvApp2Var_ApproxF2var::mma2jmx_(ndjacv, iordrv, &wrkar[ipt6]);
|
|
|
|
/* ------ 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[ipt1], &wrkar[ipt2]
|
|
, &wrkar[ipt5], &wrkar[ipt6], &wrkar[ipt7], &wrkar[ipt3], &wrkar[
|
|
ipt4], &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_ */
|
|
|
|
//=======================================================================
|
|
//function : mma2ce2_
|
|
//purpose :
|
|
//=======================================================================
|
|
int mma2ce2_(integer *numdec,
|
|
integer *ndimen,
|
|
integer *nbsesp,
|
|
integer *ndimse,
|
|
integer *ndminu,
|
|
integer *ndminv,
|
|
integer *ndguli,
|
|
integer *ndgvli,
|
|
integer *ndjacu,
|
|
integer *ndjacv,
|
|
integer *iordru,
|
|
integer *iordrv,
|
|
integer *nbpntu,
|
|
integer *nbpntv,
|
|
doublereal *epsapr,
|
|
doublereal *sosotb,
|
|
doublereal *disotb,
|
|
doublereal *soditb,
|
|
doublereal *diditb,
|
|
doublereal *gssutb,
|
|
doublereal *gssvtb,
|
|
doublereal *xmaxju,
|
|
doublereal *xmaxjv,
|
|
doublereal *vecerr,
|
|
doublereal *chpair,
|
|
doublereal *chimpr,
|
|
doublereal *patjac,
|
|
doublereal *errmax,
|
|
doublereal *errmoy,
|
|
integer *ndegpu,
|
|
integer *ndegpv,
|
|
integer *itydec,
|
|
integer *iercod)
|
|
|
|
{
|
|
/* System generated locals */
|
|
integer 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 */
|
|
logical ldbg;
|
|
integer idim, igsu, minu, minv, maxu, maxv, igsv;
|
|
doublereal vaux[3];
|
|
integer i2rdu, i2rdv, ndses, nd, ii, jj, kk, nu, nv;
|
|
doublereal zu, zv;
|
|
integer 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 = advapp_max(i__1,i__2);
|
|
minu = advapp_max(i__1,*ndminu);
|
|
maxu = *ndguli;
|
|
/* Computing MAX */
|
|
i__1 = 1, i__2 = (*iordrv << 1) + 1, i__1 = advapp_max(i__1,i__2);
|
|
minv = advapp_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 = advapp_max(*ndegpu,nu);
|
|
*ndegpv = advapp_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 = advapp_max(i__2,i__3);
|
|
minu = advapp_max(i__2,*ndminu);
|
|
maxu = *ndguli;
|
|
/* Computing MAX */
|
|
i__2 = 1, i__3 = (*iordrv << 1) + 1, i__2 = advapp_max(i__2,i__3);
|
|
minv = advapp_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 = advapp_max(*ndegpu,nu);
|
|
*ndegpv = advapp_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_ */
|
|
|
|
//=======================================================================
|
|
//function : mma2cfu_
|
|
//purpose :
|
|
//=======================================================================
|
|
int mma2cfu_(integer *ndujac,
|
|
integer *nbpntu,
|
|
integer *nbpntv,
|
|
doublereal *sosotb,
|
|
doublereal *disotb,
|
|
doublereal *soditb,
|
|
doublereal *diditb,
|
|
doublereal *gssutb,
|
|
doublereal *chpair,
|
|
doublereal *chimpr)
|
|
|
|
{
|
|
/* System generated locals */
|
|
integer sosotb_dim1, disotb_dim1, disotb_offset, soditb_dim1,
|
|
soditb_offset, diditb_dim1, i__1, i__2;
|
|
|
|
/* Local variables */
|
|
logical ldbg;
|
|
integer nptu2, nptv2, ii, jj;
|
|
doublereal 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_ */
|
|
|
|
//=======================================================================
|
|
//function : mma2cfv_
|
|
//purpose :
|
|
//=======================================================================
|
|
int mma2cfv_(integer *ndvjac,
|
|
integer *mindgu,
|
|
integer *maxdgu,
|
|
integer *nbpntv,
|
|
doublereal *gssvtb,
|
|
doublereal *chpair,
|
|
doublereal *chimpr,
|
|
doublereal *patjac)
|
|
|
|
{
|
|
/* System generated locals */
|
|
integer chpair_dim1, chpair_offset, chimpr_dim1, chimpr_offset,
|
|
patjac_offset, i__1, i__2;
|
|
|
|
/* Local variables */
|
|
logical ldbg;
|
|
integer nptv2, ii, jj;
|
|
doublereal 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 reqired 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_ */
|
|
|
|
//=======================================================================
|
|
//function : mma2ds1_
|
|
//purpose :
|
|
//=======================================================================
|
|
int AdvApp2Var_ApproxF2var::mma2ds1_(integer *ndimen,
|
|
doublereal *uintfn,
|
|
doublereal *vintfn,
|
|
const AdvApp2Var_EvaluatorFunc2Var& foncnp,
|
|
integer *nbpntu,
|
|
integer *nbpntv,
|
|
doublereal *urootb,
|
|
doublereal *vrootb,
|
|
integer *isofav,
|
|
doublereal *sosotb,
|
|
doublereal *disotb,
|
|
doublereal *soditb,
|
|
doublereal *diditb,
|
|
doublereal *fpntab,
|
|
doublereal *ttable,
|
|
integer *iercod)
|
|
|
|
{
|
|
/* System generated locals */
|
|
integer 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 */
|
|
logical ldbg;
|
|
integer ibid1, ibid2, iuouv, nd;
|
|
integer 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 integer 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, real, 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, integer. 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, integer, takes values between 0 (position) */
|
|
/* and IORDRE(1) (partial derivative of the function by u */
|
|
/* of order IORDRE(1) if IORDRE(1) > 0). */
|
|
/* - IDERIV, integer, 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 */
|
|
/* (integer) 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_ */
|
|
|
|
//=======================================================================
|
|
//function : mma2ds2_
|
|
//purpose :
|
|
//=======================================================================
|
|
int mma2ds2_(integer *ndimen,
|
|
doublereal *uintfn,
|
|
doublereal *vintfn,
|
|
const AdvApp2Var_EvaluatorFunc2Var& foncnp,
|
|
integer *nbpntu,
|
|
integer *nbpntv,
|
|
doublereal *urootb,
|
|
doublereal *vrootb,
|
|
integer *iiuouv,
|
|
doublereal *sosotb,
|
|
doublereal *disotb,
|
|
doublereal *soditb,
|
|
doublereal *diditb,
|
|
doublereal *fpntab,
|
|
doublereal *ttable,
|
|
integer *iercod)
|
|
|
|
{
|
|
integer c__0 = 0;
|
|
/* System generated locals */
|
|
integer 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 */
|
|
integer jdec;
|
|
logical ldbg;
|
|
doublereal alinu, blinu, alinv, blinv, tcons;
|
|
doublereal dbfn1[2], dbfn2[2];
|
|
integer nuroo, nvroo, id, iu, iv;
|
|
doublereal 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 integer 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, real, 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, integer. 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, integer, takes values between 0 (position) */
|
|
/* and IORDRE(1) (partial derivative of the function by u */
|
|
/* of order IORDRE(1) if IORDRE(1) > 0). */
|
|
/* - IDERIV, integer, 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 */
|
|
/* (integer) 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_ */
|
|
|
|
//=======================================================================
|
|
//function : mma2er1_
|
|
//purpose :
|
|
//=======================================================================
|
|
int mma2er1_(integer *ndjacu,
|
|
integer *ndjacv,
|
|
integer *ndimen,
|
|
integer *mindgu,
|
|
integer *maxdgu,
|
|
integer *mindgv,
|
|
integer *maxdgv,
|
|
integer *iordru,
|
|
integer *iordrv,
|
|
doublereal *xmaxju,
|
|
doublereal *xmaxjv,
|
|
doublereal *patjac,
|
|
doublereal *vecerr,
|
|
doublereal *erreur)
|
|
|
|
{
|
|
/* System generated locals */
|
|
integer patjac_dim1, patjac_dim2, patjac_offset, i__1, i__2, i__3;
|
|
doublereal d__1;
|
|
|
|
/* Local variables */
|
|
logical ldbg;
|
|
integer minu, minv;
|
|
doublereal vaux[2];
|
|
integer ii, nd, jj;
|
|
doublereal 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], advapp_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_ */
|
|
|
|
//=======================================================================
|
|
//function : mma2er2_
|
|
//purpose :
|
|
//=======================================================================
|
|
int mma2er2_(integer *ndjacu,
|
|
integer *ndjacv,
|
|
integer *ndimen,
|
|
integer *mindgu,
|
|
integer *maxdgu,
|
|
integer *mindgv,
|
|
integer *maxdgv,
|
|
integer *iordru,
|
|
integer *iordrv,
|
|
doublereal *xmaxju,
|
|
doublereal *xmaxjv,
|
|
doublereal *patjac,
|
|
doublereal *epmscut,
|
|
doublereal *vecerr,
|
|
doublereal *erreur,
|
|
integer *newdgu,
|
|
integer *newdgv)
|
|
|
|
{
|
|
/* System generated locals */
|
|
integer patjac_dim1, patjac_dim2, patjac_offset, i__1, i__2;
|
|
doublereal d__1;
|
|
|
|
/* Local variables */
|
|
logical ldbg;
|
|
doublereal vaux[2];
|
|
integer i2rdu, i2rdv;
|
|
doublereal errnu, errnv;
|
|
integer ii, nd, jj, nu, nv;
|
|
doublereal bid0, bid1;
|
|
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
/* 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 -----------------
|
|
*/
|
|
|
|
bid0 = 0.;
|
|
if (nv > *mindgv) {
|
|
bid0 = xmaxjv[nv - i2rdv];
|
|
i__1 = *ndimen;
|
|
for (nd = 1; nd <= i__1; ++nd) {
|
|
bid1 = 0.;
|
|
i__2 = nu;
|
|
for (ii = i2rdu; ii <= i__2; ++ii) {
|
|
bid1 += (d__1 = patjac[ii + (nv + nd * patjac_dim2) *
|
|
patjac_dim1], advapp_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 -----------------
|
|
*/
|
|
|
|
bid0 = 0.;
|
|
if (nu > *mindgu) {
|
|
bid0 = xmaxju[nu - i2rdu];
|
|
i__1 = *ndimen;
|
|
for (nd = 1; nd <= i__1; ++nd) {
|
|
bid1 = 0.;
|
|
i__2 = nv;
|
|
for (jj = i2rdv; jj <= i__2; ++jj) {
|
|
bid1 += (d__1 = patjac[nu + (jj + nd * patjac_dim2) *
|
|
patjac_dim1], advapp_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 = advapp_max(nu,1);
|
|
*newdgv = advapp_max(nv,1);
|
|
|
|
/* ----------------------------------- The end --------------------------
|
|
*/
|
|
|
|
if (ldbg) {
|
|
AdvApp2Var_SysBase::mgsomsg_("MMA2ER2", 7L);
|
|
}
|
|
return 0;
|
|
} /* mma2er2_ */
|
|
|
|
//=======================================================================
|
|
//function : mma2fnc_
|
|
//purpose :
|
|
//=======================================================================
|
|
int AdvApp2Var_ApproxF2var::mma2fnc_(integer *ndimen,
|
|
integer *nbsesp,
|
|
integer *ndimse,
|
|
doublereal *uvfonc,
|
|
const AdvApp2Var_EvaluatorFunc2Var& foncnp,
|
|
doublereal *tconst,
|
|
integer *isofav,
|
|
integer *nbroot,
|
|
doublereal *rootlg,
|
|
integer *iordre,
|
|
integer *ideriv,
|
|
integer *ndgjac,
|
|
integer *nbcrmx,
|
|
integer *ncflim,
|
|
doublereal *epsapr,
|
|
integer *ncoeff,
|
|
doublereal *courbe,
|
|
integer *nbcrbe,
|
|
doublereal *somtab,
|
|
doublereal *diftab,
|
|
doublereal *contr1,
|
|
doublereal *contr2,
|
|
doublereal *tabdec,
|
|
doublereal *errmax,
|
|
doublereal *errmoy,
|
|
integer *iercod)
|
|
|
|
{
|
|
integer c__8 = 8;
|
|
|
|
/* System generated locals */
|
|
integer 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;
|
|
doublereal d__1;
|
|
|
|
/* Local variables */
|
|
integer ideb;
|
|
doublereal tmil;
|
|
integer ideb1, ibid1, ibid2, ncfja, ndgre, ilong,
|
|
ndwrk;
|
|
doublereal* wrkar = 0;
|
|
integer nupil;
|
|
intptr_t iofwr;
|
|
doublereal uvpav[4] /* was [2][2] */;
|
|
integer nd, ii;
|
|
integer ibb;
|
|
integer ier = 0;
|
|
doublereal uv11[4] /* was [2][2] */;
|
|
integer ncb1;
|
|
doublereal eps3;
|
|
integer isz1, isz2, isz3, isz4, isz5;
|
|
intptr_t ipt1, ipt2, ipt3, ipt4, ipt5,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 recuperation 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 integer 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, real, 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, integer, takes values between 0 (position) */
|
|
/* and IORDREU (partial derivative of the function by u */
|
|
/* of order IORDREU if IORDREU > 0). */
|
|
/* - IDERIV, integer, 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 */
|
|
/* (integer) 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], advapp_abs(d__1)) < eps3) {
|
|
goto L9100;
|
|
}
|
|
if ((d__1 = uvfonc[6] - uvfonc[5], advapp_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 = advapp_max(ibid1,ibid2);
|
|
ibid1 = (((*ncflim - 1) / 2 + 1) << 1) * *ndimen;
|
|
isz2 = advapp_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);
|
|
if (ier > 0) {
|
|
goto L9013; }
|
|
/* --> For the parameters of discretisation (NBROOT+2 extremities). */
|
|
ipt1 = iofwr;
|
|
/* --> For the points of discretisation FPNTAB(NDIMEN,NBROOT+2), */
|
|
/* FPNTAB(NBROOT,2*(IORDRE+1)) and for WRKAR of MMAPCMP. */
|
|
ipt2 = ipt1 + isz1;
|
|
/* --> For the polynoms of Hermit */
|
|
ipt3 = ipt2 + isz2;
|
|
/* --> For the Gauss coeff of integration. */
|
|
ipt4 = ipt3 + isz3;
|
|
/* --> For the curve in Jacobi. */
|
|
ipt5 = ipt4 + 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[ipt1], &ier);
|
|
if (ier > 0) {
|
|
goto L9100;
|
|
}
|
|
|
|
/* -------------------- Discretisation of FONCNP ------------------------ */
|
|
|
|
mma1fdi_(ndimen, uvpav, foncnp, isofav, tconst, nbroot, &wrkar[ipt1],
|
|
iordre, ideriv, &wrkar[ipt2], &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[ipt2], &wrkar[ipt3], &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[ipt4], &wrkar[ipt5], &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[ipt3], ndgjac, &wrkar[ipt5]);
|
|
}
|
|
|
|
/* **********************************************************************
|
|
*/
|
|
/* --------------- Calculate Max and Average error ----------------------
|
|
*/
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
mma1fer_(ndimen, nbsesp, &ndimse[1], iordre, ndgjac, &wrkar[ipt5], ncflim,
|
|
&epsapr[1], &wrkar[ipt2], &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)) {
|
|
|
|
/* ******************************************************************
|
|
**** */
|
|
/* ----------------------- Compression du resultat ------------------
|
|
---- */
|
|
/* ******************************************************************
|
|
**** */
|
|
|
|
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_((integer*)ndimen,
|
|
&ncfja,
|
|
&ncoeff[ncb1],
|
|
&wrkar[ipt5],
|
|
&wrkar[ipt2]);
|
|
/*pkv t*/
|
|
ilong = *ndimen * *ncflim;
|
|
AdvApp2Var_SysBase::mvriraz_(&ilong, &wrkar[ipt5]);
|
|
/* -> 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 = ipt2 + ((nd - 1) << 1) * (ndgre / 2 + 1);
|
|
jptt = ipt5 + (nd - 1) * ncoeff[ncb1];
|
|
AdvApp2Var_MathBase::mmjacan_(iordre, &ndgre, &wrkar[iptt], &wrkar[jptt]);
|
|
/* L400: */
|
|
}
|
|
|
|
/* -> Store the calculated curve */
|
|
ibid1 = 1;
|
|
AdvApp2Var_MathBase::mmfmca8_(&ncoeff[ncb1], ndimen, &ibid1, ncflim, ndimen, &ibid1, &
|
|
wrkar[ipt5], &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_ */
|
|
|
|
//=======================================================================
|
|
//function : mma2fx6_
|
|
//purpose :
|
|
//=======================================================================
|
|
int AdvApp2Var_ApproxF2var::mma2fx6_(integer *ncfmxu,
|
|
integer *ncfmxv,
|
|
integer *ndimen,
|
|
integer *nbsesp,
|
|
integer *ndimse,
|
|
integer *nbupat,
|
|
integer *nbvpat,
|
|
integer *iordru,
|
|
integer *iordrv,
|
|
doublereal *epsapr,
|
|
doublereal *epsfro,
|
|
doublereal *patcan,
|
|
doublereal *errmax,
|
|
integer *ncoefu,
|
|
integer *ncoefv)
|
|
|
|
{
|
|
/* System generated locals */
|
|
integer 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;
|
|
doublereal d__1, d__2;
|
|
|
|
/* Local variables */
|
|
integer idim, ncfu, ncfv, id, ii, nd, jj, ku, kv, ns, ibb;
|
|
doublereal bid;
|
|
doublereal 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: Ordre de contrainte impose aux extremites de l'iso-U */
|
|
/* = 0, on calcule les extremites de l'iso-U. */
|
|
/* = 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 = advapp_min(d__1,d__2);
|
|
/* Computing MIN */
|
|
d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 10];
|
|
tol = advapp_min(d__1,d__2);
|
|
/* Computing MIN */
|
|
d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 11];
|
|
tol = advapp_min(d__1,d__2);
|
|
/* Computing MIN */
|
|
d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 12];
|
|
tol = advapp_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 = advapp_min(d__1,d__2);
|
|
/* Computing MIN */
|
|
d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 6];
|
|
tol = advapp_min(d__1,d__2);
|
|
/* Computing MIN */
|
|
d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 7];
|
|
tol = advapp_min(d__1,d__2);
|
|
/* Computing MIN */
|
|
d__1 = tol, d__2 = epsfro[ns + (epsfro_dim1 << 3)];
|
|
tol = advapp_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], advapp_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 = advapp_min(d__1,d__2);
|
|
/* Computing MIN */
|
|
d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 10];
|
|
tol = advapp_min(d__1,d__2);
|
|
/* Computing MIN */
|
|
d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 11];
|
|
tol = advapp_min(d__1,d__2);
|
|
/* Computing MIN */
|
|
d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 12];
|
|
tol = advapp_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 = advapp_min(d__1,d__2);
|
|
/* Computing MIN */
|
|
d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 6];
|
|
tol = advapp_min(d__1,d__2);
|
|
/* Computing MIN */
|
|
d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 7];
|
|
tol = advapp_min(d__1,d__2);
|
|
/* Computing MIN */
|
|
d__1 = tol, d__2 = epsfro[ns + (epsfro_dim1 << 3)];
|
|
tol = advapp_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], advapp_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] = advapp_max(ncfu,2);
|
|
ncoefv[ii + jj * ncoefv_dim1] = advapp_max(ncfv,2);
|
|
/* L110: */
|
|
}
|
|
/* L100: */
|
|
}
|
|
|
|
/* ------------------------------ The End -------------------------------
|
|
*/
|
|
|
|
if (ibb >= 3) {
|
|
AdvApp2Var_SysBase::mgsomsg_("MMA2FX6", 7L);
|
|
}
|
|
|
|
return 0 ;
|
|
} /* mma2fx6_ */
|
|
|
|
//=======================================================================
|
|
//function : mma2jmx_
|
|
//purpose :
|
|
//=======================================================================
|
|
int AdvApp2Var_ApproxF2var::mma2jmx_(integer *ndgjac,
|
|
integer *iordre,
|
|
doublereal *xjacmx)
|
|
{
|
|
/* Initialized data */
|
|
|
|
static doublereal 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 doublereal 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 doublereal 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 */
|
|
integer i__1;
|
|
|
|
/* Local variables */
|
|
logical ldbg;
|
|
integer numax, ii;
|
|
doublereal 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_ */
|
|
|
|
//=======================================================================
|
|
//function : mma2moy_
|
|
//purpose :
|
|
//=======================================================================
|
|
int mma2moy_(integer *ndgumx,
|
|
integer *ndgvmx,
|
|
integer *ndimen,
|
|
integer *mindgu,
|
|
integer *maxdgu,
|
|
integer *mindgv,
|
|
integer *maxdgv,
|
|
integer *iordru,
|
|
integer *iordrv,
|
|
doublereal *patjac,
|
|
doublereal *errmoy)
|
|
{
|
|
/* System generated locals */
|
|
integer patjac_dim1, patjac_dim2, patjac_offset, i__1, i__2, i__3;
|
|
|
|
/* Local variables */
|
|
logical ldbg;
|
|
integer minu, minv, idebu, idebv, ii, nd, jj;
|
|
doublereal 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 = advapp_max(idebu,*mindgu);
|
|
minv = advapp_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_ */
|
|
|
|
//=======================================================================
|
|
//function : mma2roo_
|
|
//purpose :
|
|
//=======================================================================
|
|
int AdvApp2Var_ApproxF2var::mma2roo_(integer *nbpntu,
|
|
integer *nbpntv,
|
|
doublereal *urootl,
|
|
doublereal *vrootl)
|
|
{
|
|
/* System generated locals */
|
|
integer i__1;
|
|
|
|
/* Local variables */
|
|
integer 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_ */
|
|
//=======================================================================
|
|
//function : mmmapcoe_
|
|
//purpose :
|
|
//=======================================================================
|
|
int mmmapcoe_(integer *ndim,
|
|
integer *ndgjac,
|
|
integer *iordre,
|
|
integer *nbpnts,
|
|
doublereal *somtab,
|
|
doublereal *diftab,
|
|
doublereal *gsstab,
|
|
doublereal *crvjac)
|
|
|
|
{
|
|
/* System generated locals */
|
|
integer somtab_dim1, somtab_offset, diftab_dim1, diftab_offset,
|
|
crvjac_dim1, crvjac_offset, gsstab_dim1, i__1, i__2, i__3;
|
|
|
|
/* Local variables */
|
|
integer igss, ikdeb;
|
|
doublereal bidon;
|
|
integer nd, ik, ir, nbroot, ibb;
|
|
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
/* FUNCTION : */
|
|
/* ---------- */
|
|
/* Calculate the coefficients of polinomial 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_ */
|
|
//=======================================================================
|
|
//function : mmaperm_
|
|
//purpose :
|
|
//=======================================================================
|
|
int mmaperm_(integer *ncofmx,
|
|
integer *ndim,
|
|
integer *ncoeff,
|
|
integer *iordre,
|
|
doublereal *crvjac,
|
|
integer *ncfnew,
|
|
doublereal *errmoy)
|
|
{
|
|
/* System generated locals */
|
|
integer crvjac_dim1, crvjac_offset, i__1, i__2;
|
|
|
|
/* Local variables */
|
|
doublereal bidj;
|
|
integer i__, ia, nd, ncfcut, ibb;
|
|
doublereal 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_ */
|
|
//=======================================================================
|
|
//function : mmapptt_
|
|
//purpose :
|
|
//=======================================================================
|
|
int AdvApp2Var_ApproxF2var::mmapptt_(const integer *ndgjac,
|
|
const integer *nbpnts,
|
|
const integer *jordre,
|
|
doublereal *cgauss,
|
|
integer *iercod)
|
|
{
|
|
/* System generated locals */
|
|
integer cgauss_dim1, i__1;
|
|
|
|
/* Local variables */
|
|
integer 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 integer 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,
|
|
&mmapgss_.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] = mmapgss_.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,
|
|
&mmapgs0_.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] = mmapgs0_.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,
|
|
&mmapgs1_.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] = mmapgs1_.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,
|
|
&mmapgs2_.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] = mmapgs2_.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_ */
|
|
|
|
//=======================================================================
|
|
//function : mmjacpt_
|
|
//purpose :
|
|
//=======================================================================
|
|
int mmjacpt_(const integer *ndimen,
|
|
const integer *ncoefu,
|
|
const integer *ncoefv,
|
|
const integer *iordru,
|
|
const integer *iordrv,
|
|
const doublereal *ptclgd,
|
|
doublereal *ptcaux,
|
|
doublereal *ptccan)
|
|
{
|
|
/* System generated locals */
|
|
integer 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 */
|
|
integer 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 : Auxilliary 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_ */
|