mirror of
https://github.com/Open-Cascade-SAS/OCCT.git
synced 2026-05-15 05:28:47 +08:00
11918 lines
318 KiB
C++
Executable File
11918 lines
318 KiB
C++
Executable File
//
|
|
// AdvApp2Var_MathBase.cxx
|
|
//
|
|
#include <math.h>
|
|
#include <AdvApp2Var_SysBase.hxx>
|
|
#include <AdvApp2Var_Data_f2c.hxx>
|
|
#include <AdvApp2Var_MathBase.hxx>
|
|
#include <AdvApp2Var_Data.hxx>
|
|
|
|
// statics
|
|
static
|
|
int mmchole_(integer *mxcoef,
|
|
integer *dimens,
|
|
doublereal *amatri,
|
|
integer *aposit,
|
|
integer *posuiv,
|
|
doublereal *chomat,
|
|
integer *iercod);
|
|
|
|
|
|
|
|
|
|
static
|
|
int mmrslss_(integer *mxcoef,
|
|
integer *dimens,
|
|
doublereal *smatri,
|
|
integer *sposit,
|
|
integer *posuiv,
|
|
doublereal *mscnmbr,
|
|
doublereal *soluti,
|
|
integer *iercod);
|
|
|
|
static
|
|
int mfac_(doublereal *f,
|
|
integer *n);
|
|
|
|
static
|
|
int mmaper0_(integer *ncofmx,
|
|
integer *ndimen,
|
|
integer *ncoeff,
|
|
doublereal *crvlgd,
|
|
integer *ncfnew,
|
|
doublereal *ycvmax,
|
|
doublereal *errmax);
|
|
static
|
|
int mmaper2_(integer *ncofmx,
|
|
integer *ndimen,
|
|
integer *ncoeff,
|
|
doublereal *crvjac,
|
|
integer *ncfnew,
|
|
doublereal *ycvmax,
|
|
doublereal *errmax);
|
|
|
|
static
|
|
int mmaper4_(integer *ncofmx,
|
|
integer *ndimen,
|
|
integer *ncoeff,
|
|
doublereal *crvjac,
|
|
integer *ncfnew,
|
|
doublereal *ycvmax,
|
|
doublereal *errmax);
|
|
|
|
static
|
|
int mmaper6_(integer *ncofmx,
|
|
integer *ndimen,
|
|
integer *ncoeff,
|
|
doublereal *crvjac,
|
|
integer *ncfnew,
|
|
doublereal *ycvmax,
|
|
doublereal *errmax);
|
|
|
|
static
|
|
int mmarc41_(integer *ndimax,
|
|
integer *ndimen,
|
|
integer *ncoeff,
|
|
doublereal *crvold,
|
|
doublereal *upara0,
|
|
doublereal *upara1,
|
|
doublereal *crvnew,
|
|
integer *iercod);
|
|
|
|
static
|
|
int mmatvec_(integer *nligne,
|
|
integer *ncolon,
|
|
integer *gposit,
|
|
integer *gnstoc,
|
|
doublereal *gmatri,
|
|
doublereal *vecin,
|
|
integer *deblig,
|
|
doublereal *vecout,
|
|
integer *iercod);
|
|
|
|
static
|
|
int mmcvstd_(integer *ncofmx,
|
|
integer *ndimax,
|
|
integer *ncoeff,
|
|
integer *ndimen,
|
|
doublereal *crvcan,
|
|
doublereal *courbe);
|
|
|
|
static
|
|
int mmdrvcb_(integer *ideriv,
|
|
integer *ndim,
|
|
integer *ncoeff,
|
|
doublereal *courbe,
|
|
doublereal *tparam,
|
|
doublereal *tabpnt,
|
|
integer *iercod);
|
|
|
|
static
|
|
int mmexthi_(integer *ndegre,
|
|
doublereal *hwgaus);
|
|
|
|
static
|
|
int mmextrl_(integer *ndegre,
|
|
doublereal *rootlg);
|
|
|
|
|
|
|
|
static
|
|
int mmherm0_(doublereal *debfin,
|
|
integer *iercod);
|
|
|
|
static
|
|
int mmherm1_(doublereal *debfin,
|
|
integer *ordrmx,
|
|
integer *iordre,
|
|
doublereal *hermit,
|
|
integer *iercod);
|
|
static
|
|
int mmloncv_(integer *ndimax,
|
|
integer *ndimen,
|
|
integer *ncoeff,
|
|
doublereal *courbe,
|
|
doublereal *tdebut,
|
|
doublereal *tfinal,
|
|
doublereal *xlongc,
|
|
integer *iercod);
|
|
static
|
|
int mmpojac_(doublereal *tparam,
|
|
integer *iordre,
|
|
integer *ncoeff,
|
|
integer *nderiv,
|
|
doublereal *valjac,
|
|
integer *iercod);
|
|
|
|
static
|
|
int mmrslw_(integer *normax,
|
|
integer *nordre,
|
|
integer *ndimen,
|
|
doublereal *epspiv,
|
|
doublereal *abmatr,
|
|
doublereal *xmatri,
|
|
integer *iercod);
|
|
static
|
|
int mmtmave_(integer *nligne,
|
|
integer *ncolon,
|
|
integer *gposit,
|
|
integer *gnstoc,
|
|
doublereal *gmatri,
|
|
doublereal *vecin,
|
|
doublereal *vecout,
|
|
integer *iercod);
|
|
static
|
|
int mmtrpj0_(integer *ncofmx,
|
|
integer *ndimen,
|
|
integer *ncoeff,
|
|
doublereal *epsi3d,
|
|
doublereal *crvlgd,
|
|
doublereal *ycvmax,
|
|
doublereal *epstrc,
|
|
integer *ncfnew);
|
|
static
|
|
int mmtrpj2_(integer *ncofmx,
|
|
integer *ndimen,
|
|
integer *ncoeff,
|
|
doublereal *epsi3d,
|
|
doublereal *crvlgd,
|
|
doublereal *ycvmax,
|
|
doublereal *epstrc,
|
|
integer *ncfnew);
|
|
|
|
static
|
|
int mmtrpj4_(integer *ncofmx,
|
|
integer *ndimen,
|
|
integer *ncoeff,
|
|
doublereal *epsi3d,
|
|
doublereal *crvlgd,
|
|
doublereal *ycvmax,
|
|
doublereal *epstrc,
|
|
integer *ncfnew);
|
|
static
|
|
int mmtrpj6_(integer *ncofmx,
|
|
integer *ndimen,
|
|
integer *ncoeff,
|
|
doublereal *epsi3d,
|
|
doublereal *crvlgd,
|
|
doublereal *ycvmax,
|
|
doublereal *epstrc,
|
|
integer *ncfnew);
|
|
static
|
|
integer pow__ii(integer *x,
|
|
integer *n);
|
|
|
|
static
|
|
int mvcvin2_(integer *ncoeff,
|
|
doublereal *crvold,
|
|
doublereal *crvnew,
|
|
integer *iercod);
|
|
|
|
static
|
|
int mvcvinv_(integer *ncoeff,
|
|
doublereal *crvold,
|
|
doublereal *crvnew,
|
|
integer *iercod);
|
|
|
|
static
|
|
int mvgaus0_(integer *kindic,
|
|
doublereal *urootl,
|
|
doublereal *hiltab,
|
|
integer *nbrval,
|
|
integer *iercod);
|
|
static
|
|
int mvpscr2_(integer *ncoeff,
|
|
doublereal *curve2,
|
|
doublereal *tparam,
|
|
doublereal *pntcrb);
|
|
|
|
static
|
|
int mvpscr3_(integer *ncoeff,
|
|
doublereal *curve2,
|
|
doublereal *tparam,
|
|
doublereal *pntcrb);
|
|
|
|
static struct {
|
|
doublereal eps1, eps2, eps3, eps4;
|
|
integer niterm, niterr;
|
|
} mmprcsn_;
|
|
|
|
static struct {
|
|
doublereal tdebut, tfinal, verifi, cmherm[576];
|
|
} mmcmher_;
|
|
|
|
//=======================================================================
|
|
//function : AdvApp2Var_MathBase::mdsptpt_
|
|
//purpose :
|
|
//=======================================================================
|
|
int AdvApp2Var_MathBase::mdsptpt_(integer *ndimen,
|
|
doublereal *point1,
|
|
doublereal *point2,
|
|
doublereal *distan)
|
|
|
|
{
|
|
static integer c__8 = 8;
|
|
/* System generated locals */
|
|
integer i__1;
|
|
doublereal d__1;
|
|
|
|
/* Local variables */
|
|
static integer i__;
|
|
static doublereal differ[100];
|
|
static integer ier;
|
|
long int iofset, j;
|
|
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* CALCULE LA DISTANCE ENTRE DEUX POINTS */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* DISTANCE,POINT. */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* ------------------ */
|
|
/* NDIMEN: Dimension de l' espace. */
|
|
/* POINT1: Tableau des coordonnees du 1er point. */
|
|
/* POINT2: Tableau des coordonnees du 2eme point. */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* ------------------- */
|
|
/* DISTAN: Distance des 2 points. */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ---------------- */
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* ----------------------- */
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* -------------------------------- */
|
|
/* 21-07-94 : PMN ; La valeur seuil pour alloc passe de 3 a 100 */
|
|
/* 15-07-93 : PMN ; Protection des points... */
|
|
/* 08-09-90 : DHU ; Utilisation de MZSNORM */
|
|
/* 18-07-88 : RBD ; AJOUT D' UN EN TETE STANDARD */
|
|
/* ??-??-?? : XXX ; CREATION */
|
|
/* > */
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* INITIALISATIONS */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* Parameter adjustments */
|
|
--point2;
|
|
--point1;
|
|
|
|
/* Function Body */
|
|
iofset = 0;
|
|
ier = 0;
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* TRAITEMENT */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
if (*ndimen > 100) {
|
|
AdvApp2Var_SysBase::mcrrqst_(&c__8, ndimen, differ, &iofset, &ier);
|
|
}
|
|
|
|
/* --- Si l'allocation est refuse, on applique la methode trivial */
|
|
|
|
if (ier > 0) {
|
|
|
|
*distan = 0.;
|
|
i__1 = *ndimen;
|
|
for (i__ = 1; i__ <= i__1; ++i__) {
|
|
/* Computing 2nd power */
|
|
d__1 = point1[i__] - point2[i__];
|
|
*distan += d__1 * d__1;
|
|
}
|
|
*distan = sqrt(*distan);
|
|
|
|
/* --- Sinon on utilise MZSNORM pour minimiser les risques d'overflow
|
|
*/
|
|
|
|
} else {
|
|
i__1 = *ndimen;
|
|
for (i__ = 1; i__ <= i__1; ++i__) {
|
|
j=iofset + i__ - 1;
|
|
differ[j] = point2[i__] - point1[i__];
|
|
}
|
|
|
|
*distan = AdvApp2Var_MathBase::mzsnorm_(ndimen, &differ[iofset]);
|
|
|
|
}
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* RETOUR PROGRAMME APPELANT */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* --- Desallocation dynamique */
|
|
|
|
if (iofset != 0) {
|
|
AdvApp2Var_SysBase::mcrdelt_(&c__8, ndimen, differ, &iofset, &ier);
|
|
}
|
|
|
|
return 0 ;
|
|
} /* mdsptpt_ */
|
|
|
|
//=======================================================================
|
|
//function : mfac_
|
|
//purpose :
|
|
//=======================================================================
|
|
int mfac_(doublereal *f,
|
|
integer *n)
|
|
|
|
{
|
|
/* System generated locals */
|
|
integer i__1;
|
|
|
|
/* Local variables */
|
|
static integer i__;
|
|
|
|
/* FORTRAN CONFORME AU TEXT */
|
|
/* CALCUL DE MFACTORIEL N */
|
|
/* Parameter adjustments */
|
|
--f;
|
|
|
|
/* Function Body */
|
|
f[1] = (float)1.;
|
|
i__1 = *n;
|
|
for (i__ = 2; i__ <= i__1; ++i__) {
|
|
/* L10: */
|
|
f[i__] = i__ * f[i__ - 1];
|
|
}
|
|
return 0;
|
|
} /* mfac_ */
|
|
|
|
//=======================================================================
|
|
//function : AdvApp2Var_MathBase::mmapcmp_
|
|
//purpose :
|
|
//=======================================================================
|
|
int AdvApp2Var_MathBase::mmapcmp_(integer *ndim,
|
|
integer *ncofmx,
|
|
integer *ncoeff,
|
|
doublereal *crvold,
|
|
doublereal *crvnew)
|
|
|
|
{
|
|
/* System generated locals */
|
|
integer crvold_dim1, crvold_offset, crvnew_dim1, crvnew_offset, i__1,
|
|
i__2;
|
|
|
|
/* Local variables */
|
|
static integer ipair, nd, ndegre, impair, ibb, idg;
|
|
//extern int mgsomsg_();//mgenmsg_(),
|
|
|
|
|
|
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* Compression de la courbe CRVOLD en un tableau comprenant */
|
|
/* les coeff. de rang pair : CRVNEW(*,0,*) */
|
|
/* et de rang impair : CRVNEW(*,1,*). */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* COMPRESSION,COURBE. */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* ------------------ */
|
|
/* NDIM : Dimension de l' espace. */
|
|
/* NCOFMX : Le nbre maximum de coeff. de la courbe a compacter. */
|
|
/* NCOEFF : Le nbre maximum de coeff. de la courbe compactee. */
|
|
/* CRVOLD : La courbe (0:NCOFMX-1,NDIM) a compacter. */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* ------------------- */
|
|
/* CRVNEW : La coube compactee en (0:(NCOEFF-1)/2,0,NDIM) (contenant
|
|
*/
|
|
/* les termes pairs) et en (0:(NCOEFF-1)/2,1,NDIM) */
|
|
/* (contenant les termes impairs). */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ---------------- */
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* ----------------------- */
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
/* Cette routine est utile pour preparer les coefficients d' une */
|
|
/* courbe dans une base orthogonale (Legendre ou Jacobi) avant de */
|
|
/* calculer les coefficients dans la base canonique [-1,1] par */
|
|
/* MMJACAN. */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* -------------------------------- */
|
|
/* 12-04-1989 : RBD ; Creation. */
|
|
/* > */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* Le nom de la routine */
|
|
|
|
/* Parameter adjustments */
|
|
crvold_dim1 = *ncofmx;
|
|
crvold_offset = crvold_dim1;
|
|
crvold -= crvold_offset;
|
|
crvnew_dim1 = (*ncoeff - 1) / 2 + 1;
|
|
crvnew_offset = crvnew_dim1 << 1;
|
|
crvnew -= crvnew_offset;
|
|
|
|
/* Function Body */
|
|
ibb = AdvApp2Var_SysBase::mnfndeb_();
|
|
if (ibb >= 3) {
|
|
AdvApp2Var_SysBase::mgenmsg_("MMAPCMP", 7L);
|
|
}
|
|
|
|
ndegre = *ncoeff - 1;
|
|
i__1 = *ndim;
|
|
for (nd = 1; nd <= i__1; ++nd) {
|
|
ipair = 0;
|
|
i__2 = ndegre / 2;
|
|
for (idg = 0; idg <= i__2; ++idg) {
|
|
crvnew[idg + (nd << 1) * crvnew_dim1] = crvold[ipair + nd *
|
|
crvold_dim1];
|
|
ipair += 2;
|
|
/* L200: */
|
|
}
|
|
if (ndegre < 1) {
|
|
goto L400;
|
|
}
|
|
impair = 1;
|
|
i__2 = (ndegre - 1) / 2;
|
|
for (idg = 0; idg <= i__2; ++idg) {
|
|
crvnew[idg + ((nd << 1) + 1) * crvnew_dim1] = crvold[impair + nd *
|
|
crvold_dim1];
|
|
impair += 2;
|
|
/* L300: */
|
|
}
|
|
|
|
L400:
|
|
/* L100: */
|
|
;
|
|
}
|
|
|
|
/* ---------------------------------- The end ---------------------------
|
|
*/
|
|
|
|
if (ibb >= 3) {
|
|
AdvApp2Var_SysBase::mgsomsg_("MMAPCMP", 7L);
|
|
}
|
|
return 0;
|
|
} /* mmapcmp_ */
|
|
|
|
//=======================================================================
|
|
//function : mmaper0_
|
|
//purpose :
|
|
//=======================================================================
|
|
int mmaper0_(integer *ncofmx,
|
|
integer *ndimen,
|
|
integer *ncoeff,
|
|
doublereal *crvlgd,
|
|
integer *ncfnew,
|
|
doublereal *ycvmax,
|
|
doublereal *errmax)
|
|
|
|
{
|
|
/* System generated locals */
|
|
integer crvlgd_dim1, crvlgd_offset, i__1, i__2;
|
|
doublereal d__1;
|
|
|
|
/* Local variables */
|
|
static integer ncut;
|
|
static doublereal bidon;
|
|
static integer ii, nd;
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* Calcule l' erreur d' approximation maxi faite lorsque l' on */
|
|
/* ne conserve que les premiers NCFNEW coefficients d' une courbe
|
|
*/
|
|
/* de degre NCOEFF-1 ecrite dans la base de Legendre (Jacobi */
|
|
/* d' ordre 0). */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* LEGENDRE,POLYGONE,APPROXIMATION,ERREUR. */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* ------------------ */
|
|
/* NCOFMX : Degre maximum de la courbe. */
|
|
/* NDIMEN : Dimension de l' espace. */
|
|
/* NCOEFF : Le degre +1 de la courbe. */
|
|
/* CRVLGD : La courbe dont on veut baisser le degre. */
|
|
/* NCFNEW : Le degre +1 du polynome resultat. */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* ------------------- */
|
|
/* YCVMAX : Tableau auxiliaire (erreur max sur chaque dimension).
|
|
*/
|
|
/* ERRMAX : La precision de l' approximation. */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ---------------- */
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* ----------------------- */
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* -------------------------------- */
|
|
/* 08-08-1991: RBD; Creation. */
|
|
/* > */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
|
|
/* ------------------- Init pour calcul d' erreur -----------------------
|
|
*/
|
|
|
|
/* Parameter adjustments */
|
|
--ycvmax;
|
|
crvlgd_dim1 = *ncofmx;
|
|
crvlgd_offset = crvlgd_dim1 + 1;
|
|
crvlgd -= crvlgd_offset;
|
|
|
|
/* Function Body */
|
|
i__1 = *ndimen;
|
|
for (ii = 1; ii <= i__1; ++ii) {
|
|
ycvmax[ii] = 0.;
|
|
/* L100: */
|
|
}
|
|
|
|
/* ------ Degre minimum pouvant etre atteint : Arret a 1 ou NCFNEW ------
|
|
*/
|
|
|
|
ncut = 1;
|
|
if (*ncfnew + 1 > ncut) {
|
|
ncut = *ncfnew + 1;
|
|
}
|
|
|
|
/* -------------- Elimination des coefficients de haut degre -----------
|
|
*/
|
|
/* ----------- Boucle sur la serie de Legendre: NCUT --> NCOEFF --------
|
|
*/
|
|
|
|
i__1 = *ncoeff;
|
|
for (ii = ncut; ii <= i__1; ++ii) {
|
|
/* Facteur de renormalisation (Maximum de Li(t)). */
|
|
bidon = ((ii - 1) * 2. + 1.) / 2.;
|
|
bidon = sqrt(bidon);
|
|
|
|
i__2 = *ndimen;
|
|
for (nd = 1; nd <= i__2; ++nd) {
|
|
ycvmax[nd] += (d__1 = crvlgd[ii + nd * crvlgd_dim1], abs(d__1)) *
|
|
bidon;
|
|
/* L310: */
|
|
}
|
|
/* L300: */
|
|
}
|
|
|
|
/* -------------- L'erreur est la norme du vecteur erreur ---------------
|
|
*/
|
|
|
|
*errmax = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
|
|
|
|
/* --------------------------------- Fin --------------------------------
|
|
*/
|
|
|
|
return 0;
|
|
} /* mmaper0_ */
|
|
|
|
//=======================================================================
|
|
//function : mmaper2_
|
|
//purpose :
|
|
//=======================================================================
|
|
int mmaper2_(integer *ncofmx,
|
|
integer *ndimen,
|
|
integer *ncoeff,
|
|
doublereal *crvjac,
|
|
integer *ncfnew,
|
|
doublereal *ycvmax,
|
|
doublereal *errmax)
|
|
|
|
{
|
|
/* Initialized data */
|
|
|
|
static doublereal xmaxj[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 };
|
|
|
|
/* System generated locals */
|
|
integer crvjac_dim1, crvjac_offset, i__1, i__2;
|
|
doublereal d__1;
|
|
|
|
/* Local variables */
|
|
static integer idec, ncut;
|
|
static doublereal bidon;
|
|
static integer ii, nd;
|
|
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* Calcule l' erreur d' approximation maxi faite lorsque l' on */
|
|
/* ne conserve que les premiers NCFNEW coefficients d' une courbe
|
|
*/
|
|
/* de degre NCOEFF-1 ecrite dans la base de Jacobi d' ordre 2. */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* JACOBI,POLYGONE,APPROXIMATION,ERREUR. */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* ------------------ */
|
|
/* NCOFMX : Degre maximum de la courbe. */
|
|
/* NDIMEN : Dimension de l' espace. */
|
|
/* NCOEFF : Le degre +1 de la courbe. */
|
|
/* CRVJAC : La courbe dont on veut baisser le degre. */
|
|
/* NCFNEW : Le degre +1 du polynome resultat. */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* ------------------- */
|
|
/* YCVMAX : Tableau auxiliaire (erreur max sur chaque dimension).
|
|
*/
|
|
/* ERRMAX : La precision de l' approximation. */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ---------------- */
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* ----------------------- */
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* -------------------------------- */
|
|
/* 12-02-1992: RBD; Correction d'indice de lecture de XMAXJ */
|
|
/* 08-08-1991: RBD; Creation. */
|
|
/* > */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
|
|
/* ------------------ Table des maximums de (1-t2)*Ji(t) ----------------
|
|
*/
|
|
|
|
/* Parameter adjustments */
|
|
--ycvmax;
|
|
crvjac_dim1 = *ncofmx;
|
|
crvjac_offset = crvjac_dim1 + 1;
|
|
crvjac -= crvjac_offset;
|
|
|
|
/* Function Body */
|
|
|
|
|
|
|
|
/* ------------------- Init pour calcul d' erreur -----------------------
|
|
*/
|
|
|
|
i__1 = *ndimen;
|
|
for (ii = 1; ii <= i__1; ++ii) {
|
|
ycvmax[ii] = 0.;
|
|
/* L100: */
|
|
}
|
|
|
|
/* ------ Degre minimum pouvant etre atteint : Arret a 3 ou NCFNEW ------
|
|
*/
|
|
|
|
idec = 3;
|
|
/* Computing MAX */
|
|
i__1 = idec, i__2 = *ncfnew + 1;
|
|
ncut = max(i__1,i__2);
|
|
|
|
/* -------------- Elimination des coefficients de haut degre -----------
|
|
*/
|
|
/* ----------- Boucle sur la serie de Jacobi :NCUT --> NCOEFF ----------
|
|
*/
|
|
|
|
i__1 = *ncoeff;
|
|
for (ii = ncut; ii <= i__1; ++ii) {
|
|
/* Facteur de renormalisation. */
|
|
bidon = xmaxj[ii - idec];
|
|
i__2 = *ndimen;
|
|
for (nd = 1; nd <= i__2; ++nd) {
|
|
ycvmax[nd] += (d__1 = crvjac[ii + nd * crvjac_dim1], abs(d__1)) *
|
|
bidon;
|
|
/* L310: */
|
|
}
|
|
/* L300: */
|
|
}
|
|
|
|
/* -------------- L'erreur est la norme du vecteur erreur ---------------
|
|
*/
|
|
|
|
*errmax = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
|
|
|
|
/* --------------------------------- Fin --------------------------------
|
|
*/
|
|
|
|
return 0;
|
|
} /* mmaper2_ */
|
|
|
|
/* MAPER4.f -- translated by f2c (version 19960827).
|
|
You must link the resulting object file with the libraries:
|
|
-lf2c -lm (in that order)
|
|
*/
|
|
|
|
/* Subroutine */
|
|
//=======================================================================
|
|
//function : mmaper4_
|
|
//purpose :
|
|
//=======================================================================
|
|
int mmaper4_(integer *ncofmx,
|
|
integer *ndimen,
|
|
integer *ncoeff,
|
|
doublereal *crvjac,
|
|
integer *ncfnew,
|
|
doublereal *ycvmax,
|
|
doublereal *errmax)
|
|
{
|
|
/* Initialized data */
|
|
|
|
static doublereal xmaxj[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 };
|
|
|
|
/* System generated locals */
|
|
integer crvjac_dim1, crvjac_offset, i__1, i__2;
|
|
doublereal d__1;
|
|
|
|
/* Local variables */
|
|
static integer idec, ncut;
|
|
static doublereal bidon;
|
|
static integer ii, nd;
|
|
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* Calcule l' erreur d' approximation maxi faite lorsque l' on */
|
|
/* ne conserve que les premiers NCFNEW coefficients d' une courbe
|
|
*/
|
|
/* de degre NCOEFF-1 ecrite dans la base de Jacobi d' ordre 4. */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* JACOBI,POLYGONE,APPROXIMATION,ERREUR. */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* ------------------ */
|
|
/* NCOFMX : Degre maximum de la courbe. */
|
|
/* NDIMEN : Dimension de l' espace. */
|
|
/* NCOEFF : Le degre +1 de la courbe. */
|
|
/* CRVJAC : La courbe dont on veut baisser le degre. */
|
|
/* NCFNEW : Le degre +1 du polynome resultat. */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* ------------------- */
|
|
/* YCVMAX : Tableau auxiliaire (erreur max sur chaque dimension).
|
|
*/
|
|
/* ERRMAX : La precision de l' approximation. */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ---------------- */
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* ----------------------- */
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* -------------------------------- */
|
|
/* 12-02-1992: RBD; Correction d'indice de lecture de XMAXJ */
|
|
/* 08-08-1991: RBD; Creation. */
|
|
/* > */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
|
|
/* ---------------- Table des maximums de ((1-t2)2)*Ji(t) ---------------
|
|
*/
|
|
|
|
/* Parameter adjustments */
|
|
--ycvmax;
|
|
crvjac_dim1 = *ncofmx;
|
|
crvjac_offset = crvjac_dim1 + 1;
|
|
crvjac -= crvjac_offset;
|
|
|
|
/* Function Body */
|
|
|
|
|
|
|
|
/* ------------------- Init pour calcul d' erreur -----------------------
|
|
*/
|
|
|
|
i__1 = *ndimen;
|
|
for (ii = 1; ii <= i__1; ++ii) {
|
|
ycvmax[ii] = 0.;
|
|
/* L100: */
|
|
}
|
|
|
|
/* ------ Degre minimum pouvant etre atteint : Arret a 5 ou NCFNEW ------
|
|
*/
|
|
|
|
idec = 5;
|
|
/* Computing MAX */
|
|
i__1 = idec, i__2 = *ncfnew + 1;
|
|
ncut = max(i__1,i__2);
|
|
|
|
/* -------------- Elimination des coefficients de haut degre -----------
|
|
*/
|
|
/* ----------- Boucle sur la serie de Jacobi :NCUT --> NCOEFF ----------
|
|
*/
|
|
|
|
i__1 = *ncoeff;
|
|
for (ii = ncut; ii <= i__1; ++ii) {
|
|
/* Facteur de renormalisation. */
|
|
bidon = xmaxj[ii - idec];
|
|
i__2 = *ndimen;
|
|
for (nd = 1; nd <= i__2; ++nd) {
|
|
ycvmax[nd] += (d__1 = crvjac[ii + nd * crvjac_dim1], abs(d__1)) *
|
|
bidon;
|
|
/* L310: */
|
|
}
|
|
/* L300: */
|
|
}
|
|
|
|
/* -------------- L'erreur est la norme du vecteur erreur ---------------
|
|
*/
|
|
|
|
*errmax = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
|
|
|
|
/* --------------------------------- Fin --------------------------------
|
|
*/
|
|
|
|
return 0;
|
|
} /* mmaper4_ */
|
|
|
|
//=======================================================================
|
|
//function : mmaper6_
|
|
//purpose :
|
|
//=======================================================================
|
|
int mmaper6_(integer *ncofmx,
|
|
integer *ndimen,
|
|
integer *ncoeff,
|
|
doublereal *crvjac,
|
|
integer *ncfnew,
|
|
doublereal *ycvmax,
|
|
doublereal *errmax)
|
|
|
|
{
|
|
/* Initialized data */
|
|
|
|
static doublereal xmaxj[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 crvjac_dim1, crvjac_offset, i__1, i__2;
|
|
doublereal d__1;
|
|
|
|
/* Local variables */
|
|
static integer idec, ncut;
|
|
static doublereal bidon;
|
|
static integer ii, nd;
|
|
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* Calcule l' erreur d' approximation maxi faite lorsque l' on */
|
|
/* ne conserve que les premiers NCFNEW coefficients d' une courbe
|
|
*/
|
|
/* de degre NCOEFF-1 ecrite dans la base de Jacobi d' ordre 6. */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* JACOBI,POLYGONE,APPROXIMATION,ERREUR. */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* ------------------ */
|
|
/* NCOFMX : Degre maximum de la courbe. */
|
|
/* NDIMEN : Dimension de l' espace. */
|
|
/* NCOEFF : Le degre +1 de la courbe. */
|
|
/* CRVJAC : La courbe dont on veut baisser le degre. */
|
|
/* NCFNEW : Le degre +1 du polynome resultat. */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* ------------------- */
|
|
/* YCVMAX : Tableau auxiliaire (erreur max sur chaque dimension).
|
|
*/
|
|
/* ERRMAX : La precision de l' approximation. */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ---------------- */
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* ----------------------- */
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* -------------------------------- */
|
|
/* 12-02-1992: RBD; Correction d'indice de lecture de XMAXJ */
|
|
/* 08-08-1991: RBD; Creation. */
|
|
/* > */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
|
|
/* ---------------- Table des maximums de ((1-t2)3)*Ji(t) ---------------
|
|
*/
|
|
|
|
/* Parameter adjustments */
|
|
--ycvmax;
|
|
crvjac_dim1 = *ncofmx;
|
|
crvjac_offset = crvjac_dim1 + 1;
|
|
crvjac -= crvjac_offset;
|
|
|
|
/* Function Body */
|
|
|
|
|
|
|
|
/* ------------------- Init pour calcul d' erreur -----------------------
|
|
*/
|
|
|
|
i__1 = *ndimen;
|
|
for (ii = 1; ii <= i__1; ++ii) {
|
|
ycvmax[ii] = 0.;
|
|
/* L100: */
|
|
}
|
|
|
|
/* ------ Degre minimum pouvant etre atteint : Arret a 3 ou NCFNEW ------
|
|
*/
|
|
|
|
idec = 7;
|
|
/* Computing MAX */
|
|
i__1 = idec, i__2 = *ncfnew + 1;
|
|
ncut = max(i__1,i__2);
|
|
|
|
/* -------------- Elimination des coefficients de haut degre -----------
|
|
*/
|
|
/* ----------- Boucle sur la serie de Jacobi :NCUT --> NCOEFF ----------
|
|
*/
|
|
|
|
i__1 = *ncoeff;
|
|
for (ii = ncut; ii <= i__1; ++ii) {
|
|
/* Facteur de renormalisation. */
|
|
bidon = xmaxj[ii - idec];
|
|
i__2 = *ndimen;
|
|
for (nd = 1; nd <= i__2; ++nd) {
|
|
ycvmax[nd] += (d__1 = crvjac[ii + nd * crvjac_dim1], abs(d__1)) *
|
|
bidon;
|
|
/* L310: */
|
|
}
|
|
/* L300: */
|
|
}
|
|
|
|
/* -------------- L'erreur est la norme du vecteur erreur ---------------
|
|
*/
|
|
|
|
*errmax = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
|
|
|
|
/* --------------------------------- Fin --------------------------------
|
|
*/
|
|
|
|
return 0;
|
|
} /* mmaper6_ */
|
|
|
|
//=======================================================================
|
|
//function : AdvApp2Var_MathBase::mmaperx_
|
|
//purpose :
|
|
//=======================================================================
|
|
int AdvApp2Var_MathBase::mmaperx_(integer *ncofmx,
|
|
integer *ndimen,
|
|
integer *ncoeff,
|
|
integer *iordre,
|
|
doublereal *crvjac,
|
|
integer *ncfnew,
|
|
doublereal *ycvmax,
|
|
doublereal *errmax,
|
|
integer *iercod)
|
|
|
|
{
|
|
/* System generated locals */
|
|
integer crvjac_dim1, crvjac_offset;
|
|
|
|
/* Local variables */
|
|
static integer jord;
|
|
|
|
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* Calcule l' erreur d' approximation maxi faite lorsque l' on */
|
|
/* ne conserve que les premiers NCFNEW coefficients d' une courbe
|
|
*/
|
|
/* de degre NCOEFF-1 ecrite dans la base de Jacobi d' ordre */
|
|
/* IORDRE. */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* JACOBI,LEGENDRE,POLYGONE,APPROXIMATION,ERREUR. */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* ------------------ */
|
|
/* NCOFMX : Degre maximum de la courbe. */
|
|
/* NDIMEN : Dimension de l' espace. */
|
|
/* NCOEFF : Le degre +1 de la courbe. */
|
|
/* IORDRE : Ordre de continuite aux extremites. */
|
|
/* CRVJAC : La courbe dont on veut baisser le degre. */
|
|
/* NCFNEW : Le degre +1 du polynome resultat. */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* ------------------- */
|
|
/* YCVMAX : Tableau auxiliaire. */
|
|
/* ERRMAX : La precision de l' approximation. */
|
|
/* IERCOD = 0, OK */
|
|
/* = 1, L'ordre des contraintes (IORDRE) n'est pas dans */
|
|
/* les valeurs autorisees. */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ---------------- */
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* ----------------------- */
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
/* Annule et remplace MMAPERR. */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* -------------------------------- */
|
|
/* 08-08-91: RBD; Creation d'apres MMAPERR, utilisation des nouveaux
|
|
*/
|
|
/* majorants, appel aux MMAPER0, 2, 4 et 6. */
|
|
/* > */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
|
|
/* Parameter adjustments */
|
|
--ycvmax;
|
|
crvjac_dim1 = *ncofmx;
|
|
crvjac_offset = crvjac_dim1 + 1;
|
|
crvjac -= crvjac_offset;
|
|
|
|
/* Function Body */
|
|
*iercod = 0;
|
|
/* --> L'ordre des polynomes de Jacobi */
|
|
jord = ( *iordre + 1) << 1;
|
|
|
|
if (jord == 0) {
|
|
mmaper0_(ncofmx, ndimen, ncoeff, &crvjac[crvjac_offset], ncfnew, &
|
|
ycvmax[1], errmax);
|
|
} else if (jord == 2) {
|
|
mmaper2_(ncofmx, ndimen, ncoeff, &crvjac[crvjac_offset], ncfnew, &
|
|
ycvmax[1], errmax);
|
|
} else if (jord == 4) {
|
|
mmaper4_(ncofmx, ndimen, ncoeff, &crvjac[crvjac_offset], ncfnew, &
|
|
ycvmax[1], errmax);
|
|
} else if (jord == 6) {
|
|
mmaper6_(ncofmx, ndimen, ncoeff, &crvjac[crvjac_offset], ncfnew, &
|
|
ycvmax[1], errmax);
|
|
} else {
|
|
*iercod = 1;
|
|
}
|
|
|
|
/* ----------------------------------- Fin ------------------------------
|
|
*/
|
|
|
|
return 0;
|
|
} /* mmaperx_ */
|
|
|
|
//=======================================================================
|
|
//function : mmarc41_
|
|
//purpose :
|
|
//=======================================================================
|
|
int mmarc41_(integer *ndimax,
|
|
integer *ndimen,
|
|
integer *ncoeff,
|
|
doublereal *crvold,
|
|
doublereal *upara0,
|
|
doublereal *upara1,
|
|
doublereal *crvnew,
|
|
integer *iercod)
|
|
|
|
{
|
|
/* System generated locals */
|
|
integer crvold_dim1, crvold_offset, crvnew_dim1, crvnew_offset, i__1,
|
|
i__2, i__3;
|
|
|
|
/* Local variables */
|
|
static integer nboct;
|
|
static doublereal tbaux[61];
|
|
static integer nd;
|
|
static doublereal bid;
|
|
static integer ncf, ncj;
|
|
|
|
|
|
/* IMPLICIT DOUBLE PRECISION(A-H,O-Z) */
|
|
/* IMPLICIT INTEGER (I-N) */
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* Creation de la courbe C2(v) definie sur (0,1) identique a la */
|
|
/* courbe C1(u) definie sur (U0,U1) (changement du parametre d' une */
|
|
/* courbe). */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* LIMITATION, RESTRICTION, COURBE */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* ------------------ */
|
|
/* NDIMAX : Dimensionnement de l' espace. */
|
|
/* NDIMEN : Dimension de la courbe. */
|
|
/* NCOEFF : Nbre de coefficients de la courbe. */
|
|
/* CRVOLD : La courbe a limiter. */
|
|
/* UPARA0 : Borne min de l' intervalle de restriction de la courbe.
|
|
*/
|
|
/* UPARA1 : Borne max de l' intervalle de restriction de la courbe.
|
|
*/
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* ------------------- */
|
|
/* CRVNEW : La courbe relimitee, definie dans (0,1) et egale a */
|
|
/* CRVOLD definie dans (U0,U1). */
|
|
/* IERCOD : = 0, OK */
|
|
/* =10, Nbre de coeff. <1 ou > 61. */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ---------------- */
|
|
|
|
/* .Neant. */
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* ---------------------- */
|
|
/* Type Name */
|
|
/* MAERMSG MCRFILL MVCVIN2 */
|
|
/* MVCVINV */
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
/* ---> L' algorithme employe dans le cas general est base sur le */
|
|
/* principe suivant : */
|
|
/* Soient S(t) = a0 + a1*t + a2*t**2 + ... de degre NCOEFF-1, et */
|
|
/* U(t) = b0 + b1*t, on calcule alors les coeff. de */
|
|
/* S(U(t)) de proche en proche a l' aide du tableau TBAUX. */
|
|
/* A chaque etape numero N (N=2 a NCOEFF), TBAUX(n) contient le */
|
|
/* n-ieme coefficient de U(t)**N pour n=1 a N. (RBD) */
|
|
/* ---> Reference : KNUTH, 'The Art of Computer Programming', */
|
|
/* Vol. 2/'Seminumerical Algorithms', */
|
|
/* Ex. 11 p:451 et solution p:562. (RBD) */
|
|
|
|
/* ---> L' ecrasement de l' argument d' entree CRVOLD par CRVNEW est */
|
|
/* possible, c' est a dire que l' appel : */
|
|
/* CALL MMARC41(NDIMAX,NDIMEN,NCOEFF,CURVE,UPARA0,UPARA1 */
|
|
/* ,CURVE,IERCOD) */
|
|
/* est tout a fait LEGAL. (RBD) */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* -------------------------------- */
|
|
/* 18-09-1995 : JMF ; Verfor + implicit none */
|
|
/* 18-10-88 : RBD ; Documentation de la FONCTION. */
|
|
/* 24-06-88 : RBD ; Refonte totale du code pour le cas general : */
|
|
/* optimisation et suppression du commun des CNP */
|
|
/* qui ne sert plus. */
|
|
/* 22-06-88 : NAK ; TRAITEMENT DES CAS PARTICULIERS SIMPLES ET */
|
|
/* FREQUENTS. */
|
|
/* 22-02-1988 : JJM ; Appel MFNDEB -> MNFNDEB. */
|
|
/* 22-02-1988 : JJM ; Appel GERMSG -> MAERMSG. */
|
|
/* 26-07-1985 : Remplacement de CAUX par CRVNEW, ajout du */
|
|
/* common MBLANK. */
|
|
/* 28-11-1985 : Creation JJM (NDIMAX en plus). */
|
|
|
|
/* > */
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
/* Le nom de la routine */
|
|
|
|
/* Tableau auxiliaire des coefficients de (UPARA1-UPARA0)T+UPARA0 a */
|
|
/* la puissance N=1 a NCOEFF-1. */
|
|
|
|
|
|
/* Parameter adjustments */
|
|
crvnew_dim1 = *ndimax;
|
|
crvnew_offset = crvnew_dim1 + 1;
|
|
crvnew -= crvnew_offset;
|
|
crvold_dim1 = *ndimax;
|
|
crvold_offset = crvold_dim1 + 1;
|
|
crvold -= crvold_offset;
|
|
|
|
/* Function Body */
|
|
*iercod = 0;
|
|
/* **********************************************************************
|
|
*/
|
|
/* CAS OU LE TRAITEMENT NE PEUT ETRE FAIT */
|
|
/* **********************************************************************
|
|
*/
|
|
if (*ncoeff > 61 || *ncoeff < 1) {
|
|
*iercod = 10;
|
|
goto L9999;
|
|
}
|
|
/* **********************************************************************
|
|
*/
|
|
/* SI PAS DE CHANGEMENT */
|
|
/* **********************************************************************
|
|
*/
|
|
if (*ndimen == *ndimax && *upara0 == 0. && *upara1 == 1.) {
|
|
nboct = (*ndimax << 3) * *ncoeff;
|
|
AdvApp2Var_SysBase::mcrfill_((integer *)&nboct,
|
|
(char *)&crvold[crvold_offset],
|
|
(char *)&crvnew[crvnew_offset]);
|
|
goto L9999;
|
|
}
|
|
/* **********************************************************************
|
|
*/
|
|
/* INVERSION 3D : TRAITEMENT RAPIDE */
|
|
/* **********************************************************************
|
|
*/
|
|
if (*upara0 == 1. && *upara1 == 0.) {
|
|
if (*ndimen == 3 && *ndimax == 3 && *ncoeff <= 21) {
|
|
mvcvinv_(ncoeff, &crvold[crvold_offset], &crvnew[crvnew_offset],
|
|
iercod);
|
|
goto L9999;
|
|
}
|
|
/* ******************************************************************
|
|
**** */
|
|
/* INVERSION 2D : TRAITEMENT RAPIDE */
|
|
/* ******************************************************************
|
|
**** */
|
|
if (*ndimen == 2 && *ndimax == 2 && *ncoeff <= 21) {
|
|
mvcvin2_(ncoeff, &crvold[crvold_offset], &crvnew[crvnew_offset],
|
|
iercod);
|
|
goto L9999;
|
|
}
|
|
}
|
|
/* **********************************************************************
|
|
*/
|
|
/* TRAITEMENT GENERAL */
|
|
/* **********************************************************************
|
|
*/
|
|
/* -------------------------- Initialisations ---------------------------
|
|
*/
|
|
|
|
i__1 = *ndimen;
|
|
for (nd = 1; nd <= i__1; ++nd) {
|
|
crvnew[nd + crvnew_dim1] = crvold[nd + crvold_dim1];
|
|
/* L100: */
|
|
}
|
|
if (*ncoeff == 1) {
|
|
goto L9999;
|
|
}
|
|
tbaux[0] = *upara0;
|
|
tbaux[1] = *upara1 - *upara0;
|
|
|
|
/* ----------------------- Calcul des coeff. de CRVNEW ------------------
|
|
*/
|
|
|
|
i__1 = *ncoeff - 1;
|
|
for (ncf = 2; ncf <= i__1; ++ncf) {
|
|
|
|
/* ------------ Prise en compte du NCF-ieme coeff. de CRVOLD --------
|
|
---- */
|
|
|
|
i__2 = ncf - 1;
|
|
for (ncj = 1; ncj <= i__2; ++ncj) {
|
|
bid = tbaux[ncj - 1];
|
|
i__3 = *ndimen;
|
|
for (nd = 1; nd <= i__3; ++nd) {
|
|
crvnew[nd + ncj * crvnew_dim1] += crvold[nd + ncf *
|
|
crvold_dim1] * bid;
|
|
/* L400: */
|
|
}
|
|
/* L300: */
|
|
}
|
|
|
|
bid = tbaux[ncf - 1];
|
|
i__2 = *ndimen;
|
|
for (nd = 1; nd <= i__2; ++nd) {
|
|
crvnew[nd + ncf * crvnew_dim1] = crvold[nd + ncf * crvold_dim1] *
|
|
bid;
|
|
/* L500: */
|
|
}
|
|
|
|
/* --------- Calcul des (NCF+1) coeff. de ((U1-U0)*t + U0)**(NCF) ---
|
|
---- */
|
|
|
|
bid = *upara1 - *upara0;
|
|
tbaux[ncf] = tbaux[ncf - 1] * bid;
|
|
for (ncj = ncf; ncj >= 2; --ncj) {
|
|
tbaux[ncj - 1] = tbaux[ncj - 1] * *upara0 + tbaux[ncj - 2] * bid;
|
|
/* L600: */
|
|
}
|
|
tbaux[0] *= *upara0;
|
|
|
|
/* L200: */
|
|
}
|
|
|
|
/* -------------- Prise en compte du dernier coeff. de CRVOLD -----------
|
|
*/
|
|
|
|
i__1 = *ncoeff - 1;
|
|
for (ncj = 1; ncj <= i__1; ++ncj) {
|
|
bid = tbaux[ncj - 1];
|
|
i__2 = *ndimen;
|
|
for (nd = 1; nd <= i__2; ++nd) {
|
|
crvnew[nd + ncj * crvnew_dim1] += crvold[nd + *ncoeff *
|
|
crvold_dim1] * bid;
|
|
/* L800: */
|
|
}
|
|
/* L700: */
|
|
}
|
|
i__1 = *ndimen;
|
|
for (nd = 1; nd <= i__1; ++nd) {
|
|
crvnew[nd + *ncoeff * crvnew_dim1] = crvold[nd + *ncoeff *
|
|
crvold_dim1] * tbaux[*ncoeff - 1];
|
|
/* L900: */
|
|
}
|
|
|
|
/* ---------------------------- The end ---------------------------------
|
|
*/
|
|
|
|
L9999:
|
|
if (*iercod != 0) {
|
|
AdvApp2Var_SysBase::maermsg_("MMARC41", iercod, 7L);
|
|
}
|
|
|
|
return 0 ;
|
|
} /* mmarc41_ */
|
|
|
|
//=======================================================================
|
|
//function : AdvApp2Var_MathBase::mmarcin_
|
|
//purpose :
|
|
//=======================================================================
|
|
int AdvApp2Var_MathBase::mmarcin_(integer *ndimax,
|
|
integer *ndim,
|
|
integer *ncoeff,
|
|
doublereal *crvold,
|
|
doublereal *u0,
|
|
doublereal *u1,
|
|
doublereal *crvnew,
|
|
integer *iercod)
|
|
|
|
{
|
|
/* System generated locals */
|
|
integer crvold_dim1, crvold_offset, crvnew_dim1, crvnew_offset, i__1,
|
|
i__2, i__3;
|
|
doublereal d__1;
|
|
|
|
/* Local variables */
|
|
static doublereal x0, x1;
|
|
static integer nd;
|
|
static doublereal tabaux[61];
|
|
static integer ibb;
|
|
static doublereal bid;
|
|
static integer ncf;
|
|
static integer ncj;
|
|
static doublereal eps3;
|
|
|
|
|
|
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* Creation de la courbe C2(v) definie sur [U0,U1] identique a */
|
|
/* la courbe C1(u) definie sur [-1,1] (changement du parametre */
|
|
/* d' une courbe) avec INVERSION des indices du tableau resultat. */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* LIMITATION GENERALISEE,RESTRICTION,INVERSION,COURBE */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* ------------------ */
|
|
/* NDIMAX : Dimensionnement maximal de l' espace. */
|
|
/* NDIM : Dimension de la courbe. */
|
|
/* NCOEFF : Nbre de coefficients de la courbe. */
|
|
/* CRVOLD : La courbe a limiter. */
|
|
/* U0 : Borne min de l' intervalle de restriction de la courbe. */
|
|
/* U1 : Borne max de l' intervalle de restriction de la courbe. */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* ------------------- */
|
|
/* CRVNEW : La courbe relimitee, definie dans [U0,U1] et egale a */
|
|
/* CRVOLD definie dans [-1,1]. */
|
|
/* IERCOD : = 0, OK */
|
|
/* =10, Nbre de coeff. <1 ou > 61. */
|
|
/* =13, L' intervalle de variation demande est nul. */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ---------------- */
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* ----------------------- */
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* -------------------------------- */
|
|
/* 21-11-1989 : RBD ; Correction Trait. general parametre X1. */
|
|
/* 12-04-1989 : RBD ; Creation d' apres MMARC41. */
|
|
/* > */
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
/* Le nom de la routine */
|
|
|
|
/* Tableau auxiliaire des coefficients de X1*T+X0 a */
|
|
/* la puissance N=1 a NCOEFF-1. */
|
|
|
|
|
|
/* Parameter adjustments */
|
|
crvnew_dim1 = *ndimax;
|
|
crvnew_offset = crvnew_dim1 + 1;
|
|
crvnew -= crvnew_offset;
|
|
crvold_dim1 = *ncoeff;
|
|
crvold_offset = crvold_dim1 + 1;
|
|
crvold -= crvold_offset;
|
|
|
|
/* Function Body */
|
|
ibb = AdvApp2Var_SysBase::mnfndeb_();
|
|
if (ibb >= 2) {
|
|
AdvApp2Var_SysBase::mgenmsg_("MMARCIN", 7L);
|
|
}
|
|
|
|
/* On teste au zero machine que l' intervalle d' arrivee n' est pas nul */
|
|
|
|
AdvApp2Var_MathBase::mmveps3_(&eps3);
|
|
if ((d__1 = *u1 - *u0, abs(d__1)) < eps3) {
|
|
*iercod = 13;
|
|
goto L9999;
|
|
}
|
|
*iercod = 0;
|
|
|
|
/* **********************************************************************
|
|
*/
|
|
/* CAS OU LE TRAITEMENT NE PEUT ETRE FAIT */
|
|
/* **********************************************************************
|
|
*/
|
|
if (*ncoeff > 61 || *ncoeff < 1) {
|
|
*iercod = 10;
|
|
goto L9999;
|
|
}
|
|
/* **********************************************************************
|
|
*/
|
|
/* SI PAS DE CHANGEMENT DE L' INTERVALLE DE DEFINITION */
|
|
/* (SEULEMENT INVERSION DES INDICES DU TABLEAU CRVOLD) */
|
|
/* **********************************************************************
|
|
*/
|
|
if (*ndim == *ndimax && *u0 == -1. && *u1 == 1.) {
|
|
AdvApp2Var_MathBase::mmcvinv_(ndim, ncoeff, ndim, &crvold[crvold_offset], &crvnew[
|
|
crvnew_offset]);
|
|
goto L9999;
|
|
}
|
|
/* **********************************************************************
|
|
*/
|
|
/* CAS OU LE NOUVEL INTERVALLE DE DEFINITION EST [0,1] */
|
|
/* **********************************************************************
|
|
*/
|
|
if (*u0 == 0. && *u1 == 1.) {
|
|
mmcvstd_(ncoeff, ndimax, ncoeff, ndim, &crvold[crvold_offset], &
|
|
crvnew[crvnew_offset]);
|
|
goto L9999;
|
|
}
|
|
/* **********************************************************************
|
|
*/
|
|
/* TRAITEMENT GENERAL */
|
|
/* **********************************************************************
|
|
*/
|
|
/* -------------------------- Initialisations ---------------------------
|
|
*/
|
|
|
|
x0 = -(*u1 + *u0) / (*u1 - *u0);
|
|
x1 = 2. / (*u1 - *u0);
|
|
i__1 = *ndim;
|
|
for (nd = 1; nd <= i__1; ++nd) {
|
|
crvnew[nd + crvnew_dim1] = crvold[nd * crvold_dim1 + 1];
|
|
/* L100: */
|
|
}
|
|
if (*ncoeff == 1) {
|
|
goto L9999;
|
|
}
|
|
tabaux[0] = x0;
|
|
tabaux[1] = x1;
|
|
|
|
/* ----------------------- Calcul des coeff. de CRVNEW ------------------
|
|
*/
|
|
|
|
i__1 = *ncoeff - 1;
|
|
for (ncf = 2; ncf <= i__1; ++ncf) {
|
|
|
|
/* ------------ Prise en compte du NCF-ieme coeff. de CRVOLD --------
|
|
---- */
|
|
|
|
i__2 = ncf - 1;
|
|
for (ncj = 1; ncj <= i__2; ++ncj) {
|
|
bid = tabaux[ncj - 1];
|
|
i__3 = *ndim;
|
|
for (nd = 1; nd <= i__3; ++nd) {
|
|
crvnew[nd + ncj * crvnew_dim1] += crvold[ncf + nd *
|
|
crvold_dim1] * bid;
|
|
/* L400: */
|
|
}
|
|
/* L300: */
|
|
}
|
|
|
|
bid = tabaux[ncf - 1];
|
|
i__2 = *ndim;
|
|
for (nd = 1; nd <= i__2; ++nd) {
|
|
crvnew[nd + ncf * crvnew_dim1] = crvold[ncf + nd * crvold_dim1] *
|
|
bid;
|
|
/* L500: */
|
|
}
|
|
|
|
/* --------- Calcul des (NCF+1) coeff. de [X1*t + X0]**(NCF) --------
|
|
---- */
|
|
|
|
tabaux[ncf] = tabaux[ncf - 1] * x1;
|
|
for (ncj = ncf; ncj >= 2; --ncj) {
|
|
tabaux[ncj - 1] = tabaux[ncj - 1] * x0 + tabaux[ncj - 2] * x1;
|
|
/* L600: */
|
|
}
|
|
tabaux[0] *= x0;
|
|
|
|
/* L200: */
|
|
}
|
|
|
|
/* -------------- Prise en compte du dernier coeff. de CRVOLD -----------
|
|
*/
|
|
|
|
i__1 = *ncoeff - 1;
|
|
for (ncj = 1; ncj <= i__1; ++ncj) {
|
|
bid = tabaux[ncj - 1];
|
|
i__2 = *ndim;
|
|
for (nd = 1; nd <= i__2; ++nd) {
|
|
crvnew[nd + ncj * crvnew_dim1] += crvold[*ncoeff + nd *
|
|
crvold_dim1] * bid;
|
|
/* L800: */
|
|
}
|
|
/* L700: */
|
|
}
|
|
i__1 = *ndim;
|
|
for (nd = 1; nd <= i__1; ++nd) {
|
|
crvnew[nd + *ncoeff * crvnew_dim1] = crvold[*ncoeff + nd *
|
|
crvold_dim1] * tabaux[*ncoeff - 1];
|
|
/* L900: */
|
|
}
|
|
|
|
/* ---------------------------- The end ---------------------------------
|
|
*/
|
|
|
|
L9999:
|
|
if (*iercod > 0) {
|
|
AdvApp2Var_SysBase::maermsg_("MMARCIN", iercod, 7L);
|
|
}
|
|
if (ibb >= 2) {
|
|
AdvApp2Var_SysBase::mgsomsg_("MMARCIN", 7L);
|
|
}
|
|
return 0;
|
|
} /* mmarcin_ */
|
|
|
|
//=======================================================================
|
|
//function : mmatvec_
|
|
//purpose :
|
|
//=======================================================================
|
|
int mmatvec_(integer *nligne,
|
|
integer *,//ncolon,
|
|
integer *gposit,
|
|
integer *,//gnstoc,
|
|
doublereal *gmatri,
|
|
doublereal *vecin,
|
|
integer *deblig,
|
|
doublereal *vecout,
|
|
integer *iercod)
|
|
|
|
{
|
|
/* System generated locals */
|
|
integer i__1, i__2;
|
|
|
|
/* Local variables */
|
|
static logical ldbg;
|
|
static integer jmin, jmax, i__, j, k;
|
|
static doublereal somme;
|
|
static integer aux;
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* EFFECUE LE PRODUIT MATRICE VECTEUR OU LA MATRICE EST SOUS FORME */
|
|
/* DE PROFIL */
|
|
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* RESERVE, MATRICE, PRODUIT, VECTEUR, PROFIL */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* -------------------- */
|
|
/* NLIGNE : NOMBRE DE LIGNE DE LA MATRICE DES CONTRAINTES */
|
|
/* NCOLON :NOMBRE DE COLONNE DE LA MATRICE DES CONTRAINTES */
|
|
/* GNSTOC: NOMBRE DE COEFFICIENTS DANS LE PROFILE de la matrice */
|
|
/* GMATRI */
|
|
|
|
/* GPOSIT: TABLE DE POSITIONNEMENT DES TERMES DE STOCKAGE */
|
|
/* GPOSIT(1,I) CONTIENT LE NOMBRE DE TERMES-1 SUR LA LIGNE
|
|
*/
|
|
/* I DANS LE PROFIL DE LA MATRICE */
|
|
/* GPOSIT(2,I) CONTIENT L'INDICE DE STOCKAGE DU TERME DIAGONA
|
|
L*/
|
|
/* DE LA LIGNE I */
|
|
/* GPOSIT(3,I) CONTIENT L'INDICE COLONE DU PREMIER TERME DU
|
|
*/
|
|
/* PROFIL DE LA LIGNE I */
|
|
/* GNSTOC: NOMBRE DE COEFFICIENTS DANS LE PROFILE de la matrice */
|
|
/* GMATRI */
|
|
/* GMATRI : MATRICE DES CONTRAINTES SOUS FORME DE PROFIL */
|
|
/* VECIN : VECTEUR ENTRE */
|
|
/* DEBLIG : INDICE DE LIGNE A PARTIR DUQUEL ON VEUT CALCULER */
|
|
/* LE PRODUIT MATRICE VECTEUR */
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* --------------------- */
|
|
/* VECOUT : VECTEUR PRODUIT */
|
|
|
|
/* IERCOD : CODE D'ERREUR */
|
|
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ------------------ */
|
|
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* --------------------- */
|
|
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* ------------------------------ */
|
|
/* 22-09-95 : ...; ECRITURE VERSION ORIGINALE. */
|
|
/* > */
|
|
/* ***********************************************************************
|
|
*/
|
|
/* DECLARATIONS */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* INITIALISATIONS */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* Parameter adjustments */
|
|
--vecout;
|
|
gposit -= 4;
|
|
--vecin;
|
|
--gmatri;
|
|
|
|
/* Function Body */
|
|
ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 2;
|
|
if (ldbg) {
|
|
AdvApp2Var_SysBase::mgenmsg_("MMATVEC", 7L);
|
|
}
|
|
*iercod = 0;
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* TRAITEMENT */
|
|
/* ***********************************************************************
|
|
*/
|
|
AdvApp2Var_SysBase::mvriraz_((integer *)nligne,
|
|
(char *)&vecout[1]);
|
|
i__1 = *nligne;
|
|
for (i__ = *deblig; i__ <= i__1; ++i__) {
|
|
somme = 0.;
|
|
jmin = gposit[i__ * 3 + 3];
|
|
jmax = gposit[i__ * 3 + 1] + gposit[i__ * 3 + 3] - 1;
|
|
aux = gposit[i__ * 3 + 2] - gposit[i__ * 3 + 1] - jmin + 1;
|
|
i__2 = jmax;
|
|
for (j = jmin; j <= i__2; ++j) {
|
|
k = j + aux;
|
|
somme += gmatri[k] * vecin[j];
|
|
}
|
|
vecout[i__] = somme;
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
goto L9999;
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* TRAITEMENT DES ERREURS */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* RETOUR PROGRAMME APPELANT */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
L9999:
|
|
|
|
/* ___ DESALLOCATION, ... */
|
|
|
|
AdvApp2Var_SysBase::maermsg_("MMATVEC", iercod, 7L);
|
|
if (ldbg) {
|
|
AdvApp2Var_SysBase::mgsomsg_("MMATVEC", 7L);
|
|
}
|
|
|
|
return 0 ;
|
|
} /* mmatvec_ */
|
|
|
|
//=======================================================================
|
|
//function : mmbulld_
|
|
//purpose :
|
|
//=======================================================================
|
|
int AdvApp2Var_MathBase::mmbulld_(integer *nbcoln,
|
|
integer *nblign,
|
|
doublereal *dtabtr,
|
|
integer *numcle)
|
|
|
|
{
|
|
/* System generated locals */
|
|
integer dtabtr_dim1, dtabtr_offset, i__1, i__2;
|
|
|
|
/* Local variables */
|
|
static logical ldbg;
|
|
static doublereal daux;
|
|
static integer nite1, nite2, nchan, i1, i2;
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* TRI PAR BULLE DES COLONNES D'UN TABLEAU D'ENTIER DANS LE SENS */
|
|
/* CROISSANT */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* POINT-ENTREE, TRI, BULLE */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* -------------------- */
|
|
/* - NBCOLN : NOMBRE DE COLONNES DU TABLEAU */
|
|
/* - NBLIGN : NOMBRE DE LIGNE DU TABLEAU */
|
|
/* - DTABTR : TABLEAU D'ENTIER A TRIER */
|
|
/* - NUMCLE : POSITION DE LA CLE SUR LA COLONNE */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* --------------------- */
|
|
/* - DTABTR : TABLEAU TRIE */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ------------------ */
|
|
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* --------------------- */
|
|
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
/* PARTICULIEREMENT PERFORMANT LORSQUE LE TABLEAU EST PRESQUE TRIE */
|
|
/* Dans le cas contraire il vaut mieux utiliser MVSHELD */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* ------------------------------ */
|
|
/* 25-09-1995: PMN; ECRITURE VERSION ORIGINALE d'apres MBULLE */
|
|
/* > */
|
|
/* ***********************************************************************
|
|
*/
|
|
/* DECLARATIONS */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* INITIALISATIONS */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* Parameter adjustments */
|
|
dtabtr_dim1 = *nblign;
|
|
dtabtr_offset = dtabtr_dim1 + 1;
|
|
dtabtr -= dtabtr_offset;
|
|
|
|
/* Function Body */
|
|
ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 2;
|
|
if (ldbg) {
|
|
AdvApp2Var_SysBase::mgenmsg_("MMBULLD", 7L);
|
|
}
|
|
nchan = 1;
|
|
nite1 = *nbcoln;
|
|
nite2 = 2;
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* TRAITEMENT */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* ---->ALGORITHME EN N^2 / 2 ITERATION AU PLUS */
|
|
|
|
while(nchan != 0) {
|
|
|
|
/* ----> PARCOURS DE GAUCHE A DROITE */
|
|
|
|
nchan = 0;
|
|
i__1 = nite1;
|
|
for (i1 = nite2; i1 <= i__1; ++i1) {
|
|
if (dtabtr[*numcle + i1 * dtabtr_dim1] < dtabtr[*numcle + (i1 - 1)
|
|
* dtabtr_dim1]) {
|
|
i__2 = *nblign;
|
|
for (i2 = 1; i2 <= i__2; ++i2) {
|
|
daux = dtabtr[i2 + (i1 - 1) * dtabtr_dim1];
|
|
dtabtr[i2 + (i1 - 1) * dtabtr_dim1] = dtabtr[i2 + i1 *
|
|
dtabtr_dim1];
|
|
dtabtr[i2 + i1 * dtabtr_dim1] = daux;
|
|
}
|
|
if (nchan == 0) {
|
|
nchan = 1;
|
|
}
|
|
}
|
|
}
|
|
--nite1;
|
|
|
|
/* ----> PARCOURS DE DROITE A GAUCHE */
|
|
|
|
if (nchan != 0) {
|
|
nchan = 0;
|
|
i__1 = nite2;
|
|
for (i1 = nite1; i1 >= i__1; --i1) {
|
|
if (dtabtr[*numcle + i1 * dtabtr_dim1] < dtabtr[*numcle + (i1
|
|
- 1) * dtabtr_dim1]) {
|
|
i__2 = *nblign;
|
|
for (i2 = 1; i2 <= i__2; ++i2) {
|
|
daux = dtabtr[i2 + (i1 - 1) * dtabtr_dim1];
|
|
dtabtr[i2 + (i1 - 1) * dtabtr_dim1] = dtabtr[i2 + i1 *
|
|
dtabtr_dim1];
|
|
dtabtr[i2 + i1 * dtabtr_dim1] = daux;
|
|
}
|
|
if (nchan == 0) {
|
|
nchan = 1;
|
|
}
|
|
}
|
|
}
|
|
++nite2;
|
|
}
|
|
}
|
|
|
|
|
|
goto L9999;
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* TRAITEMENT DES ERREURS */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* ----> PAS D'ERREURS EN APPELANT DES FONCTIONS, ON A UNIQUEMENT DES */
|
|
/* TESTS ET DES BOUCLES. */
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* RETOUR PROGRAMME APPELANT */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
L9999:
|
|
|
|
if (ldbg) {
|
|
AdvApp2Var_SysBase::mgsomsg_("MMBULLD", 7L);
|
|
}
|
|
|
|
return 0 ;
|
|
} /* mmbulld_ */
|
|
|
|
|
|
//=======================================================================
|
|
//function : AdvApp2Var_MathBase::mmcdriv_
|
|
//purpose :
|
|
//=======================================================================
|
|
int AdvApp2Var_MathBase::mmcdriv_(integer *ndimen,
|
|
integer *ncoeff,
|
|
doublereal *courbe,
|
|
integer *ideriv,
|
|
integer *ncofdv,
|
|
doublereal *crvdrv)
|
|
|
|
|
|
{
|
|
/* System generated locals */
|
|
integer courbe_dim1, courbe_offset, crvdrv_dim1, crvdrv_offset, i__1,
|
|
i__2;
|
|
|
|
/* Local variables */
|
|
static integer i__, j, k;
|
|
static doublereal mfactk, bid;
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* CALCUL DE LA MATRICE D'UNE COURBE DERIVEE D' ORDRE IDERIV. */
|
|
/* AVEC PARAMETRES D' ENTRE DISTINCT DES PARAMETRES DE SORTIE. */
|
|
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* COEFFICIENTS,COURBE,DERIVEE I-EME. */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* ------------------ */
|
|
/* NDIMEN : Dimension de l'espace (2 ou 3 en general) */
|
|
/* NCOEFF : Le degre +1 de la courbe. */
|
|
/* COURBE : Tableau des coefficients de la courbe. */
|
|
/* IDERIV : Ordre de derivation demande : 1=derivee 1ere, etc... */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* ------------------- */
|
|
/* NCOFDV : Le degre +1 de la derivee d' ordre IDERIV de la courbe. */
|
|
/* CRVDRV : Tableau des coefficients de la derivee d' ordre IDERIV */
|
|
/* de la courbe. */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ---------------- */
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* ----------------------- */
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
|
|
/* ---> Il est possible de prendre comme argument de sortie la courbe */
|
|
/* et le nombre de coeff passes en entree en faisant : */
|
|
/* CALL MMCDRIV(NDIMEN,NCOEFF,COURBE,IDERIV,NCOEFF,COURBE). */
|
|
/* Apres cet appel, NCOEFF doone le nbre de coeff de la courbe */
|
|
/* derivee dont les coefficients sont stockes dans COURBE. */
|
|
/* Attention alors aux coefficients de COURBE de rang superieur a */
|
|
/* NCOEFF : il ne sont pas mis a zero. */
|
|
|
|
/* ---> Algorithme : */
|
|
/* Le code ci dessous a ete ecrit a partir de l' algorithme suivant:
|
|
*/
|
|
|
|
/* Soit P(t) = a1 + a2*t + ... an*t**n. La derivee d' ordre k de P */
|
|
/* (comportant n-k coefficients) est calculee ainsi : */
|
|
|
|
/* Pk(t) = a(k+1)*CNP(k,k)*k! */
|
|
/* + a(k+2)*CNP(k+1,k)*k! * t */
|
|
/* . */
|
|
/* . */
|
|
/* . */
|
|
/* + a(n)*CNP(n-1,k)*k! * t**(n-k-1). */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* -------------------------------- */
|
|
/* 09-01-90 : TE ; COMMON MCCNP -> MMCMCNP.INC & INDICES DES CNP */
|
|
/* 07-10-88 : RBD; Creation. */
|
|
/* > */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
|
|
/* -------------- Cas ou l' ordre de derivee est plus -------------------
|
|
*/
|
|
/* ---------------- grand que le degre de la courbe ---------------------
|
|
*/
|
|
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* Sert a fournir les coefficients du binome (triangle de Pascal). */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* Coeff du binome de 0 a 60. read only . init par block data */
|
|
|
|
/* DEMSCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
/* Les coefficients du binome forment une matrice triangulaire. */
|
|
/* On complete cette matrice dans le tableau CNP par sa transposee. */
|
|
/* On a donc: CNP(I,J) = CNP(J,I) pour I et J = 0, ..., 60. */
|
|
|
|
/* L'initialisation est faite a partir du block-data MMLLL09.RES, */
|
|
/* cree par le programme MQINICNP.FOR (voir l'equipe (AC) ). */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* ------------------------------ */
|
|
/* 03-07-90 : RBD; Ajout commentaires (nom du block-data). */
|
|
/* 19-06-90 : RBD; Le commun MMCMCNP remplace MCCNP qui est obsolete.
|
|
*/
|
|
/* 08-01-90 : TE ; CREATION */
|
|
/* > */
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* Parameter adjustments */
|
|
crvdrv_dim1 = *ndimen;
|
|
crvdrv_offset = crvdrv_dim1 + 1;
|
|
crvdrv -= crvdrv_offset;
|
|
courbe_dim1 = *ndimen;
|
|
courbe_offset = courbe_dim1 + 1;
|
|
courbe -= courbe_offset;
|
|
|
|
/* Function Body */
|
|
if (*ideriv >= *ncoeff) {
|
|
i__1 = *ndimen;
|
|
for (i__ = 1; i__ <= i__1; ++i__) {
|
|
crvdrv[i__ + crvdrv_dim1] = 0.;
|
|
/* L10: */
|
|
}
|
|
*ncofdv = 1;
|
|
goto L9999;
|
|
}
|
|
/* **********************************************************************
|
|
*/
|
|
/* Traitement general */
|
|
/* **********************************************************************
|
|
*/
|
|
/* --------------------- Calcul de Factorielle(IDERIV) ------------------
|
|
*/
|
|
|
|
k = *ideriv;
|
|
mfactk = 1.;
|
|
i__1 = k;
|
|
for (i__ = 2; i__ <= i__1; ++i__) {
|
|
mfactk *= i__;
|
|
/* L50: */
|
|
}
|
|
|
|
/* ------------ Calcul des coeff de la derivee d' ordre IDERIV ----------
|
|
*/
|
|
/* ---> Attention : le coefficient binomial C(n,m) est represente dans */
|
|
/* MCCNP par CNP(N+1,M+1). */
|
|
|
|
i__1 = *ncoeff;
|
|
for (j = k + 1; j <= i__1; ++j) {
|
|
bid = mmcmcnp_.cnp[j - 1 + k * 61] * mfactk;
|
|
i__2 = *ndimen;
|
|
for (i__ = 1; i__ <= i__2; ++i__) {
|
|
crvdrv[i__ + (j - k) * crvdrv_dim1] = bid * courbe[i__ + j *
|
|
courbe_dim1];
|
|
/* L200: */
|
|
}
|
|
/* L100: */
|
|
}
|
|
|
|
*ncofdv = *ncoeff - *ideriv;
|
|
|
|
/* -------------------------------- The end -----------------------------
|
|
*/
|
|
|
|
L9999:
|
|
return 0;
|
|
} /* mmcdriv_ */
|
|
|
|
//=======================================================================
|
|
//function : AdvApp2Var_MathBase::mmcglc1_
|
|
//purpose :
|
|
//=======================================================================
|
|
int AdvApp2Var_MathBase::mmcglc1_(integer *ndimax,
|
|
integer *ndimen,
|
|
integer *ncoeff,
|
|
doublereal *courbe,
|
|
doublereal *tdebut,
|
|
doublereal *tfinal,
|
|
doublereal *epsiln,
|
|
doublereal *xlongc,
|
|
doublereal *erreur,
|
|
integer *iercod)
|
|
|
|
|
|
{
|
|
/* System generated locals */
|
|
integer courbe_dim1, courbe_offset, i__1;
|
|
doublereal d__1;
|
|
|
|
/* Local variables */
|
|
static integer ndec;
|
|
static doublereal tdeb, tfin;
|
|
static integer iter;
|
|
static doublereal oldso;
|
|
static integer itmax;
|
|
static doublereal sottc;
|
|
static integer kk, ibb;
|
|
static doublereal dif, pas;
|
|
static doublereal som;
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* Permet de calculer la longueur d'un arc de courbe POLYNOMIAL */
|
|
/* sur un intervalle [A,B] quelconque. */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* LONGUEUR,COURBE,GAUSS,PRIVE. */
|
|
|
|
/* ARGUMENTS DD'ENTREE : */
|
|
/* ------------------ */
|
|
/* NDIMAX : Nombre de lignes maximum des tableaux */
|
|
/* (i.e. nbre maxi des polynomes). */
|
|
/* NDIMEN : Dimension de l'espace (nbre de polynomes). */
|
|
/* NCOEFF : Nombre de coefficients du polynome. C'est le degre + 1.
|
|
*/
|
|
/* COURBE(NDIMAX,NCOEFF) : Coefficients de la courbe. */
|
|
/* TDEBUT : Borne inferieure de l'intervalle d'integration pour */
|
|
/* le calcul de la longueur. */
|
|
/* TFINAL : Borne superieure de l'intervalle d'integration pour */
|
|
/* le calcul de la longueur. */
|
|
/* EPSILN : Precision DEMANDEE sur le calcul de la longueur. */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* ------------------- */
|
|
/* XLONGC : Longueur de l'arc de courbe */
|
|
/* ERREUR : Precision OBTENUE sur le calcul de la longueur. */
|
|
/* IERCOD : Code d' erreur, 0 OK, >0 Erreur grave. */
|
|
/* = 1 Trop d'iterations, on sort le meilleur resultat */
|
|
/* calcule (a ERREUR pres) */
|
|
/* = 2 Pb MMLONCV (pas de resultat) */
|
|
/* = 3 NDIM ou NCOEFF invalides (pas de resultat) */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ---------------- */
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* ----------------------- */
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
/* Le polynome est en fait un ensemble de polynomes dont les */
|
|
/* coefficients sont ranges dans un tableau a 2 indices, chaque */
|
|
/* ligne etant relative a 1 polynome. */
|
|
/* Le polynome est defini par ses coefficients ordonne par les */
|
|
/* puissances croissantes de la variable. */
|
|
/* Tous les polynomes ont le meme nombre de coefficients (donc le */
|
|
/* meme degre). */
|
|
|
|
/* Ce programme annule et remplace LENGCV, MLONGC et MLENCV. */
|
|
|
|
/* ATTENTION : si TDEBUT > TFINAL, la longueur est alors NEGATIVE. */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* -------------------------------- */
|
|
/* 22-04-1991: ALR; ITMAX en dur a 13 */
|
|
/* 14-05-1990: RBD; Appel MITERR au lieu de MEPSNR pour ITMAX */
|
|
/* 26-04-1990: RBD; Creation. */
|
|
/* > */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* Le nom de la routine */
|
|
|
|
|
|
/* ------------------------ Initialisation generale ---------------------
|
|
*/
|
|
|
|
/* Parameter adjustments */
|
|
courbe_dim1 = *ndimax;
|
|
courbe_offset = courbe_dim1 + 1;
|
|
courbe -= courbe_offset;
|
|
|
|
/* Function Body */
|
|
ibb = AdvApp2Var_SysBase::mnfndeb_();
|
|
if (ibb >= 2) {
|
|
AdvApp2Var_SysBase::mgenmsg_("MMCGLC1", 7L);
|
|
}
|
|
|
|
*iercod = 0;
|
|
*xlongc = 0.;
|
|
*erreur = 0.;
|
|
|
|
/* ------ Test d'egalite des bornes */
|
|
|
|
if (*tdebut == *tfinal) {
|
|
*iercod = 0;
|
|
goto L9999;
|
|
}
|
|
|
|
/* ------ Test de la dimension et du nombre de coefficients */
|
|
|
|
if (*ndimen <= 0 || *ncoeff <= 0) {
|
|
goto L9003;
|
|
}
|
|
|
|
/* ------ Nbre de decoupe en cours, nbre d'iteration, */
|
|
/* nbre max d'iterations */
|
|
|
|
ndec = 1;
|
|
iter = 1;
|
|
|
|
/* ALR NE PAS APPELER DE NOMBRE D ITERATION VENANT */
|
|
/* D'ON NE SAIT OU !! 8 EST MIS EN DUR EXPRES !! */
|
|
|
|
itmax = 13;
|
|
|
|
/* ------ Variation du nombre d'intervalles */
|
|
/* On multiplie par 2 a chaque iteration */
|
|
|
|
L5000:
|
|
pas = (*tfinal - *tdebut) / ndec;
|
|
sottc = 0.;
|
|
|
|
/* ------ Boucle sur tous les NDEC intervalles en cours */
|
|
|
|
i__1 = ndec;
|
|
for (kk = 1; kk <= i__1; ++kk) {
|
|
|
|
/* ------ Bornes de l'intervalle d'integration en cours */
|
|
|
|
tdeb = *tdebut + (kk - 1) * pas;
|
|
tfin = tdeb + pas;
|
|
mmloncv_(ndimax, ndimen, ncoeff, &courbe[courbe_offset], &tdeb, &tfin,
|
|
&som, iercod);
|
|
if (*iercod > 0) {
|
|
goto L9002;
|
|
}
|
|
|
|
sottc += som;
|
|
|
|
/* L100: */
|
|
}
|
|
|
|
|
|
/* ----------------- Test sur le nombre maximum d'iterations ------------
|
|
*/
|
|
|
|
/* Test si passe au moins 1 fois ** */
|
|
|
|
if (iter == 1) {
|
|
oldso = sottc;
|
|
ndec <<= 1;
|
|
++iter;
|
|
goto L5000;
|
|
} else {
|
|
|
|
/* ------ Prise en compte du DIF - Test de convergence */
|
|
|
|
++iter;
|
|
dif = (d__1 = sottc - oldso, abs(d__1));
|
|
|
|
/* ------ Si DIF est OK, on va sortir..., sinon: */
|
|
|
|
if (dif > *epsiln) {
|
|
|
|
/* ------ Si nbre iteration depasse, on sort */
|
|
|
|
if (iter > itmax) {
|
|
*iercod = 1;
|
|
goto L9000;
|
|
} else {
|
|
|
|
/* ------ Sinon on continue en decoupant l'intervalle initial.
|
|
*/
|
|
|
|
oldso = sottc;
|
|
ndec <<= 1;
|
|
goto L5000;
|
|
}
|
|
}
|
|
}
|
|
|
|
/* ------------------------------ THE END -------------------------------
|
|
*/
|
|
|
|
L9000:
|
|
*xlongc = sottc;
|
|
*erreur = dif;
|
|
goto L9999;
|
|
|
|
/* ---> PB dans MMLONCV */
|
|
|
|
L9002:
|
|
*iercod = 2;
|
|
goto L9999;
|
|
|
|
/* ---> NCOEFF ou NDIM invalides. */
|
|
|
|
L9003:
|
|
*iercod = 3;
|
|
goto L9999;
|
|
|
|
L9999:
|
|
if (*iercod > 0) {
|
|
AdvApp2Var_SysBase::maermsg_("MMCGLC1", iercod, 7L);
|
|
}
|
|
if (ibb >= 2) {
|
|
AdvApp2Var_SysBase::mgsomsg_("MMCGLC1", 7L);
|
|
}
|
|
return 0;
|
|
} /* mmcglc1_ */
|
|
|
|
//=======================================================================
|
|
//function : mmchole_
|
|
//purpose :
|
|
//=======================================================================
|
|
int mmchole_(integer *,//mxcoef,
|
|
integer *dimens,
|
|
doublereal *amatri,
|
|
integer *aposit,
|
|
integer *posuiv,
|
|
doublereal *chomat,
|
|
integer *iercod)
|
|
|
|
{
|
|
/* System generated locals */
|
|
integer i__1, i__2, i__3;
|
|
doublereal d__1;
|
|
|
|
/* Builtin functions */
|
|
//double sqrt();
|
|
|
|
/* Local variables */
|
|
static logical ldbg;
|
|
static integer kmin, i__, j, k;
|
|
static doublereal somme;
|
|
static integer ptini, ptcou;
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- T */
|
|
/* Effectue la decomposition de choleski de la matrice A en S.S */
|
|
/* Calcul la matrice triangulaire inferieure S. */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* RESOLUTION, MFACTORISATION, MATRICE_PROFILE, CHOLESKI */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* -------------------- */
|
|
/* MXCOEF : Nombres maximale de termes dans le profile du hessien */
|
|
/* DIMENS : Dimension du probleme */
|
|
/* AMATRI(MXCOEF) : Coefficients du profil de la matrice */
|
|
/* APOSIT(1,*) : Distance diagonnale-extrimite gauche de la ligne
|
|
*/
|
|
/* APOSIT(2,*) : Position des termes diagonnaux dans HESSIE */
|
|
/* POSUIV(MXCOEF): premiere ligne inferieure non hors profil */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* --------------------- */
|
|
/* CHOMAT(MXCOEF) : Matrice triangulaire inferieure qui conserve */
|
|
/* le profil de AMATRI. */
|
|
/* IERCOD : code d'erreur */
|
|
/* = 0 : ok */
|
|
/* = 1 : Matrice non definie positive */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ------------------ */
|
|
|
|
/* .Neant. */
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* ---------------------- */
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
/* NIVEAU DE DEBUG = 4 */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* ------------------------------ */
|
|
/* 14-02-1994: PMN; ECRITURE VERSION ORIGINALE. */
|
|
/* > */
|
|
/* ***********************************************************************
|
|
*/
|
|
/* DECLARATIONS */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* INITIALISATIONS */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* Parameter adjustments */
|
|
--chomat;
|
|
--posuiv;
|
|
--amatri;
|
|
aposit -= 3;
|
|
|
|
/* Function Body */
|
|
ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 4;
|
|
if (ldbg) {
|
|
AdvApp2Var_SysBase::mgenmsg_("MMCHOLE", 7L);
|
|
}
|
|
*iercod = 0;
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* TRAITEMENT */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
i__1 = *dimens;
|
|
for (j = 1; j <= i__1; ++j) {
|
|
|
|
ptini = aposit[(j << 1) + 2];
|
|
|
|
somme = 0.;
|
|
i__2 = ptini - 1;
|
|
for (k = ptini - aposit[(j << 1) + 1]; k <= i__2; ++k) {
|
|
/* Computing 2nd power */
|
|
d__1 = chomat[k];
|
|
somme += d__1 * d__1;
|
|
}
|
|
|
|
if (amatri[ptini] - somme < 1e-32) {
|
|
goto L9101;
|
|
}
|
|
chomat[ptini] = sqrt(amatri[ptini] - somme);
|
|
|
|
ptcou = ptini;
|
|
|
|
while(posuiv[ptcou] > 0) {
|
|
|
|
i__ = posuiv[ptcou];
|
|
ptcou = aposit[(i__ << 1) + 2] - (i__ - j);
|
|
|
|
/* Calcul la somme de S .S pour k =1 a j-1 */
|
|
/* ik jk */
|
|
somme = 0.;
|
|
/* Computing MAX */
|
|
i__2 = i__ - aposit[(i__ << 1) + 1], i__3 = j - aposit[(j << 1) +
|
|
1];
|
|
kmin = max(i__2,i__3);
|
|
i__2 = j - 1;
|
|
for (k = kmin; k <= i__2; ++k) {
|
|
somme += chomat[aposit[(i__ << 1) + 2] - (i__ - k)] * chomat[
|
|
aposit[(j << 1) + 2] - (j - k)];
|
|
}
|
|
|
|
chomat[ptcou] = (amatri[ptcou] - somme) / chomat[ptini];
|
|
}
|
|
}
|
|
|
|
goto L9999;
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* TRAITEMENT DES ERREURS */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
L9101:
|
|
*iercod = 1;
|
|
goto L9999;
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* RETOUR PROGRAMME APPELANT */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
L9999:
|
|
|
|
AdvApp2Var_SysBase::maermsg_("MMCHOLE", iercod, 7L);
|
|
if (ldbg) {
|
|
AdvApp2Var_SysBase::mgsomsg_("MMCHOLE", 7L);
|
|
}
|
|
|
|
return 0 ;
|
|
} /* mmchole_ */
|
|
|
|
//=======================================================================
|
|
//function : AdvApp2Var_MathBase::mmcvctx_
|
|
//purpose :
|
|
//=======================================================================
|
|
int AdvApp2Var_MathBase::mmcvctx_(integer *ndimen,
|
|
integer *ncofmx,
|
|
integer *nderiv,
|
|
doublereal *ctrtes,
|
|
doublereal *crvres,
|
|
doublereal *tabaux,
|
|
doublereal *xmatri,
|
|
integer *iercod)
|
|
|
|
{
|
|
/* System generated locals */
|
|
integer ctrtes_dim1, ctrtes_offset, crvres_dim1, crvres_offset,
|
|
xmatri_dim1, xmatri_offset, tabaux_dim1, tabaux_offset, i__1,
|
|
i__2;
|
|
|
|
/* Local variables */
|
|
static integer moup1, nordr;
|
|
static integer nd;
|
|
static integer ibb, ncf, ndv;
|
|
static doublereal eps1;
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* Calcul d' une courbe polynomiale verifiant des */
|
|
/* contraintes de passages (interpolation) */
|
|
/* de derivees premieres etc... aux extremites. */
|
|
/* Les parametres aux extremites sont supposes etre -1 et 1. */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* TOUS, AB_SPECIFI::CONTRAINTES&,INTERPOLATION,&COURBE */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* ------------------ */
|
|
/* NDIMEN : Dimension de l' espace. */
|
|
/* NCOFMX : Nre de coeff. de la courbe CRVRES sur chaque */
|
|
/* dimension. */
|
|
/* NDERIV : Ordre de contrainte aux derivees : */
|
|
/* 0 --> interpolation simple. */
|
|
/* 1 --> interpolation+contraintes aux derivees 1eres. */
|
|
/* 2 --> cas (0)+ (1) + " " " 2emes. */
|
|
/* etc... */
|
|
/* CTRTES : Tableau des contraintes. */
|
|
/* CTRTES(*,1,*) = contraintes en -1. */
|
|
/* CTRTES(*,2,*) = contraintes en 1. */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* ------------------- */
|
|
/* CRVRES : La courbe resultat definie dans (-1,1). */
|
|
/* TABAUX : Matrice auxilliaire. */
|
|
/* XMATRI : Matrice auxilliaire. */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ---------------- */
|
|
|
|
/* .Neant. */
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* ---------------------- */
|
|
/* Type Name */
|
|
/* MAERMSG R*8 DFLOAT MGENMSG */
|
|
/* MGSOMSG MMEPS1 MMRSLW */
|
|
/* I*4 MNFNDEB */
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
/* Le polynome (ou la courbe) est calculee en resolvant un */
|
|
/* systeme d' equations lineaires. Si le degre impose est grand */
|
|
/* il est preferable de faire appel a une routine basee sur */
|
|
/* l' interpolation de Lagrange ou d' Hermite suivant le cas. */
|
|
/* (pour un degre eleve la matrice du systeme peut etre mal */
|
|
/* conditionnee). */
|
|
/* Cette routine retourne une courbe definie dans (-1,1). */
|
|
/* Pour un cas general, il faut utiliser MCVCTG. */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* -------------------------------- */
|
|
/* 18-09-1995 : JMF ; Verfor */
|
|
/* 14-02-1990 : RBD ; Correction declaration de NOMPRG. */
|
|
/* 12-04-1989 : RBD ; Suppression des chaines de caracteres pour */
|
|
/* les appel a MMRSLW. */
|
|
/* 31-05-1988 : JJM ; Reorganisation contraintes. */
|
|
/* 22-02-1988 : JJM ; Appel MFNDEB -> MNFNDEB */
|
|
/* 22-02-1988 : JJM ; Appel GERMSG -> MAERMSG */
|
|
/* 24-11-1987 : Cree par RBD. */
|
|
|
|
/* > */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* Le nom de la routine */
|
|
|
|
|
|
/* Parameter adjustments */
|
|
crvres_dim1 = *ncofmx;
|
|
crvres_offset = crvres_dim1 + 1;
|
|
crvres -= crvres_offset;
|
|
xmatri_dim1 = *nderiv + 1;
|
|
xmatri_offset = xmatri_dim1 + 1;
|
|
xmatri -= xmatri_offset;
|
|
tabaux_dim1 = *nderiv + 1 + *ndimen;
|
|
tabaux_offset = tabaux_dim1 + 1;
|
|
tabaux -= tabaux_offset;
|
|
ctrtes_dim1 = *ndimen;
|
|
ctrtes_offset = ctrtes_dim1 * 3 + 1;
|
|
ctrtes -= ctrtes_offset;
|
|
|
|
/* Function Body */
|
|
ibb = AdvApp2Var_SysBase::mnfndeb_();
|
|
if (ibb >= 3) {
|
|
AdvApp2Var_SysBase::mgenmsg_("MMCVCTX", 7L);
|
|
}
|
|
/* Les precisions. */
|
|
AdvApp2Var_MathBase::mmeps1_(&eps1);
|
|
|
|
/* ****************** CALCUL DES COEFFICIENTS PAIRS *********************
|
|
*/
|
|
/* ------------------------- Initialisation -----------------------------
|
|
*/
|
|
|
|
nordr = *nderiv + 1;
|
|
i__1 = nordr;
|
|
for (ncf = 1; ncf <= i__1; ++ncf) {
|
|
tabaux[ncf + tabaux_dim1] = 1.;
|
|
/* L100: */
|
|
}
|
|
|
|
/* ---------------- Calcul des termes correspondants aux derivees -------
|
|
*/
|
|
|
|
i__1 = nordr;
|
|
for (ndv = 2; ndv <= i__1; ++ndv) {
|
|
i__2 = nordr;
|
|
for (ncf = 1; ncf <= i__2; ++ncf) {
|
|
tabaux[ncf + ndv * tabaux_dim1] = tabaux[ncf + (ndv - 1) *
|
|
tabaux_dim1] * (doublereal) ((ncf << 1) - ndv);
|
|
/* L300: */
|
|
}
|
|
/* L200: */
|
|
}
|
|
|
|
/* ------------------ Ecriture du deuxieme membre -----------------------
|
|
*/
|
|
|
|
moup1 = 1;
|
|
i__1 = nordr;
|
|
for (ndv = 1; ndv <= i__1; ++ndv) {
|
|
i__2 = *ndimen;
|
|
for (nd = 1; nd <= i__2; ++nd) {
|
|
tabaux[nordr + nd + ndv * tabaux_dim1] = (ctrtes[nd + ((ndv << 1)
|
|
+ 2) * ctrtes_dim1] + moup1 * ctrtes[nd + ((ndv << 1) + 1)
|
|
* ctrtes_dim1]) / 2.;
|
|
/* L500: */
|
|
}
|
|
moup1 = -moup1;
|
|
/* L400: */
|
|
}
|
|
|
|
/* -------------------- Resolution du systeme ---------------------------
|
|
*/
|
|
|
|
mmrslw_(&nordr, &nordr, ndimen, &eps1, &tabaux[tabaux_offset], &xmatri[
|
|
xmatri_offset], iercod);
|
|
if (*iercod > 0) {
|
|
goto L9999;
|
|
}
|
|
i__1 = *ndimen;
|
|
for (nd = 1; nd <= i__1; ++nd) {
|
|
i__2 = nordr;
|
|
for (ncf = 1; ncf <= i__2; ++ncf) {
|
|
crvres[(ncf << 1) - 1 + nd * crvres_dim1] = xmatri[ncf + nd *
|
|
xmatri_dim1];
|
|
/* L700: */
|
|
}
|
|
/* L600: */
|
|
}
|
|
|
|
/* ***************** CALCUL DES COEFFICIENTS IMPAIRS ********************
|
|
*/
|
|
/* ------------------------- Initialisation -----------------------------
|
|
*/
|
|
|
|
|
|
i__1 = nordr;
|
|
for (ncf = 1; ncf <= i__1; ++ncf) {
|
|
tabaux[ncf + tabaux_dim1] = 1.;
|
|
/* L1100: */
|
|
}
|
|
|
|
/* ---------------- Calcul des termes correspondants aux derivees -------
|
|
*/
|
|
|
|
i__1 = nordr;
|
|
for (ndv = 2; ndv <= i__1; ++ndv) {
|
|
i__2 = nordr;
|
|
for (ncf = 1; ncf <= i__2; ++ncf) {
|
|
tabaux[ncf + ndv * tabaux_dim1] = tabaux[ncf + (ndv - 1) *
|
|
tabaux_dim1] * (doublereal) ((ncf << 1) - ndv + 1);
|
|
/* L1300: */
|
|
}
|
|
/* L1200: */
|
|
}
|
|
|
|
/* ------------------ Ecriture du deuxieme membre -----------------------
|
|
*/
|
|
|
|
moup1 = -1;
|
|
i__1 = nordr;
|
|
for (ndv = 1; ndv <= i__1; ++ndv) {
|
|
i__2 = *ndimen;
|
|
for (nd = 1; nd <= i__2; ++nd) {
|
|
tabaux[nordr + nd + ndv * tabaux_dim1] = (ctrtes[nd + ((ndv << 1)
|
|
+ 2) * ctrtes_dim1] + moup1 * ctrtes[nd + ((ndv << 1) + 1)
|
|
* ctrtes_dim1]) / 2.;
|
|
/* L1500: */
|
|
}
|
|
moup1 = -moup1;
|
|
/* L1400: */
|
|
}
|
|
|
|
/* -------------------- Resolution du systeme ---------------------------
|
|
*/
|
|
|
|
mmrslw_(&nordr, &nordr, ndimen, &eps1, &tabaux[tabaux_offset], &xmatri[
|
|
xmatri_offset], iercod);
|
|
if (*iercod > 0) {
|
|
goto L9999;
|
|
}
|
|
i__1 = *ndimen;
|
|
for (nd = 1; nd <= i__1; ++nd) {
|
|
i__2 = nordr;
|
|
for (ncf = 1; ncf <= i__2; ++ncf) {
|
|
crvres[(ncf << 1) + nd * crvres_dim1] = xmatri[ncf + nd *
|
|
xmatri_dim1];
|
|
/* L1700: */
|
|
}
|
|
/* L1600: */
|
|
}
|
|
|
|
/* --------------------------- The end ----------------------------------
|
|
*/
|
|
|
|
L9999:
|
|
if (*iercod != 0) {
|
|
AdvApp2Var_SysBase::maermsg_("MMCVCTX", iercod, 7L);
|
|
}
|
|
if (ibb >= 3) {
|
|
AdvApp2Var_SysBase::mgsomsg_("MMCVCTX", 7L);
|
|
}
|
|
|
|
return 0 ;
|
|
} /* mmcvctx_ */
|
|
|
|
//=======================================================================
|
|
//function : AdvApp2Var_MathBase::mmcvinv_
|
|
//purpose :
|
|
//=======================================================================
|
|
int AdvApp2Var_MathBase::mmcvinv_(integer *ndimax,
|
|
integer *ncoef,
|
|
integer *ndim,
|
|
doublereal *curveo,
|
|
doublereal *curve)
|
|
|
|
{
|
|
/* Initialized data */
|
|
|
|
static char nomprg[8+1] = "MMCVINV ";
|
|
|
|
/* System generated locals */
|
|
integer curve_dim1, curve_offset, curveo_dim1, curveo_offset, i__1, i__2;
|
|
|
|
/* Local variables */
|
|
static integer i__, nd, ibb;
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* Inversion des arguments de la courbe finale. */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* LISSAGE,COURBE */
|
|
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* ------------------ */
|
|
|
|
/* NDIM: Dimension de l' espace. */
|
|
/* NCOEF: Degre du polynome. */
|
|
/* CURVEO: La courbe avant inversion. */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* ------------------- */
|
|
/* CURVE: La courbe apres inversion. */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ---------------- */
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* ----------------------- */
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* -------------------------------- */
|
|
/* 22-02-1988 : JJM ; Appel MFNDEB -> MNFNDEB */
|
|
/* 15-07-1987: Cree par JJM. */
|
|
|
|
/* > */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* Le nom de la routine */
|
|
/* Parameter adjustments */
|
|
curve_dim1 = *ndimax;
|
|
curve_offset = curve_dim1 + 1;
|
|
curve -= curve_offset;
|
|
curveo_dim1 = *ncoef;
|
|
curveo_offset = curveo_dim1 + 1;
|
|
curveo -= curveo_offset;
|
|
|
|
/* Function Body */
|
|
|
|
ibb = AdvApp2Var_SysBase::mnfndeb_();
|
|
if (ibb >= 2) {
|
|
AdvApp2Var_SysBase::mgenmsg_(nomprg, 6L);
|
|
}
|
|
|
|
i__1 = *ncoef;
|
|
for (i__ = 1; i__ <= i__1; ++i__) {
|
|
i__2 = *ndim;
|
|
for (nd = 1; nd <= i__2; ++nd) {
|
|
curve[nd + i__ * curve_dim1] = curveo[i__ + nd * curveo_dim1];
|
|
/* L300: */
|
|
}
|
|
}
|
|
|
|
/* L9999: */
|
|
return 0;
|
|
} /* mmcvinv_ */
|
|
|
|
//=======================================================================
|
|
//function : mmcvstd_
|
|
//purpose :
|
|
//=======================================================================
|
|
int mmcvstd_(integer *ncofmx,
|
|
integer *ndimax,
|
|
integer *ncoeff,
|
|
integer *ndimen,
|
|
doublereal *crvcan,
|
|
doublereal *courbe)
|
|
|
|
{
|
|
/* System generated locals */
|
|
integer courbe_dim1, crvcan_dim1, crvcan_offset, i__1, i__2, i__3;
|
|
|
|
/* Local variables */
|
|
static integer ndeg, i__, j, j1, nd, ibb;
|
|
static doublereal bid;
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* Transforme une courbe definie entre [-1,1] a [0,1]. */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* LIMITATION,RESTRICTION,COURBE */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* ------------------ */
|
|
/* NDIMAX : Dimensionnement de l' espace. */
|
|
/* NDIMEN : Dimension de la courbe. */
|
|
/* NCOEFF : Degre de la courbe. */
|
|
/* CRVCAN(NCOFMX,NDIMEN): La courbe definie entre [-1,1]. */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* ------------------- */
|
|
/* COURBE(NDIMAX,NCOEFF): La courbe definie dans [0,1]. */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ---------------- */
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* ----------------------- */
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* -------------------------------- */
|
|
/* 09-01-90 : TE ; COMMON MCCNP -> MMCMCNP.INC & INDICES DES CNP */
|
|
/* 12-04-89 : RBD ; Appel MGSOMSG. */
|
|
/* 22-02-88 : JJM ; Appel MFNDEB -> MNFNDEB */
|
|
/* 19-02-88 : JJM ; Remontee des PARAMETER */
|
|
/* 14-01-88 : JJM ; Suppression de MINOMBR */
|
|
/* 28-11-86 : Creation JJM. */
|
|
/* > */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* Le nom du programme. */
|
|
|
|
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* Sert a fournir les coefficients du binome (triangle de Pascal). */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* Coeff du binome de 0 a 60. read only . init par block data */
|
|
|
|
/* DEMSCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
/* Les coefficients du binome forment une matrice triangulaire. */
|
|
/* On complete cette matrice dans le tableau CNP par sa transposee. */
|
|
/* On a donc: CNP(I,J) = CNP(J,I) pour I et J = 0, ..., 60. */
|
|
|
|
/* L'initialisation est faite a partir du block-data MMLLL09.RES, */
|
|
/* cree par le programme MQINICNP.FOR (voir l'equipe (AC) ). */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* ------------------------------ */
|
|
/* 03-07-90 : RBD; Ajout commentaires (nom du block-data). */
|
|
/* 19-06-90 : RBD; Le commun MMCMCNP remplace MCCNP qui est obsolete.
|
|
*/
|
|
/* 08-01-90 : TE ; CREATION */
|
|
/* > */
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* Parameter adjustments */
|
|
courbe_dim1 = *ndimax;
|
|
--courbe;
|
|
crvcan_dim1 = *ncofmx;
|
|
crvcan_offset = crvcan_dim1;
|
|
crvcan -= crvcan_offset;
|
|
|
|
/* Function Body */
|
|
ibb = AdvApp2Var_SysBase::mnfndeb_();
|
|
if (ibb >= 3) {
|
|
AdvApp2Var_SysBase::mgenmsg_("MMCVSTD", 7L);
|
|
}
|
|
ndeg = *ncoeff - 1;
|
|
|
|
/* ------------------ Construction de la courbe resultat ----------------
|
|
*/
|
|
|
|
i__1 = *ndimen;
|
|
for (nd = 1; nd <= i__1; ++nd) {
|
|
i__2 = ndeg;
|
|
for (j = 0; j <= i__2; ++j) {
|
|
bid = 0.;
|
|
i__3 = ndeg;
|
|
for (i__ = j; i__ <= i__3; i__ += 2) {
|
|
bid += crvcan[i__ + nd * crvcan_dim1] * mmcmcnp_.cnp[i__ + j
|
|
* 61];
|
|
/* L410: */
|
|
}
|
|
courbe[nd + j * courbe_dim1] = bid;
|
|
|
|
bid = 0.;
|
|
j1 = j + 1;
|
|
i__3 = ndeg;
|
|
for (i__ = j1; i__ <= i__3; i__ += 2) {
|
|
bid += crvcan[i__ + nd * crvcan_dim1] * mmcmcnp_.cnp[i__ + j
|
|
* 61];
|
|
/* L420: */
|
|
}
|
|
courbe[nd + j * courbe_dim1] -= bid;
|
|
/* L400: */
|
|
}
|
|
/* L300: */
|
|
}
|
|
|
|
/* ------------------- Renormalisation de COURBE -------------------------
|
|
*/
|
|
|
|
bid = 1.;
|
|
i__1 = ndeg;
|
|
for (i__ = 0; i__ <= i__1; ++i__) {
|
|
i__2 = *ndimen;
|
|
for (nd = 1; nd <= i__2; ++nd) {
|
|
courbe[nd + i__ * courbe_dim1] *= bid;
|
|
/* L510: */
|
|
}
|
|
bid *= 2.;
|
|
/* L500: */
|
|
}
|
|
|
|
/* ----------------------------- The end --------------------------------
|
|
*/
|
|
|
|
if (ibb >= 3) {
|
|
AdvApp2Var_SysBase::mgsomsg_("MMCVSTD", 7L);
|
|
}
|
|
return 0;
|
|
} /* mmcvstd_ */
|
|
|
|
//=======================================================================
|
|
//function : AdvApp2Var_MathBase::mmdrc11_
|
|
//purpose :
|
|
//=======================================================================
|
|
int AdvApp2Var_MathBase::mmdrc11_(integer *iordre,
|
|
integer *ndimen,
|
|
integer *ncoeff,
|
|
doublereal *courbe,
|
|
doublereal *points,
|
|
doublereal *mfactab)
|
|
|
|
{
|
|
/* System generated locals */
|
|
integer courbe_dim1, courbe_offset, points_dim2, points_offset, i__1,
|
|
i__2;
|
|
|
|
/* Local variables */
|
|
|
|
static integer ndeg, i__, j, ndgcb, nd, ibb;
|
|
|
|
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* Calcul des derivees successives de l' equation COURBE au */
|
|
/* parametres -1, 1 de l' ordre 0 jusqu' a l' ordre IORDRE */
|
|
/* inclus.Le calcul se fait sans connaitre les coefficients des */
|
|
/* derivees de la courbe. */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* POSITIONNEMENT,EXTREMITES,COURBE,DERIVEE. */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* ------------------ */
|
|
/* IORDRE : Ordre maximal de calcul des derivees. */
|
|
/* NDIMEN : Dimension de l' espace. */
|
|
/* NCOEFF : Nombre de coefficients de la courbe (degre+1). */
|
|
/* COURBE : Tableau des coefficients de la courbe. */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* ------------------- */
|
|
/* POINTS : Tableau des valeurs des derivees successives */
|
|
/* au parametres -1.D0 et 1.D0. */
|
|
/* MFACTAB : Tableau auxiliaire pour le calcul de factorielle(I).
|
|
*/
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ---------------- */
|
|
/* Aucun. */
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* ----------------------- */
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
|
|
/* ---> ATTENTION, les coefficients de la courbe sont ranges */
|
|
/* "A L' ENVERS". */
|
|
|
|
/* ---> L' algorithme de calcul des derivees est base sur la */
|
|
/* generalisation du schema de Horner : */
|
|
/* k 2 */
|
|
/* Soit C(t) = uk.t + ... + u2.t + u1.t + u0 . */
|
|
|
|
|
|
/* On pose a0 = uk, b0 = 0, c0 = 0 et pour 1<=j<=k, on calcule : */
|
|
|
|
/* aj = a(j-1).x + u(k-j) */
|
|
/* bj = b(j-1).x + a(j-1) */
|
|
/* cj = c(j-1).x + b(j-1) */
|
|
|
|
/* On obtient alors : C(x) = ak, C'(x) = bk, C"(x) = 2.ck . */
|
|
|
|
/* L' algorithme se generalise facilement pour le calcul de */
|
|
|
|
/* (n) */
|
|
/* C (x) . */
|
|
/* --------- */
|
|
/* n! */
|
|
|
|
/* Reference : D. KNUTH, "The Art of Computer Programming" */
|
|
/* --------- Vol. 2/Seminumerical Algorithms */
|
|
/* Addison-Wesley Pub. Co. (1969) */
|
|
/* pages 423-425. */
|
|
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* -------------------------------- */
|
|
/* 29-01-1990 : RBD ; Correction de l' en-tete, mise au normes. */
|
|
/* 22-02-1988 : JJM ; Appel MFNDEB -> MNFNDEB */
|
|
/* 25-11-1987 : Cree par JJM (d' apres MDRCRV). */
|
|
/* > */
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
/* Le nom de la routine */
|
|
|
|
/* Parameter adjustments */
|
|
points_dim2 = *iordre + 1;
|
|
points_offset = (points_dim2 << 1) + 1;
|
|
points -= points_offset;
|
|
courbe_dim1 = *ncoeff;
|
|
courbe_offset = courbe_dim1;
|
|
courbe -= courbe_offset;
|
|
|
|
/* Function Body */
|
|
ibb = AdvApp2Var_SysBase::mnfndeb_();
|
|
if (ibb >= 2) {
|
|
AdvApp2Var_SysBase::mgenmsg_("MMDRC11", 7L);
|
|
}
|
|
|
|
if (*iordre < 0 || *ncoeff < 1) {
|
|
goto L9999;
|
|
}
|
|
|
|
/* ------------------- Initialisation du tableau POINTS -----------------
|
|
*/
|
|
|
|
ndgcb = *ncoeff - 1;
|
|
i__1 = *ndimen;
|
|
for (nd = 1; nd <= i__1; ++nd) {
|
|
points[(nd * points_dim2 << 1) + 1] = courbe[ndgcb + nd * courbe_dim1]
|
|
;
|
|
points[(nd * points_dim2 << 1) + 2] = courbe[ndgcb + nd * courbe_dim1]
|
|
;
|
|
/* L100: */
|
|
}
|
|
|
|
i__1 = *ndimen;
|
|
for (nd = 1; nd <= i__1; ++nd) {
|
|
i__2 = *iordre;
|
|
for (j = 1; j <= i__2; ++j) {
|
|
points[((j + nd * points_dim2) << 1) + 1] = 0.;
|
|
points[((j + nd * points_dim2) << 1) + 2] = 0.;
|
|
/* L400: */
|
|
}
|
|
/* L300: */
|
|
}
|
|
|
|
/* Calcul au parametre -1 et 1 */
|
|
|
|
i__1 = *ndimen;
|
|
for (nd = 1; nd <= i__1; ++nd) {
|
|
i__2 = ndgcb;
|
|
for (ndeg = 1; ndeg <= i__2; ++ndeg) {
|
|
for (i__ = *iordre; i__ >= 1; --i__) {
|
|
points[((i__ + nd * points_dim2) << 1) + 1] = -points[((i__ + nd
|
|
* points_dim2) << 1) + 1] + points[((i__ - 1 + nd *
|
|
points_dim2) << 1) + 1];
|
|
points[((i__ + nd * points_dim2) << 1) + 2] += points[((i__ - 1
|
|
+ nd * points_dim2) << 1) + 2];
|
|
/* L800: */
|
|
}
|
|
points[(nd * points_dim2 << 1) + 1] = -points[(nd * points_dim2 <<
|
|
1) + 1] + courbe[ndgcb - ndeg + nd * courbe_dim1];
|
|
points[(nd * points_dim2 << 1) + 2] += courbe[ndgcb - ndeg + nd *
|
|
courbe_dim1];
|
|
/* L700: */
|
|
}
|
|
/* L600: */
|
|
}
|
|
|
|
/* --------------------- Multiplication par factorielle(I) --------------
|
|
*/
|
|
|
|
if (*iordre > 1) {
|
|
mfac_(&mfactab[1], iordre);
|
|
|
|
i__1 = *ndimen;
|
|
for (nd = 1; nd <= i__1; ++nd) {
|
|
i__2 = *iordre;
|
|
for (i__ = 2; i__ <= i__2; ++i__) {
|
|
points[((i__ + nd * points_dim2) << 1) + 1] = mfactab[i__] *
|
|
points[((i__ + nd * points_dim2) << 1) + 1];
|
|
points[((i__ + nd * points_dim2) << 1) + 2] = mfactab[i__] *
|
|
points[((i__ + nd * points_dim2) << 1) + 2];
|
|
/* L1000: */
|
|
}
|
|
/* L900: */
|
|
}
|
|
}
|
|
|
|
/* ---------------------------- Fin -------------------------------------
|
|
*/
|
|
|
|
L9999:
|
|
if (ibb >= 2) {
|
|
AdvApp2Var_SysBase::mgsomsg_("MMDRC11", 7L);
|
|
}
|
|
return 0;
|
|
} /* mmdrc11_ */
|
|
|
|
//=======================================================================
|
|
//function : mmdrvcb_
|
|
//purpose :
|
|
//=======================================================================
|
|
int mmdrvcb_(integer *ideriv,
|
|
integer *ndim,
|
|
integer *ncoeff,
|
|
doublereal *courbe,
|
|
doublereal *tparam,
|
|
doublereal *tabpnt,
|
|
integer *iercod)
|
|
|
|
{
|
|
/* System generated locals */
|
|
integer courbe_dim1, tabpnt_dim1, i__1, i__2, i__3;
|
|
|
|
/* Local variables */
|
|
static integer ndeg, i__, j, nd, ndgcrb, iptpnt, ibb;
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* Calcul des derivees successives de l' equation COURBE au */
|
|
/* parametre TPARAM de l' ordre 0 jusqu' a l' ordre IDERIV inclus. */
|
|
/* Le calcul se fait sans utiliser les coefficients des */
|
|
/* derivees de COURBE. */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* POSITIONNEMENT,PARAMETRE,COURBE,DERIVEE. */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* ------------------ */
|
|
/* IDERIV : Ordre maximal de calcul des derivees. */
|
|
/* NDIM : Dimension de l' espace. */
|
|
/* NCOEFF : Nombre de coefficients de la courbe (degre+1). */
|
|
/* COURBE : Tableau des coefficients de la courbe. */
|
|
/* TPARAM : Valeur du parametre ou la courbe doit etre evaluee. */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* ------------------- */
|
|
/* TABPNT : Tableau des valeurs des derivees successives */
|
|
/* au parametre TPARAM. */
|
|
/* IERCOD : 0 = OK, */
|
|
/* 1 = Entrees incoherentes. */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ---------------- */
|
|
/* Aucun. */
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* ----------------------- */
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
|
|
/* L' algorithme de calcul des derivees est base sur la */
|
|
/* generalisation du schema de Horner : */
|
|
/* k 2 */
|
|
/* Soit C(t) = uk.t + ... + u2.t + u1.t + u0 . */
|
|
|
|
|
|
/* On pose a0 = uk, b0 = 0, c0 = 0 et pour 1<=j<=k, on calcule : */
|
|
|
|
/* aj = a(j-1).x + u(k-j) */
|
|
/* bj = b(j-1).x + a(j-1) */
|
|
/* cj = c(j-1).x + b(j-1) */
|
|
|
|
/* On obtient alors : C(x) = ak, C'(x) = bk, C"(x) = 2.ck . */
|
|
|
|
/* L' algorithme se generalise facilement pour le calcul de */
|
|
|
|
/* (n) */
|
|
/* C (x) . */
|
|
/* --------- */
|
|
/* n! */
|
|
|
|
/* Reference : D. KNUTH, "The Art of Computer Programming" */
|
|
/* --------- Vol. 2/Seminumerical Algorithms */
|
|
/* Addison-Wesley Pub. Co. (1969) */
|
|
/* pages 423-425. */
|
|
|
|
/* ----> Pour evaluer les derivees en 0 et en 1, il est preferable */
|
|
/* d' utiliser la routine MDRV01.FOR . */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* -------------------------------- */
|
|
/* 28-06-1988 : Cree par RBD. */
|
|
|
|
/* > */
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
/* Le nom de la routine */
|
|
|
|
/* Parameter adjustments */
|
|
tabpnt_dim1 = *ndim;
|
|
--tabpnt;
|
|
courbe_dim1 = *ndim;
|
|
--courbe;
|
|
|
|
/* Function Body */
|
|
ibb = AdvApp2Var_SysBase::mnfndeb_();
|
|
if (ibb >= 2) {
|
|
AdvApp2Var_SysBase::mgenmsg_("MMDRVCB", 7L);
|
|
}
|
|
|
|
if (*ideriv < 0 || *ncoeff < 1) {
|
|
*iercod = 1;
|
|
goto L9999;
|
|
}
|
|
*iercod = 0;
|
|
|
|
/* ------------------- Initialisation du tableau TABPNT -----------------
|
|
*/
|
|
|
|
ndgcrb = *ncoeff - 1;
|
|
i__1 = *ndim;
|
|
for (nd = 1; nd <= i__1; ++nd) {
|
|
tabpnt[nd] = courbe[nd + ndgcrb * courbe_dim1];
|
|
/* L100: */
|
|
}
|
|
|
|
if (*ideriv < 1) {
|
|
goto L200;
|
|
}
|
|
iptpnt = *ndim * *ideriv;
|
|
AdvApp2Var_SysBase::mvriraz_((integer *)&iptpnt,
|
|
(char *)&tabpnt[tabpnt_dim1 + 1]);
|
|
L200:
|
|
|
|
/* ------------------------ Calcul au parametre TPARAM ------------------
|
|
*/
|
|
|
|
i__1 = ndgcrb;
|
|
for (ndeg = 1; ndeg <= i__1; ++ndeg) {
|
|
i__2 = *ndim;
|
|
for (nd = 1; nd <= i__2; ++nd) {
|
|
for (i__ = *ideriv; i__ >= 1; --i__) {
|
|
tabpnt[nd + i__ * tabpnt_dim1] = tabpnt[nd + i__ *
|
|
tabpnt_dim1] * *tparam + tabpnt[nd + (i__ - 1) *
|
|
tabpnt_dim1];
|
|
/* L700: */
|
|
}
|
|
tabpnt[nd] = tabpnt[nd] * *tparam + courbe[nd + (ndgcrb - ndeg) *
|
|
courbe_dim1];
|
|
/* L600: */
|
|
}
|
|
/* L500: */
|
|
}
|
|
|
|
/* --------------------- Multiplication par factorielle(I) -------------
|
|
*/
|
|
|
|
i__1 = *ideriv;
|
|
for (i__ = 2; i__ <= i__1; ++i__) {
|
|
i__2 = i__;
|
|
for (j = 2; j <= i__2; ++j) {
|
|
i__3 = *ndim;
|
|
for (nd = 1; nd <= i__3; ++nd) {
|
|
tabpnt[nd + i__ * tabpnt_dim1] = (doublereal) j * tabpnt[nd +
|
|
i__ * tabpnt_dim1];
|
|
/* L1200: */
|
|
}
|
|
/* L1100: */
|
|
}
|
|
/* L1000: */
|
|
}
|
|
|
|
/* --------------------------- The end ---------------------------------
|
|
*/
|
|
|
|
L9999:
|
|
if (*iercod > 0) {
|
|
AdvApp2Var_SysBase::maermsg_("MMDRVCB", iercod, 7L);
|
|
}
|
|
return 0;
|
|
} /* mmdrvcb_ */
|
|
|
|
//=======================================================================
|
|
//function : AdvApp2Var_MathBase::mmdrvck_
|
|
//purpose :
|
|
//=======================================================================
|
|
int AdvApp2Var_MathBase::mmdrvck_(integer *ncoeff,
|
|
integer *ndimen,
|
|
doublereal *courbe,
|
|
integer *ideriv,
|
|
doublereal *tparam,
|
|
doublereal *pntcrb)
|
|
|
|
{
|
|
/* Initialized data */
|
|
|
|
static doublereal mmfack[21] = { 1.,2.,6.,24.,120.,720.,5040.,40320.,
|
|
362880.,3628800.,39916800.,479001600.,6227020800.,87178291200.,
|
|
1.307674368e12,2.0922789888e13,3.55687428096e14,6.402373705728e15,
|
|
1.21645100408832e17,2.43290200817664e18,5.109094217170944e19 };
|
|
|
|
/* System generated locals */
|
|
integer courbe_dim1, courbe_offset, i__1, i__2;
|
|
|
|
/* Local variables */
|
|
static integer i__, j, k, nd;
|
|
static doublereal mfactk, bid;
|
|
|
|
|
|
/* IMPLICIT INTEGER (I-N) */
|
|
/* IMPLICIT DOUBLE PRECISION(A-H,O-Z) */
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* CALCUL DE LA VALEUR D'UNE COURBE DERIVEE D' ORDRE IDERIV EN */
|
|
/* UN POINT DE PARAMETRE TPARAM. */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* POSITIONNEMENT,COURBE,DERIVEE D' ORDRE K. */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* ------------------ */
|
|
/* NCOEFF : Le degre +1 de la courbe. */
|
|
/* NDIMEN : Dimension de l'espace (2 ou 3 en general) */
|
|
/* COURBE : Tableau des coefficients de la courbe. */
|
|
/* IDERIV : Ordre de derivation demande : 1=derivee 1ere, etc... */
|
|
/* TPARAM : Valeur du parametre de la courbe. */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* ------------------- */
|
|
/* PNTCRB : Le point de parametre TPARAM sur la derivee d' ordre */
|
|
/* IDERIV de COURBE. */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ---------------- */
|
|
/* MMCMCNP */
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* ---------------------- */
|
|
/* .Neant. */
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
|
|
/* Le code ci dessous a ete ecrit a partir de l' algorithme suivant :
|
|
*/
|
|
|
|
/* Soit P(t) = a1 + a2*t + ... an*t**n. La derivee d' ordre k de P */
|
|
/* (comportant n-k coefficients) est calculee ainsi : */
|
|
|
|
/* Pk(t) = a(k+1)*CNP(k,k)*k! */
|
|
/* + a(k+2)*CNP(k+1,k)*k! * t */
|
|
/* . */
|
|
/* . */
|
|
/* . */
|
|
/* + a(n)*CNP(n-1,k)*k! * t**(n-k-1). */
|
|
|
|
/* L' evaluation se fait suivant un schema de Horner classique. */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* -------------------------------- */
|
|
/* 8-09-1995 : JMF ; Performance */
|
|
/* 09-01-90 : TE ; COMMON MCCNP -> MMCMCNP.INC & INDICES DES CNP */
|
|
/* 06-07-88 : RBD; Creation, sur une idee de GD. */
|
|
/* > */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
|
|
/* Factorielles (1 a 21) caculees sur VAX en R*16 */
|
|
|
|
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* Sert a fournir les coefficients du binome (triangle de Pascal). */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* Coeff du binome de 0 a 60. read only . init par block data */
|
|
|
|
/* DEMSCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
/* Les coefficients du binome forment une matrice triangulaire. */
|
|
/* On complete cette matrice dans le tableau CNP par sa transposee. */
|
|
/* On a donc: CNP(I,J) = CNP(J,I) pour I et J = 0, ..., 60. */
|
|
|
|
/* L'initialisation est faite a partir du block-data MMLLL09.RES, */
|
|
/* cree par le programme MQINICNP.FOR (voir l'equipe (AC) ). */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* ------------------------------ */
|
|
/* 03-07-90 : RBD; Ajout commentaires (nom du block-data). */
|
|
/* 19-06-90 : RBD; Le commun MMCMCNP remplace MCCNP qui est obsolete.
|
|
*/
|
|
/* 08-01-90 : TE ; CREATION */
|
|
/* > */
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* Parameter adjustments */
|
|
--pntcrb;
|
|
courbe_dim1 = *ndimen;
|
|
courbe_offset = courbe_dim1 + 1;
|
|
courbe -= courbe_offset;
|
|
|
|
/* Function Body */
|
|
|
|
/* -------------- Cas ou l' ordre de derivee est plus -------------------
|
|
*/
|
|
/* ---------------- grand que le degre de la courbe ---------------------
|
|
*/
|
|
|
|
if (*ideriv >= *ncoeff) {
|
|
i__1 = *ndimen;
|
|
for (nd = 1; nd <= i__1; ++nd) {
|
|
pntcrb[nd] = 0.;
|
|
/* L100: */
|
|
}
|
|
goto L9999;
|
|
}
|
|
/* **********************************************************************
|
|
*/
|
|
/* Traitement general */
|
|
/* **********************************************************************
|
|
*/
|
|
/* --------------------- Calcul de Factorielle(IDERIV) ------------------
|
|
*/
|
|
|
|
k = *ideriv;
|
|
if (*ideriv <= 21 && *ideriv > 0) {
|
|
mfactk = mmfack[k - 1];
|
|
} else {
|
|
mfactk = 1.;
|
|
i__1 = k;
|
|
for (i__ = 2; i__ <= i__1; ++i__) {
|
|
mfactk *= i__;
|
|
/* L200: */
|
|
}
|
|
}
|
|
|
|
/* ------- Calcul de la derivee d' ordre IDERIV de COURBE en TPARAM -----
|
|
*/
|
|
/* ---> Attention : le coefficient binomial C(n,m) est represente dans */
|
|
/* MCCNP par CNP(N,M). */
|
|
|
|
i__1 = *ndimen;
|
|
for (nd = 1; nd <= i__1; ++nd) {
|
|
pntcrb[nd] = courbe[nd + *ncoeff * courbe_dim1] * mmcmcnp_.cnp[*
|
|
ncoeff - 1 + k * 61] * mfactk;
|
|
/* L300: */
|
|
}
|
|
|
|
i__1 = k + 1;
|
|
for (j = *ncoeff - 1; j >= i__1; --j) {
|
|
bid = mmcmcnp_.cnp[j - 1 + k * 61] * mfactk;
|
|
i__2 = *ndimen;
|
|
for (nd = 1; nd <= i__2; ++nd) {
|
|
pntcrb[nd] = pntcrb[nd] * *tparam + courbe[nd + j * courbe_dim1] *
|
|
bid;
|
|
/* L500: */
|
|
}
|
|
/* L400: */
|
|
}
|
|
|
|
/* -------------------------------- The end -----------------------------
|
|
*/
|
|
|
|
L9999:
|
|
|
|
return 0 ;
|
|
|
|
} /* mmdrvck_ */
|
|
//=======================================================================
|
|
//function : AdvApp2Var_MathBase::mmeps1_
|
|
//purpose :
|
|
//=======================================================================
|
|
int AdvApp2Var_MathBase::mmeps1_(doublereal *epsilo)
|
|
|
|
{
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* Extraction du EPS1 du COMMON MPRCSN. EPS1 est le zero spatial */
|
|
/* egal a 1.D-9 */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* MPRCSN,PRECISON,EPS1. */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* ------------------ */
|
|
/* Neant */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* ------------------- */
|
|
/* EPSILO : Valeur de EPS1 (Le zero spatial (10**-9)) */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ---------------- */
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* ----------------------- */
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
/* EPS1 est le zero spatial ABSOLU , c.a.d. que l' on doit */
|
|
/* l' utiliser chaque fois que l' on veut tester si une variable */
|
|
/* est nulle. Par exemple, si la norme d' un vecteur est inferieure */
|
|
/* a EPS1, c' est que ce vecteur est NUL ! (lorsqu' on travaille en */
|
|
/* REAL*8) Il est vivement deconseille de tester des arguments par */
|
|
/* rapport a EPS1**2. Vu les erreurs d' arrondis inevitables lors */
|
|
/* des calculs, cela revient a tester par rapport a 0.D0. */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* -------------------------------- */
|
|
/* 29-01-90 : DH ; Nettoyage */
|
|
/* 27-07-88 : RBD; Ajouts de commentaires. */
|
|
/* 29-10-87 : Cree par JJM. */
|
|
/* > */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* DONNE LES TOLERANCES DE NULLITE DANS STRIM */
|
|
/* AINSI QUE LES BORNES DES PROCESSUS ITERATIFS */
|
|
|
|
/* CONTEXTE GENERAL, MODIFIABLE PAR L'UTILISATEUR */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* PARAMETRE , TOLERANCE */
|
|
|
|
/* DEMSCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
/* INITIALISATION : PROFIL , **VIA MPRFTX** A L' ENTREE DANS STRI
|
|
M*/
|
|
|
|
/* CHARGEMENT DES VALEURS PAR DEFAUT DU PROFIL DANS MPRFTX A L'ENTRE
|
|
E*/
|
|
/* DANS STRIM. ELLES SONT CONSERVEES DANS DES VARIABLES LOCALES */
|
|
/* DE MPRFTX */
|
|
|
|
/* REMISE DES VALEURS PAR DEFAUT : MDFINT */
|
|
/* MODIFICATION INTERACTIVE PAR L'UTILISATEUR : MDBINT */
|
|
|
|
/* FONCTION D'ACCES : MMEPS1 ... EPS1 */
|
|
/* MEPSPB ... EPS3,EPS4 */
|
|
/* MEPSLN ... EPS2, NITERM , NITERR */
|
|
/* MEPSNR ... EPS2 , NITERM */
|
|
/* MITERR ... NITERR */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* ------------------------------ */
|
|
/* 01-02-90 : NAK ; ENTETE */
|
|
/* > */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* NITERM : NB D'ITERATIONS MAXIMAL */
|
|
/* NITERR : NB D'ITERATIONS RAPIDES */
|
|
/* EPS1 : TOLERANCE DE DISTANCE 3D NULLE */
|
|
/* EPS2 : TOLERANCE DE DISTANCE PARAMETRIQUE NULLE */
|
|
/* EPS3 : TOLERANCE POUR EVITER LES DIVISIONS PAR 0.. */
|
|
/* EPS4 : TOLERANCE ANGULAIRE */
|
|
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
*epsilo = mmprcsn_.eps1;
|
|
|
|
return 0 ;
|
|
} /* mmeps1_ */
|
|
|
|
//=======================================================================
|
|
//function : mmexthi_
|
|
//purpose :
|
|
//=======================================================================
|
|
int mmexthi_(integer *ndegre,
|
|
doublereal *hwgaus)
|
|
|
|
{
|
|
/* System generated locals */
|
|
integer i__1;
|
|
|
|
/* Local variables */
|
|
static integer iadd, ideb, ndeg2, nmod2, ii, ibb;
|
|
static integer kpt;
|
|
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* Extrait du commun LDGRTL les poids des formules de quadrature de */
|
|
/* Gauss sur toutes les racines des polynomes de Legendre de degre */
|
|
/* NDEGRE defini sur [-1,1]. */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* TOUS, AB_SPECIFI::COMMON&, EXTRACTION, &POIDS, &GAUSS. */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* ------------------ */
|
|
/* NDEGRE : Degre mathematique du polynome de Legendre. On doit avoir */
|
|
/* 2 <= NDEGRE <= 61. */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* ------------------- */
|
|
/* HWGAUS : Le tableau des poids des formules de quadrature de Gauss */
|
|
/* relatifs aux NDEGRE racines d' un polynome de Legendre de */
|
|
/* degre NDEGRE. */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ---------------- */
|
|
/* MLGDRTL */
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* ----------------------- */
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
/* ATTENTION: La condition sur NDEGRE ( 2 <= NDEGRE <= 61) n'est */
|
|
/* pas testee. A l'appelant de faire le test. */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* -------------------------------- */
|
|
/* 23-03-90 : RBD ; Mise a jour en-tete, declaration variables locales, */
|
|
/* correction poids associe racines negatives (bug */
|
|
/* ENORME). */
|
|
/* 15-01-90 : NAK ; MLGDRTL PAR INCLUDE MMLGDRT */
|
|
/* 22-04-88 : JJM ; Creation. */
|
|
/* > */
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
/* Le nom de la routine */
|
|
|
|
|
|
/* Le common MLGDRTL: */
|
|
/* Ce common comprend les racines POSITIVES des polynomes de Legendre */
|
|
/* ET les poids des formules de quadrature de Gauss sur toutes les */
|
|
/* racines POSITIVES des polynomes de Legendre. */
|
|
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* Le common des racines de Legendre. */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* BASE LEGENDRE */
|
|
|
|
/* DEMSCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* ------------------------------ */
|
|
/* 11-01-90 : NAK ; Creation version originale */
|
|
/* > */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
|
|
|
|
|
|
/* ROOTAB : Tableau de toutes les racines des polynomes de Legendre */
|
|
/* comprises entre ]0,1]. Elles sont rangees pour des degres croissants
|
|
*/
|
|
/* de 2 a 61. */
|
|
/* HILTAB : Tableau des interpolants de Legendre concernant ROOTAB. */
|
|
/* L' adressage est le meme. */
|
|
/* HI0TAB : Tableau des interpolants de Legendre pour la racine x=0 */
|
|
/* des polynomes de degre IMPAIR. */
|
|
/* RTLTB0 : Tableau des Li(uk) ou les uk sont les racines d' un */
|
|
/* polynome de Legendre de degre PAIR. */
|
|
/* RTLTB1 : Tableau des Li(uk) ou les uk sont les racines d' un */
|
|
/* polynome de Legendre de degre IMPAIR. */
|
|
|
|
|
|
/************************************************************************
|
|
*****/
|
|
/* Parameter adjustments */
|
|
--hwgaus;
|
|
|
|
/* Function Body */
|
|
ibb = AdvApp2Var_SysBase::mnfndeb_();
|
|
if (ibb >= 3) {
|
|
AdvApp2Var_SysBase::mgenmsg_("MMEXTHI", 7L);
|
|
}
|
|
|
|
ndeg2 = *ndegre / 2;
|
|
nmod2 = *ndegre % 2;
|
|
|
|
/* Adresse du poids de Gauss associe a la 1ere racine strictement */
|
|
/* positive du polynome de Legendre de degre NDEGRE dans MLGDRTL. */
|
|
|
|
iadd = ndeg2 * (ndeg2 - 1) / 2 + 1;
|
|
|
|
/* Indice du 1er element de HWGAUS associe a la 1ere racine */
|
|
/* strictement positive du polynome de Legendre de degre NDEGRE. */
|
|
|
|
ideb = (*ndegre + 1) / 2 + 1;
|
|
|
|
/* Lecture des poids associes aux racines strictement positives. */
|
|
|
|
i__1 = *ndegre;
|
|
for (ii = ideb; ii <= i__1; ++ii) {
|
|
kpt = iadd + ii - ideb;
|
|
hwgaus[ii] = mlgdrtl_.hiltab[kpt + nmod2 * 465 - 1];
|
|
/* L100: */
|
|
}
|
|
|
|
/* Pour les racines strictement negatives, les poids sont les memes. */
|
|
/* i.e HW(1) = HW(NDEGRE), HW(2) = HW(NDEGRE-1), etc... */
|
|
|
|
i__1 = ndeg2;
|
|
for (ii = 1; ii <= i__1; ++ii) {
|
|
hwgaus[ii] = hwgaus[*ndegre + 1 - ii];
|
|
/* L200: */
|
|
}
|
|
|
|
/* Cas NDEGRE impair, 0 est racine du polynome de Legendre, on */
|
|
/* charge le poids de Gauss associe. */
|
|
|
|
if (nmod2 == 1) {
|
|
hwgaus[ndeg2 + 1] = mlgdrtl_.hi0tab[ndeg2];
|
|
}
|
|
|
|
/* --------------------------- The end ----------------------------------
|
|
*/
|
|
|
|
if (ibb >= 3) {
|
|
AdvApp2Var_SysBase::mgsomsg_("MMEXTHI", 7L);
|
|
}
|
|
return 0;
|
|
} /* mmexthi_ */
|
|
|
|
//=======================================================================
|
|
//function : mmextrl_
|
|
//purpose :
|
|
//=======================================================================
|
|
int mmextrl_(integer *ndegre,
|
|
doublereal *rootlg)
|
|
{
|
|
/* System generated locals */
|
|
integer i__1;
|
|
|
|
/* Local variables */
|
|
static integer iadd, ideb, ndeg2, nmod2, ii, ibb;
|
|
static integer kpt;
|
|
|
|
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* Extrait du Common LDGRTL les racines du polynome de Legendre */
|
|
/* de degre NDEGRE defini sur [-1,1]. */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* TOUS, AB_SPECIFI::COMMON&, EXTRACTION, &RACINE, &LEGENDRE. */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* ------------------ */
|
|
/* NDEGRE : Degre mathematique du polynome de Legendre. On doit avoir */
|
|
/* 2 <= NDEGRE <= 61. */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* ------------------- */
|
|
/* ROOTLG : Le tableau des racines du polynome de Legendre de degre */
|
|
/* NDEGRE et defini sur [-1,1]. */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ---------------- */
|
|
/* MLGDRTL */
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* ----------------------- */
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
/* ATTENTION: La condition sur NDEGRE ( 2 <= NDEGRE <= 61) n'est */
|
|
/* pas testee. A l'appelant de faire le test. */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* -------------------------------- */
|
|
/* 23-03-90 : RBD ; Ajout commentaires + declarations. */
|
|
/* 15-01-90 : NAK ; MLGDRTL PAR INCLUDE MMLGDRT */
|
|
/* 04-03-88 : JJM ; Raccoursissement de MLGDRTL. */
|
|
/* 22-02-88 : JJM ; Appel MFNDEB -> MNFNDEB */
|
|
/* 23-10-87 : JJM ; Cree par JJM */
|
|
/* > */
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
|
|
/* Le nom de la routine */
|
|
|
|
|
|
/* Le common MLGDRTL: */
|
|
/* Ce common comprend les racines POSITIVES des polynomes de Legendre */
|
|
/* ET les poids des formules de quadrature de Gauss sur toutes les */
|
|
/* racines POSITIVES des polynomes de Legendre. */
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* Le common des racines de Legendre. */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* BASE LEGENDRE */
|
|
|
|
/* DEMSCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* ------------------------------ */
|
|
/* 11-01-90 : NAK ; Creation version originale */
|
|
/* > */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
|
|
|
|
|
|
/* ROOTAB : Tableau de toutes les racines des polynomes de Legendre */
|
|
/* comprises entre ]0,1]. Elles sont rangees pour des degres croissants
|
|
*/
|
|
/* de 2 a 61. */
|
|
/* HILTAB : Tableau des interpolants de Legendre concernant ROOTAB. */
|
|
/* L' adressage est le meme. */
|
|
/* HI0TAB : Tableau des interpolants de Legendre pour la racine x=0 */
|
|
/* des polynomes de degre IMPAIR. */
|
|
/* RTLTB0 : Tableau des Li(uk) ou les uk sont les racines d' un */
|
|
/* polynome de Legendre de degre PAIR. */
|
|
/* RTLTB1 : Tableau des Li(uk) ou les uk sont les racines d' un */
|
|
/* polynome de Legendre de degre IMPAIR. */
|
|
|
|
|
|
/************************************************************************
|
|
*****/
|
|
/* Parameter adjustments */
|
|
--rootlg;
|
|
|
|
/* Function Body */
|
|
ibb = AdvApp2Var_SysBase::mnfndeb_();
|
|
if (ibb >= 3) {
|
|
AdvApp2Var_SysBase::mgenmsg_("MMEXTRL", 7L);
|
|
}
|
|
|
|
ndeg2 = *ndegre / 2;
|
|
nmod2 = *ndegre % 2;
|
|
|
|
/* Adresse de la 1ere racine strictement positive du polynome de */
|
|
/* Legendre de degre NDEGRE dans MLGDRTL. */
|
|
|
|
iadd = ndeg2 * (ndeg2 - 1) / 2 + 1;
|
|
|
|
/* Indice, dans ROOTLG, de la 1ere racine strictement positive du */
|
|
/* polynome de Legendre de degre NDEGRE. */
|
|
|
|
ideb = (*ndegre + 1) / 2 + 1;
|
|
|
|
/* Lecture des racines strictement positives. */
|
|
|
|
i__1 = *ndegre;
|
|
for (ii = ideb; ii <= i__1; ++ii) {
|
|
kpt = iadd + ii - ideb;
|
|
rootlg[ii] = mlgdrtl_.rootab[kpt + nmod2 * 465 - 1];
|
|
/* L100: */
|
|
}
|
|
|
|
/* Les racines strictement negatives sont egales aux racines positives
|
|
*/
|
|
/* au signe pres i.e RT(1) = -RT(NDEGRE), RT(2) = -RT(NDEGRE-1), etc...
|
|
*/
|
|
|
|
i__1 = ndeg2;
|
|
for (ii = 1; ii <= i__1; ++ii) {
|
|
rootlg[ii] = -rootlg[*ndegre + 1 - ii];
|
|
/* L200: */
|
|
}
|
|
|
|
/* Cas NDEGRE impair, 0 est racine du polynome de Legendre. */
|
|
|
|
if (nmod2 == 1) {
|
|
rootlg[ndeg2 + 1] = 0.;
|
|
}
|
|
|
|
/* -------------------------------- THE END -----------------------------
|
|
*/
|
|
|
|
if (ibb >= 3) {
|
|
AdvApp2Var_SysBase::mgenmsg_("MMEXTRL", 7L);
|
|
}
|
|
return 0;
|
|
} /* mmextrl_ */
|
|
|
|
//=======================================================================
|
|
//function : AdvApp2Var_MathBase::mmfmca8_
|
|
//purpose :
|
|
//=======================================================================
|
|
int AdvApp2Var_MathBase::mmfmca8_(integer *ndimen,
|
|
integer *ncoefu,
|
|
integer *ncoefv,
|
|
integer *ndimax,
|
|
integer *ncfumx,
|
|
integer *,//ncfvmx,
|
|
doublereal *tabini,
|
|
doublereal *tabres)
|
|
|
|
{
|
|
/* System generated locals */
|
|
integer tabini_dim1, tabini_dim2, tabini_offset, tabres_dim1, tabres_dim2,
|
|
tabres_offset;
|
|
|
|
/* Local variables */
|
|
static integer i__, j, k, ilong;
|
|
|
|
|
|
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* Expansion d' un tableau ne contenant que l' essentiel */
|
|
/* en un tableau de donnees plus grand. */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* TOUS, MATH_ACCES:: CARREAU&, DECOMPRESSION, &CARREAU */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* ------------------ */
|
|
/* NDIMEN: Dimension de l' espace de travail. */
|
|
/* NCOEFU: Le degre +1 du tableau en u. */
|
|
/* NCOEFV: Le degre +1 du tableau en v. */
|
|
/* NDIMAX: Dimension maxi de l' espace. */
|
|
/* NCFUMX: Degre maximal +1 du tableau en u. */
|
|
/* NCFVMX: Degre maximal +1 du tableau en v. */
|
|
/* TABINI: Le tableau a decompacter. */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* ------------------- */
|
|
/* TABRES: Le tableau decompacte. */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ---------------- */
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* ----------------------- */
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
/* L' appel suivant : */
|
|
|
|
/* CALL MMFMCA8(NDIMEN,NCOEFU,NCOEFV,NDIMAX,NCFUMX,NCFVMX,TABINI,TABINI)
|
|
*/
|
|
|
|
/* ou TABINI est un argument d' entree/sortie, est possible pourvu */
|
|
/* que l' appelant ait declare TABINI en (NDIMAX,NCFUMX,NCFVMX) */
|
|
|
|
/* ATTENTION : on ne verifie pas que NDIMAX >= NDIMEN, */
|
|
/* NCOEFU >= NCFMXU et NCOEFV >= NCFMXV. */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* -------------------------------- */
|
|
/* 03-08-1989 : RBD; Creation */
|
|
/* > */
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
|
|
/* Parameter adjustments */
|
|
tabini_dim1 = *ndimen;
|
|
tabini_dim2 = *ncoefu;
|
|
tabini_offset = tabini_dim1 * (tabini_dim2 + 1) + 1;
|
|
tabini -= tabini_offset;
|
|
tabres_dim1 = *ndimax;
|
|
tabres_dim2 = *ncfumx;
|
|
tabres_offset = tabres_dim1 * (tabres_dim2 + 1) + 1;
|
|
tabres -= tabres_offset;
|
|
|
|
/* Function Body */
|
|
if (*ndimax == *ndimen) {
|
|
goto L1000;
|
|
}
|
|
|
|
/* ----------------------- decompression NDIMAX<>NDIMEN -----------------
|
|
*/
|
|
|
|
for (k = *ncoefv; k >= 1; --k) {
|
|
for (j = *ncoefu; j >= 1; --j) {
|
|
for (i__ = *ndimen; i__ >= 1; --i__) {
|
|
tabres[i__ + (j + k * tabres_dim2) * tabres_dim1] = tabini[
|
|
i__ + (j + k * tabini_dim2) * tabini_dim1];
|
|
/* L300: */
|
|
}
|
|
/* L200: */
|
|
}
|
|
/* L100: */
|
|
}
|
|
goto L9999;
|
|
|
|
/* ----------------------- decompression NDIMAX=NDIMEN ------------------
|
|
*/
|
|
|
|
L1000:
|
|
if (*ncoefu == *ncfumx) {
|
|
goto L2000;
|
|
}
|
|
ilong = (*ndimen << 3) * *ncoefu;
|
|
for (k = *ncoefv; k >= 1; --k) {
|
|
AdvApp2Var_SysBase::mcrfill_((integer *)&ilong,
|
|
(char *)&tabini[(k * tabini_dim2 + 1) * tabini_dim1 + 1],
|
|
(char *)&tabres[(k * tabres_dim2 + 1) * tabres_dim1 + 1]);
|
|
/* L500: */
|
|
}
|
|
goto L9999;
|
|
|
|
/* ----------------- decompression NDIMAX=NDIMEN,NCOEFU=NCFUMX ----------
|
|
*/
|
|
|
|
L2000:
|
|
ilong = (*ndimen << 3) * *ncoefu * *ncoefv;
|
|
AdvApp2Var_SysBase::mcrfill_((integer *)&ilong,
|
|
(char *)&tabini[tabini_offset],
|
|
(char *)&tabres[tabres_offset]);
|
|
goto L9999;
|
|
|
|
/* ---------------------------- The end ---------------------------------
|
|
*/
|
|
|
|
L9999:
|
|
return 0;
|
|
} /* mmfmca8_ */
|
|
|
|
//=======================================================================
|
|
//function : AdvApp2Var_MathBase::mmfmca9_
|
|
//purpose :
|
|
//=======================================================================
|
|
int AdvApp2Var_MathBase::mmfmca9_(integer *ndimax,
|
|
integer *ncfumx,
|
|
integer *,//ncfvmx,
|
|
integer *ndimen,
|
|
integer *ncoefu,
|
|
integer *ncoefv,
|
|
doublereal *tabini,
|
|
doublereal *tabres)
|
|
|
|
{
|
|
/* System generated locals */
|
|
integer tabini_dim1, tabini_dim2, tabini_offset, tabres_dim1, tabres_dim2,
|
|
tabres_offset, i__1, i__2, i__3;
|
|
|
|
/* Local variables */
|
|
static integer i__, j, k, ilong;
|
|
|
|
|
|
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* Compression d' un tableau de donnees en un tableau ne */
|
|
/* contenant que l' essentiel (Le tableau d' entree n' est */
|
|
/* pas ecrase). */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* TOUS, MATH_ACCES:: CARREAU&, COMPRESSION, &CARREAU */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* ------------------ */
|
|
/* NDIMAX: Dimension maxi de l' espace. */
|
|
/* NCFUMX: Degre maximal +1 du tableau en u. */
|
|
/* NCFVMX: Degre maximal +1 du tableau en v. */
|
|
/* NDIMEN: Dimension de l' espace de travail. */
|
|
/* NCOEFU: Le degre +1 du tableau en u. */
|
|
/* NCOEFV: Le degre +1 du tableau en v. */
|
|
/* TABINI: Le tableau a compacter. */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* ------------------- */
|
|
/* TABRES: Le tableau compacte. */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ---------------- */
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* ----------------------- */
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
/* L' appel suivant : */
|
|
|
|
/* CALL MMFMCA9(NDIMAX,NCFUMX,NCFVMX,NDIMEN,NCOEFU,NCOEFV,TABINI,TABINI)
|
|
*/
|
|
|
|
/* ou TABINI est un argument d' entree/sortie, est possible pourvu */
|
|
/* que l' appelant ait bien verifie que : */
|
|
|
|
/* NDIMAX > NDIMEN, */
|
|
/* ou NDIMAX = NDIMEN et NCFUMX > NCOEFU */
|
|
/* ou NDIMAX = NDIMEN, NCFUMX = NCOEFU et NCFVMX > NCOEFV */
|
|
|
|
/* Ces conditions ne sont pas testees dans le programme. */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* -------------------------------- */
|
|
/* 18-01-199O : RBD ; Creation. */
|
|
/* > */
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
|
|
/* Parameter adjustments */
|
|
tabini_dim1 = *ndimax;
|
|
tabini_dim2 = *ncfumx;
|
|
tabini_offset = tabini_dim1 * (tabini_dim2 + 1) + 1;
|
|
tabini -= tabini_offset;
|
|
tabres_dim1 = *ndimen;
|
|
tabres_dim2 = *ncoefu;
|
|
tabres_offset = tabres_dim1 * (tabres_dim2 + 1) + 1;
|
|
tabres -= tabres_offset;
|
|
|
|
/* Function Body */
|
|
if (*ndimen == *ndimax) {
|
|
goto L1000;
|
|
}
|
|
|
|
/* ----------------------- Compression NDIMEN<>NDIMAX -------------------
|
|
*/
|
|
|
|
i__1 = *ncoefv;
|
|
for (k = 1; k <= i__1; ++k) {
|
|
i__2 = *ncoefu;
|
|
for (j = 1; j <= i__2; ++j) {
|
|
i__3 = *ndimen;
|
|
for (i__ = 1; i__ <= i__3; ++i__) {
|
|
tabres[i__ + (j + k * tabres_dim2) * tabres_dim1] = tabini[
|
|
i__ + (j + k * tabini_dim2) * tabini_dim1];
|
|
/* L300: */
|
|
}
|
|
/* L200: */
|
|
}
|
|
/* L100: */
|
|
}
|
|
goto L9999;
|
|
|
|
/* ----------------------- Compression NDIMEN=NDIMAX --------------------
|
|
*/
|
|
|
|
L1000:
|
|
if (*ncoefu == *ncfumx) {
|
|
goto L2000;
|
|
}
|
|
ilong = (*ndimen << 3) * *ncoefu;
|
|
i__1 = *ncoefv;
|
|
for (k = 1; k <= i__1; ++k) {
|
|
AdvApp2Var_SysBase::mcrfill_((integer *)&ilong,
|
|
(char *)&tabini[(k * tabini_dim2 + 1) * tabini_dim1 + 1],
|
|
(char *)&tabres[(k * tabres_dim2 + 1) * tabres_dim1 + 1]);
|
|
/* L500: */
|
|
}
|
|
goto L9999;
|
|
|
|
/* ----------------- Compression NDIMEN=NDIMAX,NCOEFU=NCFUMX ------------
|
|
*/
|
|
|
|
L2000:
|
|
ilong = (*ndimen << 3) * *ncoefu * *ncoefv;
|
|
AdvApp2Var_SysBase::mcrfill_((integer *)&ilong,
|
|
(char *)&tabini[tabini_offset],
|
|
(char *)&tabres[tabres_offset]);
|
|
goto L9999;
|
|
|
|
/* ---------------------------- The end ---------------------------------
|
|
*/
|
|
|
|
L9999:
|
|
return 0;
|
|
} /* mmfmca9_ */
|
|
|
|
//=======================================================================
|
|
//function : AdvApp2Var_MathBase::mmfmcar_
|
|
//purpose :
|
|
//=======================================================================
|
|
int AdvApp2Var_MathBase::mmfmcar_(integer *ndimen,
|
|
integer *ncofmx,
|
|
integer *ncoefu,
|
|
integer *ncoefv,
|
|
doublereal *patold,
|
|
doublereal *upara1,
|
|
doublereal *upara2,
|
|
doublereal *vpara1,
|
|
doublereal *vpara2,
|
|
doublereal *patnew,
|
|
integer *iercod)
|
|
|
|
{
|
|
static integer c__8 = 8;
|
|
/* System generated locals */
|
|
integer patold_dim1, patold_dim2, patnew_dim1, patnew_dim2,
|
|
i__1, patold_offset,patnew_offset;
|
|
|
|
/* Local variables */
|
|
static doublereal tbaux[1];
|
|
static integer ksize, numax, kk;
|
|
static long int iofst;
|
|
static integer ibb, ier;
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* LIMITATION D'UN CARREAU DEFINI SUR (0,1)*(0,1) ENTRE LES ISOS */
|
|
/* UPARA1 ET UPARA2 (EN U) ET VPARA1 ET VPARA2 EN V. */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* LIMITATION , CARREAU , PARAMETRE */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* ------------------ */
|
|
/* NCOFMX: NBRE MAXI DE COEFF EN U DU CARREAU */
|
|
/* NCOEFU: NBRE DE COEFF EN U DU CARREAU */
|
|
/* NCOEFV: NBRE DE COEFF EN V DU CARREAU */
|
|
/* PATOLD : LE CARREAU A LIMITER SUIVANT UPARA1,UPARA2 ET VPARA1,VPARA2
|
|
.*/
|
|
/* UPARA1 : BORNE INF DES U */
|
|
/* UPARA2 : BORNE SUP DES U */
|
|
/* VPARA1 : BORNE INF DES V */
|
|
/* VPARA2 : BORNE SUP DES V */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* ------------------- */
|
|
/* PATNEW : LE CARREAU RELIMITE, DEFINI DANS (0,1)**2 */
|
|
/* IERCOD : =10 NBR DE COEFF TROP GRAND OU NUL */
|
|
/* =13 PB DANS L' ALLOCATION DYNAMIQUE */
|
|
/* = 0 OK. */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ---------------- */
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* ----------------------- */
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
/* ---> L' appel suivant : */
|
|
/* CALL MMFMCAR(NCOFMX,NCOEFU,NCOEFV,PATOLD,UPARA1,UPARA2,VPARA1,VPARA2
|
|
*/
|
|
/* ,PATOLD), */
|
|
/* ou PATOLD est un argument d' entree/sortie est tout a fait */
|
|
/* legal. */
|
|
|
|
/* ---> Le nombre maximum de coeff en u et en v de PATOLD est 61 */
|
|
|
|
/* ---> Si NCOEFU < NCOFMX, on compresse les donnees par MMFMCA9 avant
|
|
*/
|
|
/* la limitation en v pour gagner du temps lors de l' execution */
|
|
/* de MMARC41 qui suit (le carreau est traite comme une courbe de
|
|
*/
|
|
/* dimension NDIMEN*NCOEFU possedant NCOEFV coefficients). */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* -------------------------------- */
|
|
/* 02-08-89 : RBD; CREATION. */
|
|
/* > */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* Le nom de la routine */
|
|
|
|
|
|
/* Parameter adjustments */
|
|
patnew_dim1 = *ndimen;
|
|
patnew_dim2 = *ncofmx;
|
|
patnew_offset = patnew_dim1 * (patnew_dim2 + 1) + 1;
|
|
patnew -= patnew_offset;
|
|
patold_dim1 = *ndimen;
|
|
patold_dim2 = *ncofmx;
|
|
patold_offset = patold_dim1 * (patold_dim2 + 1) + 1;
|
|
patold -= patold_offset;
|
|
|
|
/* Function Body */
|
|
ibb = AdvApp2Var_SysBase::mnfndeb_();
|
|
if (ibb >= 2) {
|
|
AdvApp2Var_SysBase::mgenmsg_("MMFMCAR", 7L);
|
|
}
|
|
*iercod = 0;
|
|
iofst = 0;
|
|
|
|
/* **********************************************************************
|
|
*/
|
|
/* TEST DES NOMBRES DE COEFFICIENTS */
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
if (*ncofmx < *ncoefu) {
|
|
*iercod = 10;
|
|
goto L9999;
|
|
}
|
|
if (*ncoefu < 1 || *ncoefu > 61 || *ncoefv < 1 || *ncoefv > 61) {
|
|
*iercod = 10;
|
|
goto L9999;
|
|
}
|
|
|
|
/* **********************************************************************
|
|
*/
|
|
/* CAS OU UPARA1=VPARA1=0 ET UPARA2=VPARA2=1 */
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
if (*upara1 == 0. && *upara2 == 1. && *vpara1 == 0. && *vpara2 == 1.) {
|
|
ksize = (*ndimen << 3) * *ncofmx * *ncoefv;
|
|
AdvApp2Var_SysBase::mcrfill_((integer *)&ksize,
|
|
(char *)&patold[patold_offset],
|
|
(char *)&patnew[patnew_offset]);
|
|
goto L9999;
|
|
}
|
|
|
|
/* **********************************************************************
|
|
*/
|
|
/* LIMITATION EN U */
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
if (*upara1 == 0. && *upara2 == 1.) {
|
|
goto L2000;
|
|
}
|
|
i__1 = *ncoefv;
|
|
for (kk = 1; kk <= i__1; ++kk) {
|
|
mmarc41_(ndimen, ndimen, ncoefu, &patold[(kk * patold_dim2 + 1) *
|
|
patold_dim1 + 1], upara1, upara2, &patnew[(kk * patnew_dim2 +
|
|
1) * patnew_dim1 + 1], iercod);
|
|
/* L100: */
|
|
}
|
|
|
|
/* **********************************************************************
|
|
*/
|
|
/* LIMITATION EN V */
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
L2000:
|
|
if (*vpara1 == 0. && *vpara2 == 1.) {
|
|
goto L9999;
|
|
}
|
|
|
|
/* ----------- LIMITATION EN V (AVEC COMPRESSION I.E. NCOEFU<NCOFMX) ----
|
|
*/
|
|
|
|
numax = *ndimen * *ncoefu;
|
|
if (*ncofmx != *ncoefu) {
|
|
/* ------------------------- Allocation dynamique -------------------
|
|
---- */
|
|
ksize = *ndimen * *ncoefu * *ncoefv;
|
|
AdvApp2Var_SysBase::mcrrqst_(&c__8, &ksize, tbaux, &iofst, &ier);
|
|
if (ier > 0) {
|
|
*iercod = 13;
|
|
goto L9900;
|
|
}
|
|
/* --------------- Compression en (NDIMEN,NCOEFU,NCOEFV) ------------
|
|
---- */
|
|
if (*upara1 == 0. && *upara2 == 1.) {
|
|
AdvApp2Var_MathBase::mmfmca9_(ndimen,
|
|
ncofmx,
|
|
ncoefv,
|
|
ndimen,
|
|
ncoefu,
|
|
ncoefv,
|
|
&patold[patold_offset],
|
|
&tbaux[iofst]);
|
|
} else {
|
|
AdvApp2Var_MathBase::mmfmca9_(ndimen,
|
|
ncofmx,
|
|
ncoefv,
|
|
ndimen,
|
|
ncoefu,
|
|
ncoefv,
|
|
&patnew[patnew_offset],
|
|
&tbaux[iofst]);
|
|
}
|
|
/* ------------------------- Limitation en v ------------------------
|
|
---- */
|
|
mmarc41_(&numax, &numax, ncoefv, &tbaux[iofst], vpara1, vpara2, &
|
|
tbaux[iofst], iercod);
|
|
/* --------------------- Expansion de TBAUX dans PATNEW -------------
|
|
--- */
|
|
AdvApp2Var_MathBase::mmfmca8_(ndimen, ncoefu, ncoefv, ndimen, ncofmx, ncoefv, &tbaux[iofst]
|
|
, &patnew[patnew_offset]);
|
|
goto L9900;
|
|
|
|
/* -------- LIMITATION EN V (SANS COMPRESSION I.E. NCOEFU=NCOFMX) ---
|
|
---- */
|
|
|
|
} else {
|
|
if (*upara1 == 0. && *upara2 == 1.) {
|
|
mmarc41_(&numax, &numax, ncoefv, &patold[patold_offset], vpara1,
|
|
vpara2, &patnew[patnew_offset], iercod);
|
|
} else {
|
|
mmarc41_(&numax, &numax, ncoefv, &patnew[patnew_offset], vpara1,
|
|
vpara2, &patnew[patnew_offset], iercod);
|
|
}
|
|
goto L9999;
|
|
}
|
|
|
|
/* **********************************************************************
|
|
*/
|
|
/* DESALLOCATION */
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
L9900:
|
|
if (iofst != 0) {
|
|
AdvApp2Var_SysBase::mcrdelt_(&c__8, &ksize, tbaux, &iofst, &ier);
|
|
}
|
|
if (ier > 0) {
|
|
*iercod = 13;
|
|
}
|
|
|
|
/* ------------------------------ The end -------------------------------
|
|
*/
|
|
|
|
L9999:
|
|
if (*iercod > 0) {
|
|
AdvApp2Var_SysBase::maermsg_("MMFMCAR", iercod, 7L);
|
|
}
|
|
if (ibb >= 2) {
|
|
AdvApp2Var_SysBase::mgsomsg_("MMFMCAR", 7L);
|
|
}
|
|
return 0;
|
|
} /* mmfmcar_ */
|
|
|
|
|
|
//=======================================================================
|
|
//function : AdvApp2Var_MathBase::mmfmcb5_
|
|
//purpose :
|
|
//=======================================================================
|
|
int AdvApp2Var_MathBase::mmfmcb5_(integer *isenmsc,
|
|
integer *ndimax,
|
|
integer *ncf1mx,
|
|
doublereal *courb1,
|
|
integer *ncoeff,
|
|
integer *ncf2mx,
|
|
integer *ndimen,
|
|
doublereal *courb2,
|
|
integer *iercod)
|
|
|
|
{
|
|
/* System generated locals */
|
|
integer courb1_dim1, courb1_offset, courb2_dim1, courb2_offset, i__1,
|
|
i__2;
|
|
|
|
/* Local variables */
|
|
static integer i__, nboct, nd;
|
|
|
|
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* Reformattage (et compactage/decompactage eventuel) de courbe */
|
|
/* (ndim,.) en (.,ndim) et reciproquement . */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* TOUS , MATH_ACCES :: */
|
|
/* COURBE&, REORGANISATION,COMPRESSION,INVERSION , &COURBE */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* -------------------- */
|
|
/* ISENMSC : sens du transfert demande : */
|
|
/* 1 : passage de (NDIMEN,.) ---> (.,NDIMEN) sens vers AB
|
|
*/
|
|
/* -1 : passage de (.,NDIMEN) ---> (NDIMEN,.) sens vers TS,T
|
|
V*/
|
|
/* NDIMAX : format / dimension */
|
|
/* NCF1MX : format en t de COURB1 */
|
|
/* si ISENMSC= 1 : COURB1: La courbe a traiter (NDIMAX,.) */
|
|
/* NCOEFF : nombre de coef de la courbe */
|
|
/* NCF2MX : format en t de COURB2 */
|
|
/* NDIMEN : dimension de la courbe et format de COURB2 */
|
|
/* si ISENMSC=-1 : COURB2: La courbe a traiter (.,NDIMEN) */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* --------------------- */
|
|
/* si ISENMSC= 1 : COURB2: La courbe resultat (.,NDIMEN) */
|
|
/* si ISENMSC=-1 : COURB1: La courbe resultat (NDIMAX,.) */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ------------------ */
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* --------------------- */
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
/* permet de traiter les transferts usuels suivant : */
|
|
/* | ---- ISENMSC = 1 ---- | | ---- ISENMSC =-1 ----- | */
|
|
/* TS (3,21) --> (21,3) AB ; AB (21,3) --> (3,21) TS */
|
|
/* TS (3,21) --> (NU,3) AB ; AB (NU,3) --> (3,21) TS */
|
|
/* (3,NU) --> (21,3) AB ; AB (21,3) --> (3,NU) */
|
|
/* (3,NU) --> (NU,3) AB ; AB (NU,3) --> (3,NU) */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* ------------------------------ */
|
|
/* .07-08-89 : JG ; VERSION ORIGINALE (ANNULE ET REMPLACE MMCVINV)
|
|
*/
|
|
/* > */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
|
|
/* Parameter adjustments */
|
|
courb1_dim1 = *ndimax;
|
|
courb1_offset = courb1_dim1 + 1;
|
|
courb1 -= courb1_offset;
|
|
courb2_dim1 = *ncf2mx;
|
|
courb2_offset = courb2_dim1 + 1;
|
|
courb2 -= courb2_offset;
|
|
|
|
/* Function Body */
|
|
if (*ndimen > *ndimax || *ncoeff > *ncf1mx || *ncoeff > *ncf2mx) {
|
|
goto L9119;
|
|
}
|
|
|
|
if (*ndimen == 1 && *ncf1mx == *ncf2mx) {
|
|
nboct = *ncf2mx << 3;
|
|
if (*isenmsc == 1) {
|
|
AdvApp2Var_SysBase::mcrfill_((integer *)&nboct,
|
|
(char *)&courb1[courb1_offset],
|
|
(char *)&courb2[courb2_offset]);
|
|
}
|
|
if (*isenmsc == -1) {
|
|
AdvApp2Var_SysBase::mcrfill_((integer *)&nboct,
|
|
(char *)&courb2[courb2_offset],
|
|
(char *)&courb1[courb1_offset]);
|
|
}
|
|
*iercod = -3136;
|
|
goto L9999;
|
|
}
|
|
|
|
*iercod = 0;
|
|
if (*isenmsc == 1) {
|
|
i__1 = *ndimen;
|
|
for (nd = 1; nd <= i__1; ++nd) {
|
|
i__2 = *ncoeff;
|
|
for (i__ = 1; i__ <= i__2; ++i__) {
|
|
courb2[i__ + nd * courb2_dim1] = courb1[nd + i__ *
|
|
courb1_dim1];
|
|
/* L400: */
|
|
}
|
|
/* L500: */
|
|
}
|
|
} else if (*isenmsc == -1) {
|
|
i__1 = *ndimen;
|
|
for (nd = 1; nd <= i__1; ++nd) {
|
|
i__2 = *ncoeff;
|
|
for (i__ = 1; i__ <= i__2; ++i__) {
|
|
courb1[nd + i__ * courb1_dim1] = courb2[i__ + nd *
|
|
courb2_dim1];
|
|
/* L1400: */
|
|
}
|
|
/* L1500: */
|
|
}
|
|
} else {
|
|
*iercod = 3164;
|
|
}
|
|
|
|
goto L9999;
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
L9119:
|
|
*iercod = 3119;
|
|
|
|
L9999:
|
|
if (*iercod != 0) {
|
|
AdvApp2Var_SysBase::maermsg_("MMFMCB5", iercod, 7L);
|
|
}
|
|
return 0;
|
|
} /* mmfmcb5_ */
|
|
|
|
//=======================================================================
|
|
//function : AdvApp2Var_MathBase::mmfmtb1_
|
|
//purpose :
|
|
//=======================================================================
|
|
int AdvApp2Var_MathBase::mmfmtb1_(integer *maxsz1,
|
|
doublereal *table1,
|
|
integer *isize1,
|
|
integer *jsize1,
|
|
integer *maxsz2,
|
|
doublereal *table2,
|
|
integer *isize2,
|
|
integer *jsize2,
|
|
integer *iercod)
|
|
{
|
|
static integer c__8 = 8;
|
|
|
|
/* System generated locals */
|
|
integer table1_dim1, table1_offset, table2_dim1, table2_offset, i__1,
|
|
i__2;
|
|
|
|
/* Local variables */
|
|
static doublereal work[1];
|
|
static integer ilong, isize, ii, jj, ier;
|
|
static long int iofst,iipt, jjpt;
|
|
|
|
|
|
/************************************************************************
|
|
*******/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* Inversion des elements d'un tableau rectangulaire (T1(i,j) */
|
|
/* est charge dans T2(j,i)) */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* TOUS, MATH_ACCES :: TABLEAU&, INVERSION, &TABLEAU */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* ------------------ */
|
|
/* MAXSZ1: Nbre maxi d'elements suivant la 1ere dimension de */
|
|
/* TABLE1. */
|
|
/* TABLE1: Table de reels a deux dimensions. */
|
|
/* ISIZE1: Nbre d'elements utiles de TABLE1 sur la 1ere dimension */
|
|
/* JSIZE1: Nbre d'elements utiles de TABLE1 sur la 2eme dimension */
|
|
/* MAXSZ2: Nbre maxi d'elements suivant la 1ere dimension de */
|
|
/* TABLE2. */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* ------------------- */
|
|
/* TABLE2: Table de reels a deux dimensions, contenant la transposee
|
|
*/
|
|
/* du tableau rectangulaire TABLE1. */
|
|
/* ISIZE2: Nbre d'elements utiles de TABLE2 sur la 1ere dimension */
|
|
/* JSIZE2: Nbre d'elements utiles de TABLE2 sur la 2eme dimension */
|
|
/* IERCOD: Code d'erreur. */
|
|
/* = 0, ok. */
|
|
/* = 1, erreur dans le dimensionnement des tables */
|
|
/* soit MAXSZ1 < ISIZE1 (tableau TABLE1 trop petit). */
|
|
/* soit MAXSZ2 < JSIZE1 (tableau TABLE2 trop petit). */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ---------------- */
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* ---------------------- */
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
/* On peut utiliser TABLE1 comme tableau d'entree et de sortie i.e. */
|
|
/* l'appel: */
|
|
/* CALL MMFMTB1(MAXSZ1,TABLE1,ISIZE1,JSIZE1,MAXSZ2,TABLE1 */
|
|
/* ,ISIZE2,JSIZE2,IERCOD) */
|
|
/* est valable. */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* -------------------------------- */
|
|
/* 07-06-91: RBD; Creation d'apres VCRINV de NAK. */
|
|
/* > */
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
|
|
/* Parameter adjustments */
|
|
table1_dim1 = *maxsz1;
|
|
table1_offset = table1_dim1 + 1;
|
|
table1 -= table1_offset;
|
|
table2_dim1 = *maxsz2;
|
|
table2_offset = table2_dim1 + 1;
|
|
table2 -= table2_offset;
|
|
|
|
/* Function Body */
|
|
*iercod = 0;
|
|
if (*isize1 > *maxsz1 || *jsize1 > *maxsz2) {
|
|
goto L9100;
|
|
}
|
|
|
|
iofst = 0;
|
|
isize = *maxsz2 * *isize1;
|
|
AdvApp2Var_SysBase::mcrrqst_(&c__8, &isize, work, &iofst, &ier);
|
|
if (ier > 0) {
|
|
goto L9200;
|
|
}
|
|
|
|
/* NE PAS CRAINDRE D'ECRASEMENT. */
|
|
|
|
i__1 = *isize1;
|
|
for (ii = 1; ii <= i__1; ++ii) {
|
|
iipt = (ii - 1) * *maxsz2 + iofst;
|
|
i__2 = *jsize1;
|
|
for (jj = 1; jj <= i__2; ++jj) {
|
|
jjpt = iipt + (jj - 1);
|
|
work[jjpt] = table1[ii + jj * table1_dim1];
|
|
/* L200: */
|
|
}
|
|
/* L100: */
|
|
}
|
|
ilong = isize << 3;
|
|
AdvApp2Var_SysBase::mcrfill_((integer *)&ilong,
|
|
(char *)&work[iofst],
|
|
(char *)&table2[table2_offset]);
|
|
|
|
/* -------------- On recupere le nombre d'elements de TABLE2 ------------
|
|
*/
|
|
|
|
ii = *isize1;
|
|
*isize2 = *jsize1;
|
|
*jsize2 = ii;
|
|
|
|
goto L9999;
|
|
|
|
/* ------------------------------- THE END ------------------------------
|
|
*/
|
|
/* --> Entree invalide. */
|
|
L9100:
|
|
*iercod = 1;
|
|
goto L9999;
|
|
/* --> Pb d'alloc. */
|
|
L9200:
|
|
*iercod = 2;
|
|
goto L9999;
|
|
|
|
L9999:
|
|
if (iofst != 0) {
|
|
AdvApp2Var_SysBase::mcrdelt_(&c__8, &isize, work, &iofst, &ier);
|
|
}
|
|
if (ier > 0) {
|
|
*iercod = 2;
|
|
}
|
|
return 0;
|
|
} /* mmfmtb1_ */
|
|
|
|
//=======================================================================
|
|
//function : AdvApp2Var_MathBase::mmgaus1_
|
|
//purpose :
|
|
//=======================================================================
|
|
int AdvApp2Var_MathBase::mmgaus1_(integer *ndimf,
|
|
int (*bfunx) (
|
|
integer *ninteg,
|
|
doublereal *parame,
|
|
doublereal *vfunj1,
|
|
integer *iercod
|
|
),
|
|
|
|
integer *k,
|
|
doublereal *xd,
|
|
doublereal *xf,
|
|
doublereal *saux1,
|
|
doublereal *saux2,
|
|
doublereal *somme,
|
|
integer *niter,
|
|
integer *iercod)
|
|
{
|
|
/* System generated locals */
|
|
integer i__1, i__2;
|
|
|
|
/* Local variables */
|
|
static integer ndeg;
|
|
static doublereal h__[20];
|
|
static integer j;
|
|
static doublereal t, u[20], x;
|
|
static integer idimf;
|
|
static doublereal c1x, c2x;
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* -------- */
|
|
|
|
/* Calcul de l'integrale de la fonction BFUNX passee en parametre */
|
|
/* entre les bornes XD et XF . */
|
|
/* La fonction doit etre calculable pour n'importe quelle valeur */
|
|
/* de la variable dans l'intervalle donne.. */
|
|
/* La methode utilisee est celle de GAUSS-LEGENDRE. Des explications
|
|
*/
|
|
/* peuvent etre obtenus sur le livre : */
|
|
/* Complements de mathematiques a l'usage des Ingenieurs de */
|
|
/* l'electrotechnique et des telecommunications. */
|
|
/* Par Andre ANGOT - Collection technique et scientifique du CNET
|
|
*/
|
|
/* page 772 .... */
|
|
/* Le degre des polynomes de LEGENDRE utilise est passe en parametre.
|
|
*/
|
|
|
|
/* MOTS CLES : */
|
|
/* --------- */
|
|
/* INTEGRATION,LEGENDRE,GAUSS */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* ------------------ */
|
|
|
|
/* NDIMF : Dimension de la fonction */
|
|
/* BFUNX : Fonction a integrer passee en argument */
|
|
/* Doit etre declaree en EXTERNAL dans la routine d'appel. */
|
|
/* SUBROUTINE BFUNX(NDIMF,X,VAL,IER) */
|
|
/* REAL *8 X,VAL */
|
|
/* K : Parametre determinant le degre du polynome de LEGENDRE qui
|
|
*/
|
|
/* peut prendre une valeur comprise entre 0 et 10. */
|
|
/* Le degre du polynome est egal a 4 k, c'est a dire 4, 8,
|
|
*/
|
|
/* 12, 16, 20, 24, 28, 32, 36 et 40. */
|
|
/* Si K n'est pas bon, le degre est pris a 40 directement.
|
|
*/
|
|
/* XD : Borne inferieure de l'intervalle d'integration. */
|
|
/* XF : Borne superieure de l'intervalle d'integration. */
|
|
/* SAUX1 : Tableau auxiliaire */
|
|
/* SAUX2 : Tableau auxiliaire */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* ------------------- */
|
|
|
|
/* SOMME : Valeur de l'integrale */
|
|
/* NITER : Nombre d'iterations effectues. */
|
|
/* Il est egal au degre du polynome. */
|
|
|
|
/* IER : Code d'erreur : */
|
|
/* < 0 ==> Attention - Warning */
|
|
/* = 0 ==> Tout est OK */
|
|
/* > 0 ==> Erreur severe - Faire un traitement special */
|
|
/* ==> Erreur dans le calcul de BFUNX (code de retour */
|
|
/* de cette routine */
|
|
|
|
/* Si erreur => SOMME = 0 */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ----------------- */
|
|
|
|
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* ---------------------- */
|
|
|
|
/* Type Name */
|
|
/* @ BFUNX MVGAUS0 */
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* --------------------------------- */
|
|
|
|
/* Voir les explications detaillees sur le listing */
|
|
|
|
/* Utilisation de la methode de GAUSS (polynomes orthogonaux) */
|
|
/* On utilise la symetrie des racines de ces polynomes */
|
|
|
|
/* En fonction de K, le degre du polynome d'interpolation augmente.
|
|
*/
|
|
/* Si vous voulez calculer l'integrale avec une precision donnee, */
|
|
/* boucler sur k variant de 1 a 10 et tester la difference de 2 iteres
|
|
*/
|
|
/* consecutifs. Arreter la boucle si cette difference est inferieure
|
|
*/
|
|
/* a une valeur epsilon fixee a 10E-6 par exemple. */
|
|
/* Si S1 et S2 sont 2 iteres successifs, tester suivant cet exemple :
|
|
*/
|
|
|
|
/* AF=DABS(S1-S2) */
|
|
/* AS=DABS(S2) */
|
|
/* Si AS < 1 alors tester si FS < eps sinon tester AF/AS < eps
|
|
*/
|
|
/* -- ----- ----- */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* ---------------------------- */
|
|
/* 3-09-1993 : PMN; CREATION D'APRES VGAUS1 (SAUX1 et SAUX2 en */
|
|
/* arguments) */
|
|
/* . 04-10-89 : JP;AJOUT EXTERNAL BFUNX SGI_420_144 */
|
|
/* . 20-08-87 : JP;INTEGRATION D'UNE FONCTION VECTORIELLE */
|
|
/* . 08-08-87 : GD; Version originale */
|
|
|
|
/* > */
|
|
/************************************************************************
|
|
******/
|
|
/* DECLARATIONS */
|
|
/************************************************************************
|
|
******/
|
|
|
|
|
|
|
|
/* ****** Initialisation generale ** */
|
|
|
|
/* Parameter adjustments */
|
|
--somme;
|
|
--saux2;
|
|
--saux1;
|
|
|
|
/* Function Body */
|
|
AdvApp2Var_SysBase::mvriraz_((integer *)ndimf,
|
|
(char *)&somme[1]);
|
|
*iercod = 0;
|
|
|
|
/* ****** Chargement des coefficients U et H ** */
|
|
/* -------------------------------------------- */
|
|
|
|
mvgaus0_(k, u, h__, &ndeg, iercod);
|
|
if (*iercod > 0) {
|
|
goto L9999;
|
|
}
|
|
|
|
/* ****** C1X => Point milieu intervalle [XD,XF] */
|
|
/* ****** C2X => 1/2 amplitude intervalle [XD,XF] */
|
|
|
|
c1x = (*xf + *xd) * .5;
|
|
c2x = (*xf - *xd) * .5;
|
|
|
|
/* ---------------------------------------- */
|
|
/* ****** Integration pour un degre NDEG ** */
|
|
/* ---------------------------------------- */
|
|
|
|
i__1 = ndeg;
|
|
for (j = 1; j <= i__1; ++j) {
|
|
t = c2x * u[j - 1];
|
|
|
|
x = c1x + t;
|
|
(*bfunx)(ndimf, &x, &saux1[1], iercod);
|
|
if (*iercod != 0) {
|
|
goto L9999;
|
|
}
|
|
|
|
x = c1x - t;
|
|
(*bfunx)(ndimf, &x, &saux2[1], iercod);
|
|
if (*iercod != 0) {
|
|
goto L9999;
|
|
}
|
|
|
|
i__2 = *ndimf;
|
|
for (idimf = 1; idimf <= i__2; ++idimf) {
|
|
somme[idimf] += h__[j - 1] * (saux1[idimf] + saux2[idimf]);
|
|
}
|
|
|
|
}
|
|
|
|
*niter = ndeg << 1;
|
|
i__1 = *ndimf;
|
|
for (idimf = 1; idimf <= i__1; ++idimf) {
|
|
somme[idimf] *= c2x;
|
|
}
|
|
|
|
/* ****** Fin du sous-programme ** */
|
|
|
|
L9999:
|
|
|
|
return 0 ;
|
|
} /* mmgaus1_ */
|
|
//=======================================================================
|
|
//function : mmherm0_
|
|
//purpose :
|
|
//=======================================================================
|
|
int mmherm0_(doublereal *debfin,
|
|
integer *iercod)
|
|
{
|
|
static integer c__576 = 576;
|
|
static integer c__6 = 6;
|
|
|
|
|
|
/* System generated locals */
|
|
integer i__1, i__2;
|
|
doublereal d__1;
|
|
|
|
/* Local variables */
|
|
static doublereal amat[36] /* was [6][6] */;
|
|
static integer iord[2];
|
|
static doublereal prod;
|
|
static integer iord1, iord2;
|
|
static doublereal miden[36] /* was [6][6] */;
|
|
static integer ncmat;
|
|
static doublereal epspi, d1, d2;
|
|
static integer ii, jj, pp, ncf;
|
|
static doublereal cof[6];
|
|
static integer iof[2], ier;
|
|
static doublereal mat[36] /* was [6][6] */;
|
|
static integer cot;
|
|
static doublereal abid[72] /* was [12][6] */;
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* INIT DES COEFFS. DES POLYNOMES D'INTERPOL. D'HERMITE */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* MATH_ACCES :: HERMITE */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* -------------------- */
|
|
/* DEBFIN : PARAMETRES OU SONT DONNEES LES CONTRAINTES */
|
|
/* DEBFIN(1) : PREMIER PARAMETRE */
|
|
/* DEBFIN(2) : DEUXIEME PARAMETRE */
|
|
|
|
/* ON DOIT AVOIR: */
|
|
/* ABS (DEBFIN(I)) < 100 */
|
|
/* et */
|
|
/* (ABS(DEBFIN(1)+ABS(DEBFIN(2))) > 1/100 */
|
|
/* (pour les overflows) */
|
|
|
|
/* ABS(DEBFIN(2)-DEBFIN(1)) / (ABS(DEBFIN(1)+ABS(DEBFIN(2))) > 1/100
|
|
*/
|
|
/* (pour le conditionnement ) */
|
|
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* --------------------- */
|
|
|
|
/* IERCOD : Code d'erreur : 0 : O.K. */
|
|
/* 1 : LES valeur de DEBFIN */
|
|
/* ne sont pas raisonnables */
|
|
/* -1 : L'init etait deja faite */
|
|
/* (OK mais pas de traitement) */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ------------------ */
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* ---------------------- */
|
|
/* Type Name */
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
|
|
/* Ce programme initialise les coefficients des polynomes */
|
|
/* d'Hermite qui sont ensuite lus par MMHERM1 */
|
|
|
|
/* HISTORIQUE */
|
|
/* --------------------------------------------------------- */
|
|
/* 06-01-92: ALR; mise a 0 des termes de MAT non recalcules */
|
|
/* 23-12-91: ALR; 2 CORRECTIONS */
|
|
/* 12-11-91: ALR; ECRITURE VERSION ORIGINALE. */
|
|
/* > */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
|
|
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* Sert a STOCKER les coefficients des polynomes de */
|
|
/* l'interpolation d'Hermite */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* HERMITE */
|
|
|
|
/* DEMSCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
|
|
/* les coefficients des polynomes d'hermitesont calcules par */
|
|
/* la routine MMHERM0 et lus par la routine MMHERM1 */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* ------------------------------ */
|
|
/* 23-11-91: ALR; MODIF DIMENSIONNEMENT */
|
|
/* 12-11-91: ALR; CREATION */
|
|
/* > */
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
|
|
|
|
|
|
|
|
/* NBCOEF est la taille de CMHERM (voir plus bas) */
|
|
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* Verification des donnees */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
|
|
/* Parameter adjustments */
|
|
--debfin;
|
|
|
|
/* Function Body */
|
|
d1 = abs(debfin[1]);
|
|
if (d1 > (float)100.) {
|
|
goto L9101;
|
|
}
|
|
|
|
d2 = abs(debfin[2]);
|
|
if (d2 > (float)100.) {
|
|
goto L9101;
|
|
}
|
|
|
|
d2 = d1 + d2;
|
|
if (d2 < (float).01) {
|
|
goto L9101;
|
|
}
|
|
|
|
d1 = (d__1 = debfin[2] - debfin[1], abs(d__1));
|
|
if (d1 / d2 < (float).01) {
|
|
goto L9101;
|
|
}
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* Initialisations */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
*iercod = 0;
|
|
|
|
epspi = 1e-10;
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* EST-CE DEJA INITIALISE ? */
|
|
|
|
d1 = abs(debfin[1]) + abs(debfin[2]);
|
|
d1 *= 16111959;
|
|
|
|
if (debfin[1] != mmcmher_.tdebut) {
|
|
goto L100;
|
|
}
|
|
if (debfin[2] != mmcmher_.tfinal) {
|
|
goto L100;
|
|
}
|
|
if (d1 != mmcmher_.verifi) {
|
|
goto L100;
|
|
}
|
|
|
|
|
|
goto L9001;
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* CALCUL */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
|
|
L100:
|
|
|
|
/* Init. matrice identite: */
|
|
|
|
ncmat = 36;
|
|
AdvApp2Var_SysBase::mvriraz_((integer *)&ncmat,
|
|
(char *)miden);
|
|
|
|
for (ii = 1; ii <= 6; ++ii) {
|
|
miden[ii + ii * 6 - 7] = 1.;
|
|
/* L110: */
|
|
}
|
|
|
|
|
|
|
|
/* Init a 0 du tableau CMHERM */
|
|
|
|
AdvApp2Var_SysBase::mvriraz_((integer *)&c__576, (char *)mmcmher_.cmherm);
|
|
|
|
/* Calcul par resolution de systemes lineaires */
|
|
|
|
for (iord1 = -1; iord1 <= 2; ++iord1) {
|
|
for (iord2 = -1; iord2 <= 2; ++iord2) {
|
|
|
|
iord[0] = iord1;
|
|
iord[1] = iord2;
|
|
|
|
|
|
iof[0] = 0;
|
|
iof[1] = iord[0] + 1;
|
|
|
|
|
|
ncf = iord[0] + iord[1] + 2;
|
|
|
|
/* Calcul matrice MAT a inverser: */
|
|
|
|
for (cot = 1; cot <= 2; ++cot) {
|
|
|
|
|
|
if (iord[cot - 1] > -1) {
|
|
prod = 1.;
|
|
i__1 = ncf;
|
|
for (jj = 1; jj <= i__1; ++jj) {
|
|
cof[jj - 1] = 1.;
|
|
/* L200: */
|
|
}
|
|
}
|
|
|
|
i__1 = iord[cot - 1] + 1;
|
|
for (pp = 1; pp <= i__1; ++pp) {
|
|
|
|
ii = pp + iof[cot - 1];
|
|
|
|
prod = 1.;
|
|
|
|
i__2 = pp - 1;
|
|
for (jj = 1; jj <= i__2; ++jj) {
|
|
mat[ii + jj * 6 - 7] = (float)0.;
|
|
/* L300: */
|
|
}
|
|
|
|
i__2 = ncf;
|
|
for (jj = pp; jj <= i__2; ++jj) {
|
|
|
|
/* tout se passe dans ces 3 lignes peu lisibles
|
|
*/
|
|
|
|
mat[ii + jj * 6 - 7] = cof[jj - 1] * prod;
|
|
cof[jj - 1] *= jj - pp;
|
|
prod *= debfin[cot];
|
|
|
|
/* L400: */
|
|
}
|
|
/* L500: */
|
|
}
|
|
|
|
/* L1000: */
|
|
}
|
|
|
|
/* Inversion */
|
|
|
|
if (ncf >= 1) {
|
|
AdvApp2Var_MathBase::mmmrslwd_(&c__6, &ncf, &ncf, mat, miden, &epspi, abid, amat, &
|
|
ier);
|
|
if (ier > 0) {
|
|
goto L9101;
|
|
}
|
|
}
|
|
|
|
for (cot = 1; cot <= 2; ++cot) {
|
|
i__1 = iord[cot - 1] + 1;
|
|
for (pp = 1; pp <= i__1; ++pp) {
|
|
i__2 = ncf;
|
|
for (ii = 1; ii <= i__2; ++ii) {
|
|
mmcmher_.cmherm[ii + (pp + (cot + ((iord1 + (iord2 <<
|
|
2)) << 1)) * 3) * 6 + 155] = amat[ii + (pp +
|
|
iof[cot - 1]) * 6 - 7];
|
|
/* L1300: */
|
|
}
|
|
/* L1400: */
|
|
}
|
|
/* L1500: */
|
|
}
|
|
|
|
/* L2000: */
|
|
}
|
|
/* L2010: */
|
|
}
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* On positionne le flag initialise: */
|
|
|
|
mmcmher_.tdebut = debfin[1];
|
|
mmcmher_.tfinal = debfin[2];
|
|
|
|
d1 = abs(debfin[1]) + abs(debfin[2]);
|
|
mmcmher_.verifi = d1 * 16111959;
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
goto L9999;
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
L9101:
|
|
*iercod = 1;
|
|
goto L9999;
|
|
|
|
L9001:
|
|
*iercod = -1;
|
|
goto L9999;
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
L9999:
|
|
|
|
AdvApp2Var_SysBase::maermsg_("MMHERM0", iercod, 7L);
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
return 0 ;
|
|
} /* mmherm0_ */
|
|
|
|
//=======================================================================
|
|
//function : mmherm1_
|
|
//purpose :
|
|
//=======================================================================
|
|
int mmherm1_(doublereal *debfin,
|
|
integer *ordrmx,
|
|
integer *iordre,
|
|
doublereal *hermit,
|
|
integer *iercod)
|
|
{
|
|
/* System generated locals */
|
|
integer hermit_dim1, hermit_dim2, hermit_offset;
|
|
|
|
/* Local variables */
|
|
static integer nbval;
|
|
static doublereal d1;
|
|
static integer cot;
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* lecture des coeffs. des polynomes d'interpol. d'HERMITE */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* MATH_ACCES :: HERMITE */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* -------------------- */
|
|
/* DEBFIN : PARAMETRES OU SONT DONNEES LES CONTRAINTES */
|
|
/* DEBFIN(1) : PREMIER PARAMETRE */
|
|
/* DEBFIN(2) : DEUXIEME PARAMETRE */
|
|
|
|
/* Doivent etre egaux aux argeuments correspondant lors */
|
|
/* du dernier appel a MMHERM0 pour l'init. des coeffs. */
|
|
|
|
/* ORDRMX : sert a indiquer le dimensionnent de HERMIT: */
|
|
/* on n'a pas le choix : ORDRMX doit etre egal a la valeur */
|
|
/* du PARAMETER IORDMX de l'INCLUDE MMCMHER, soit 2 pour */
|
|
/* l'instant. */
|
|
|
|
/* IORDRE (2) : Ordres de contraintes en chaque parametre DEBFIN(I)
|
|
*/
|
|
/* corrspondant. doivent etre compris entre -1 (pas de */
|
|
/* contrainte) et ORDRMX. */
|
|
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* --------------------- */
|
|
|
|
/* HERMIT : HERMIT(1:IORDRE(1)+IORDRE(2)+2, j, cote) sont les */
|
|
/* coefficients dans la base canonique du polynome d'Hermite */
|
|
/* correspondant aux ordres IORDRE aux paramtres DEBFIN pour */
|
|
/* la contrainte d'ordre j en DEBFIN(cote). j est compris entre */
|
|
/* 0 et IORDRE(cote). */
|
|
|
|
|
|
/* IERCOD : Code d'erreur : */
|
|
/* -1: O.K mais on a du reinitialise les coefficients */
|
|
/* (info pour optimisation) */
|
|
/* 0 : O.K. */
|
|
/* 1 : Erreur dans MMHERM0 */
|
|
/* 2 : arguments invalides */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ------------------ */
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* ---------------------- */
|
|
/* Type Name */
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
|
|
/* Ce programme lit les coefficients des polynomes */
|
|
/* d'Hermite qui ont ete au prealable initialise par MMHERM0 */
|
|
|
|
/* PMN : L'initialisation n'est plus a la charge de l'appelant. */
|
|
|
|
/* HISTORIQUE */
|
|
/* --------------------------------------------------------- */
|
|
/* 14-01-94: PMN; On appelle MMHERM0 si pas initialise. */
|
|
/* 12-11-91: ALR; ECRITURE VERSION ORIGINALE. */
|
|
/* > */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
|
|
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* Sert a STOCKER les coefficients des polynomes de */
|
|
/* l'interpolation d'Hermite */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* HERMITE */
|
|
|
|
/* DEMSCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
|
|
/* les coefficients des polynomes d'hermitesont calcules par */
|
|
/* la routine MMHERM0 et lus par la routine MMHERM1 */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* ------------------------------ */
|
|
/* 23-11-91: ALR; MODIF DIMENSIONNEMENT */
|
|
/* 12-11-91: ALR; CREATION */
|
|
/* > */
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
|
|
|
|
|
|
|
|
/* NBCOEF est la taille de CMHERM (voir plus bas) */
|
|
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
|
|
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* Initialisations */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* Parameter adjustments */
|
|
--debfin;
|
|
hermit_dim1 = (*ordrmx << 1) + 2;
|
|
hermit_dim2 = *ordrmx + 1;
|
|
hermit_offset = hermit_dim1 * hermit_dim2 + 1;
|
|
hermit -= hermit_offset;
|
|
--iordre;
|
|
|
|
/* Function Body */
|
|
*iercod = 0;
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* Verification des donnees */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
|
|
if (*ordrmx != 2) {
|
|
goto L9102;
|
|
}
|
|
|
|
for (cot = 1; cot <= 2; ++cot) {
|
|
if (iordre[cot] < -1) {
|
|
goto L9102;
|
|
}
|
|
if (iordre[cot] > *ordrmx) {
|
|
goto L9102;
|
|
}
|
|
/* L100: */
|
|
}
|
|
|
|
|
|
/* EST-CE BIEN INITIALISE ? */
|
|
|
|
d1 = abs(debfin[1]) + abs(debfin[2]);
|
|
d1 *= 16111959;
|
|
|
|
/* SINON ON INITIALISE */
|
|
|
|
if (debfin[1] != mmcmher_.tdebut || debfin[2] != mmcmher_.tfinal || d1
|
|
!= mmcmher_.verifi) {
|
|
*iercod = -1;
|
|
mmherm0_(&debfin[1], iercod);
|
|
if (*iercod > 0) {
|
|
goto L9101;
|
|
}
|
|
}
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* LECTURE */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
nbval = 36;
|
|
|
|
AdvApp2Var_SysBase::msrfill_(&nbval, &mmcmher_.cmherm[((((iordre[1] + (iordre[2] << 2)) << 1)
|
|
+ 1) * 3 + 1) * 6 + 156], &hermit[hermit_offset]);
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
goto L9999;
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
L9101:
|
|
*iercod = 1;
|
|
goto L9999;
|
|
|
|
L9102:
|
|
*iercod = 2;
|
|
goto L9999;
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
L9999:
|
|
|
|
AdvApp2Var_SysBase::maermsg_("MMHERM1", iercod, 7L);
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
return 0 ;
|
|
} /* mmherm1_ */
|
|
|
|
//=======================================================================
|
|
//function : AdvApp2Var_MathBase::mmhjcan_
|
|
//purpose :
|
|
//=======================================================================
|
|
int AdvApp2Var_MathBase::mmhjcan_(integer *ndimen,
|
|
integer *ncourb,
|
|
integer *ncftab,
|
|
integer *orcont,
|
|
integer *ncflim,
|
|
doublereal *tcbold,
|
|
doublereal *tdecop,
|
|
doublereal *tcbnew,
|
|
integer *iercod)
|
|
|
|
{
|
|
static integer c__2 = 2;
|
|
static integer c__21 = 21;
|
|
/* System generated locals */
|
|
integer tcbold_dim1, tcbold_dim2, tcbold_offset, tcbnew_dim1, tcbnew_dim2,
|
|
tcbnew_offset, i__1, i__2, i__3, i__4, i__5;
|
|
|
|
|
|
/* Local variables */
|
|
static logical ldbg;
|
|
static integer ndeg;
|
|
static doublereal taux1[21];
|
|
static integer d__, e, i__, k;
|
|
static doublereal mfact;
|
|
static integer ncoeff;
|
|
static doublereal tjacap[21];
|
|
static integer iordre[2];
|
|
static doublereal hermit[36]/* was [6][3][2] */, ctenor, bornes[2];
|
|
static integer ier;
|
|
static integer aux1, aux2;
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* CONVERSION LA TABLE TCBOLD DES COEFFICIENTS DES COURBES */
|
|
/* POLYNOMIALES EXPRIMEES DANS LA BASE HERMITE JACOBI, EN UNE */
|
|
/* TABLE DE COEFFICIENTS TCBNEW DES COURBES EXPRIMEES DANS LA */
|
|
/* BASE CANONIQUE */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* CANNONIQUE, HERMITE, JACCOBI */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* -------------------- */
|
|
/* ORDHER : ORDRE DES POLYNOMES D'HERMITE OU ORDRE DE CONTINUITE */
|
|
/* NCOEFS : NOMBRE DE COEFFICIENTS DE UNE LA COURBE POLYNOMIALE */
|
|
/* POUR UNE DE SES NDIM COMPOSANTS;(DEGRE+1 DE LA COURBE)
|
|
*/
|
|
/* NDIM : DIMENSION DE LA COURBE */
|
|
/* CBHEJA : TABLE DE COEFFICIENTS DE LA COURBE DANS LA BASE */
|
|
/* HERMITE JACOBI */
|
|
/* (H(0,-1),..,H(ORDHER,-1),H(0,1),..,H(ORDHER,1), */
|
|
/* JA(ORDHER+1,2*ORDHER+2),....,JA(ORDHER+1,NCOEFS-1) */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* --------------------- */
|
|
/* CBRCAN : TABLE DE COEFFICIENTS DE LA COURBE DANS LA BASE */
|
|
/* CANONIQUE */
|
|
/* (1, t, ...) */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ------------------ */
|
|
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* --------------------- */
|
|
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* ------------------------------ */
|
|
/* 8-09-95 : KHN/PMN; ECRITURE VERSION ORIGINALE. */
|
|
/* > */
|
|
/* ***********************************************************************
|
|
*/
|
|
/* DECLARATIONS */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* Sert a fournir les constantes entieres de 0 a 1000 */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* TOUS,ENTIERS */
|
|
|
|
/* DEMSCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* ------------------------------ */
|
|
/* 11-10-89 : DH ; Creation version originale */
|
|
/* > */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* INITIALISATIONS */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* Parameter adjustments */
|
|
--ncftab;
|
|
tcbnew_dim1 = *ndimen;
|
|
tcbnew_dim2 = *ncflim;
|
|
tcbnew_offset = tcbnew_dim1 * (tcbnew_dim2 + 1) + 1;
|
|
tcbnew -= tcbnew_offset;
|
|
tcbold_dim1 = *ndimen;
|
|
tcbold_dim2 = *ncflim;
|
|
tcbold_offset = tcbold_dim1 * (tcbold_dim2 + 1) + 1;
|
|
tcbold -= tcbold_offset;
|
|
|
|
/* Function Body */
|
|
ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 2;
|
|
if (ldbg) {
|
|
AdvApp2Var_SysBase::mgenmsg_("MMHJCAN", 7L);
|
|
}
|
|
*iercod = 0;
|
|
|
|
bornes[0] = -1.;
|
|
bornes[1] = 1.;
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* TRAITEMENT */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
if (*orcont > 2) {
|
|
goto L9101;
|
|
}
|
|
if (*ncflim > 21) {
|
|
goto L9101;
|
|
}
|
|
|
|
/* CALCUL DES POLYNOMES D'HERMITE DANS LA BASE CANONIQUE SUR (-1,1) */
|
|
|
|
|
|
iordre[0] = *orcont;
|
|
iordre[1] = *orcont;
|
|
mmherm1_(bornes, &c__2, iordre, hermit, &ier);
|
|
if (ier > 0) {
|
|
goto L9102;
|
|
}
|
|
|
|
|
|
aux1 = *orcont + 1;
|
|
aux2 = aux1 << 1;
|
|
|
|
i__1 = *ncourb;
|
|
for (e = 1; e <= i__1; ++e) {
|
|
|
|
ctenor = (tdecop[e] - tdecop[e - 1]) / 2;
|
|
ncoeff = ncftab[e];
|
|
ndeg = ncoeff - 1;
|
|
if (ncoeff > 21) {
|
|
goto L9101;
|
|
}
|
|
|
|
i__2 = *ndimen;
|
|
for (d__ = 1; d__ <= i__2; ++d__) {
|
|
|
|
/* CONVERSION DES COEFFICIENTS DE LA PARTIE DE LA COURBE EXPRI
|
|
MEE */
|
|
/* DANS LA BASE HERMITE, DANS LA BASE CANONIQUE */
|
|
|
|
AdvApp2Var_SysBase::mvriraz_((integer *)&ncoeff, (char *)taux1);
|
|
|
|
i__3 = aux2;
|
|
for (k = 1; k <= i__3; ++k) {
|
|
i__4 = aux1;
|
|
for (i__ = 1; i__ <= i__4; ++i__) {
|
|
i__5 = i__ - 1;
|
|
mfact = AdvApp2Var_MathBase::pow__di(&ctenor, &i__5);
|
|
taux1[k - 1] += (tcbold[d__ + (i__ + e * tcbold_dim2) *
|
|
tcbold_dim1] * hermit[k + (i__ + 2) * 6 - 19] +
|
|
tcbold[d__ + (i__ + aux1 + e * tcbold_dim2) *
|
|
tcbold_dim1] * hermit[k + (i__ + 5) * 6 - 19]) *
|
|
mfact;
|
|
}
|
|
}
|
|
|
|
|
|
i__3 = ncoeff;
|
|
for (i__ = aux2 + 1; i__ <= i__3; ++i__) {
|
|
taux1[i__ - 1] = tcbold[d__ + (i__ + e * tcbold_dim2) *
|
|
tcbold_dim1];
|
|
}
|
|
|
|
/* CONVERSION DES COEFFICIENTS DE LA PARTIE DE LA COURBE EXPRI
|
|
MEE */
|
|
/* DANS LA BASE CANONIQUE-JACOBI , DANS LA BASE CANONIQUE */
|
|
|
|
|
|
AdvApp2Var_MathBase::mmapcmp_(&minombr_.nbr[1], &c__21, &ncoeff, taux1, tjacap);
|
|
AdvApp2Var_MathBase::mmjacan_(orcont, &ndeg, tjacap, taux1);
|
|
|
|
/* RECOPIE DES COEFS RESULTANT DE LA CONVERSION DANS LA TA
|
|
BLE */
|
|
/* DES RESULTAT */
|
|
|
|
i__3 = ncoeff;
|
|
for (i__ = 1; i__ <= i__3; ++i__) {
|
|
tcbnew[d__ + (i__ + e * tcbnew_dim2) * tcbnew_dim1] = taux1[
|
|
i__ - 1];
|
|
}
|
|
|
|
}
|
|
}
|
|
|
|
goto L9999;
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* TRAITEMENT DES ERREURS */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
L9101:
|
|
*iercod = 1;
|
|
goto L9999;
|
|
L9102:
|
|
*iercod = 2;
|
|
goto L9999;
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* RETOUR PROGRAMME APPELANT */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
L9999:
|
|
|
|
AdvApp2Var_SysBase::maermsg_("MMHJCAN", iercod, 7L);
|
|
if (ldbg) {
|
|
AdvApp2Var_SysBase::mgsomsg_("MMHJCAN", 7L);
|
|
}
|
|
return 0 ;
|
|
} /* mmhjcan_ */
|
|
|
|
//=======================================================================
|
|
//function : AdvApp2Var_MathBase::mminltt_
|
|
//purpose :
|
|
//=======================================================================
|
|
int AdvApp2Var_MathBase::mminltt_(integer *ncolmx,
|
|
integer *nlgnmx,
|
|
doublereal *tabtri,
|
|
integer *nbrcol,
|
|
integer *nbrlgn,
|
|
doublereal *ajoute,
|
|
doublereal *,//epseg,
|
|
integer *iercod)
|
|
{
|
|
/* System generated locals */
|
|
integer tabtri_dim1, tabtri_offset, i__1, i__2;
|
|
|
|
/* Local variables */
|
|
static logical idbg;
|
|
static integer icol, ilgn, nlgn, noct, inser;
|
|
static doublereal epsega;
|
|
static integer ibb;
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* . Insertion d'une ligne dans une table triee sans redondance */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* TOUS,MATH_ACCES :: TABLEAU&,INSERTION,&TABLEAU */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* -------------------- */
|
|
/* . NCOLMX : Nombre de colonnes du tableau */
|
|
/* . NLGNMX : Nombre de lignes du tableau */
|
|
/* . TABTRI : Tableau trie par lignes sans redondances */
|
|
/* . NBRCOL : Nombre de colonnes utilisees */
|
|
/* . NBRLGN : Nombre de lignes utilisees */
|
|
/* . AJOUTE : Ligne a ajouter */
|
|
/* . EPSEGA : Epsilon pour le test de redondance */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* --------------------- */
|
|
/* . TABTRI : Tableau trie par lignes sans redondances */
|
|
/* . NBRLGN : Nombre de lignes utilisees */
|
|
/* . IERCOD : 0 -> Pas de probleme */
|
|
/* 1 -> La table est pleine */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ------------------ */
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* --------------------- */
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
/* . On n'insere la ligne que si il n'y a pas de ligne tq tous ses
|
|
*/
|
|
/* elements soient egaux a ceux qu'on veut inserer a epsilon pres. */
|
|
|
|
/* . Niveau de debug = 3 */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* ------------------------------ */
|
|
/* . 24-06-91 : RBD; Suppression des accents (Pb. Bull). */
|
|
/* . 01-10-89 : VV ; Version originale */
|
|
/* > */
|
|
/* ***********************************************************************
|
|
*/
|
|
/* DECLARATIONS , CONTROLE DES ARGUMENTS D'ENTREE , INITIALISATION */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* --- Parametres */
|
|
|
|
|
|
/* --- Fonctions */
|
|
|
|
|
|
/* --- Variables locales */
|
|
|
|
|
|
/* --- Messagerie */
|
|
|
|
/* Parameter adjustments */
|
|
tabtri_dim1 = *ncolmx;
|
|
tabtri_offset = tabtri_dim1 + 1;
|
|
tabtri -= tabtri_offset;
|
|
--ajoute;
|
|
|
|
/* Function Body */
|
|
ibb = AdvApp2Var_SysBase::mnfndeb_();
|
|
idbg = ibb >= 3;
|
|
if (idbg) {
|
|
AdvApp2Var_SysBase::mgenmsg_("MMINLTT", 7L);
|
|
}
|
|
|
|
/* --- Controle arguments */
|
|
|
|
if (*nbrlgn >= *nlgnmx) {
|
|
goto L9001;
|
|
}
|
|
|
|
/* -------------------- */
|
|
/* *** INITIALISATIONS */
|
|
/* -------------------- */
|
|
|
|
*iercod = 0;
|
|
|
|
/* ---------------------------- */
|
|
/* *** RECHERCHE DE REDONDANCE */
|
|
/* ---------------------------- */
|
|
|
|
i__1 = *nbrlgn;
|
|
for (ilgn = 1; ilgn <= i__1; ++ilgn) {
|
|
if (tabtri[ilgn * tabtri_dim1 + 1] >= ajoute[1] - epsega) {
|
|
if (tabtri[ilgn * tabtri_dim1 + 1] <= ajoute[1] + epsega) {
|
|
i__2 = *nbrcol;
|
|
for (icol = 1; icol <= i__2; ++icol) {
|
|
if (tabtri[icol + ilgn * tabtri_dim1] < ajoute[icol] -
|
|
epsega || tabtri[icol + ilgn * tabtri_dim1] >
|
|
ajoute[icol] + epsega) {
|
|
goto L20;
|
|
}
|
|
/* L10: */
|
|
}
|
|
goto L9999;
|
|
} else {
|
|
goto L30;
|
|
}
|
|
}
|
|
L20:
|
|
;
|
|
}
|
|
|
|
/* ----------------------------------- */
|
|
/* *** RECHERCHE DU POINT D'INSERTION */
|
|
/* ----------------------------------- */
|
|
|
|
L30:
|
|
|
|
i__1 = *nbrlgn;
|
|
for (ilgn = 1; ilgn <= i__1; ++ilgn) {
|
|
i__2 = *nbrcol;
|
|
for (icol = 1; icol <= i__2; ++icol) {
|
|
if (tabtri[icol + ilgn * tabtri_dim1] < ajoute[icol]) {
|
|
goto L50;
|
|
}
|
|
if (tabtri[icol + ilgn * tabtri_dim1] > ajoute[icol]) {
|
|
goto L70;
|
|
}
|
|
/* L60: */
|
|
}
|
|
L50:
|
|
;
|
|
}
|
|
|
|
ilgn = *nbrlgn + 1;
|
|
|
|
/* -------------- */
|
|
/* *** INSERTION */
|
|
/* -------------- */
|
|
|
|
L70:
|
|
|
|
inser = ilgn;
|
|
++(*nbrlgn);
|
|
|
|
/* --- Decalage vers le bas */
|
|
|
|
nlgn = *nbrlgn - inser;
|
|
if (nlgn > 0) {
|
|
noct = (*ncolmx << 3) * nlgn;
|
|
AdvApp2Var_SysBase::mcrfill_((integer *)&noct,
|
|
(char *)&tabtri[inser * tabtri_dim1 + 1],
|
|
(char *)&tabtri[(inser + 1)* tabtri_dim1 + 1]);
|
|
}
|
|
|
|
/* --- Copie de la ligne */
|
|
|
|
noct = *nbrcol << 3;
|
|
AdvApp2Var_SysBase::mcrfill_((integer *)&noct,
|
|
(char *)&ajoute[1],
|
|
(char *)&tabtri[inser * tabtri_dim1 + 1]);
|
|
|
|
goto L9999;
|
|
|
|
/* ******************************************************************** */
|
|
/* SORTIE ERREUR , RETOUR PROGRAMME APPELANT , MESSAGERIE */
|
|
/* ******************************************************************** */
|
|
|
|
/* --- La table est deja pleine */
|
|
|
|
L9001:
|
|
*iercod = 1;
|
|
|
|
/* --- Fin */
|
|
|
|
L9999:
|
|
if (*iercod != 0) {
|
|
AdvApp2Var_SysBase::maermsg_("MMINLTT", iercod, 7L);
|
|
}
|
|
if (idbg) {
|
|
AdvApp2Var_SysBase::mgsomsg_("MMINLTT", 7L);
|
|
}
|
|
return 0 ;
|
|
} /* mminltt_ */
|
|
|
|
//=======================================================================
|
|
//function : AdvApp2Var_MathBase::mmjacan_
|
|
//purpose :
|
|
//=======================================================================
|
|
int AdvApp2Var_MathBase::mmjacan_(integer *ideriv,
|
|
integer *ndeg,
|
|
doublereal *poljac,
|
|
doublereal *polcan)
|
|
{
|
|
/* System generated locals */
|
|
integer poljac_dim1, i__1, i__2;
|
|
|
|
/* Local variables */
|
|
static integer iptt, i__, j, ibb;
|
|
static doublereal bid;
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* Routine de transfert de Jacobi normalise a canonique [-1,1], les */
|
|
/* tableaux etant ranges en termes de degre pair puis impair. */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* LEGENDRE,JACOBI,PASSAGE. */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* ------------------ */
|
|
/* IDERIV : Ordre de Jacobi compris entre -1 et 2. */
|
|
/* NDEG : Le degre vrai du polynome. */
|
|
/* POLJAC : Le polynome dans la base de Jacobi. */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* ------------------- */
|
|
/* POLCAN : La courbe exprimee dans la base canonique [-1,1]. */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ---------------- */
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* ----------------------- */
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* -------------------------------- */
|
|
/* 04-01-90 : NAK ; COMMON MMJCOBI PAR INCLUDE MMJCOBI */
|
|
/* 12-04-1989 : RBD ; Appel MGSOMSG. */
|
|
/* 27-04-1988 : JJM ; Test NDEG=0 */
|
|
/* 01-03-1988 : JJM ; Creation. */
|
|
|
|
/* > */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* Le nom de la routine */
|
|
|
|
/* Matrices de conversion */
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* MATRICE DE TRANSFORMATION DS LA BASE DE LEGENDRE */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* MATH */
|
|
|
|
/* DEMSCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* ------------------------------ */
|
|
/* 04-01-90 : NAK ; Creation version originale */
|
|
/* > */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
|
|
|
|
/* Common de Legendre/Casteljau comprime. */
|
|
|
|
/* 0:1 0 Concerne les termes pairs, 1 les termes impairs. */
|
|
/* CANPLG : Matrice de passage de canonique vers Jacobi avec parites */
|
|
/* comptees */
|
|
/* PLGCAN : Matrice de passage de Jacobi vers canonique avec parites */
|
|
/* comptees. */
|
|
|
|
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* Parameter adjustments */
|
|
poljac_dim1 = *ndeg / 2 + 1;
|
|
|
|
/* Function Body */
|
|
ibb = AdvApp2Var_SysBase::mnfndeb_();
|
|
if (ibb >= 5) {
|
|
AdvApp2Var_SysBase::mgenmsg_("MMJACAN", 7L);
|
|
}
|
|
|
|
/* ----------------- Expression des termes de degre pair ----------------
|
|
*/
|
|
|
|
i__1 = *ndeg / 2;
|
|
for (i__ = 0; i__ <= i__1; ++i__) {
|
|
bid = 0.;
|
|
iptt = i__ * 31 - (i__ + 1) * i__ / 2 + 1;
|
|
i__2 = *ndeg / 2;
|
|
for (j = i__; j <= i__2; ++j) {
|
|
bid += mmjcobi_.plgcan[iptt + j + *ideriv * 992 + 991] * poljac[
|
|
j];
|
|
/* L310: */
|
|
}
|
|
polcan[i__ * 2] = bid;
|
|
/* L300: */
|
|
}
|
|
|
|
/* --------------- Expression des termes de degre impair ----------------
|
|
*/
|
|
|
|
if (*ndeg == 0) {
|
|
goto L9999;
|
|
}
|
|
|
|
i__1 = (*ndeg - 1) / 2;
|
|
for (i__ = 0; i__ <= i__1; ++i__) {
|
|
bid = 0.;
|
|
iptt = i__ * 31 - (i__ + 1) * i__ / 2 + 1;
|
|
i__2 = (*ndeg - 1) / 2;
|
|
for (j = i__; j <= i__2; ++j) {
|
|
bid += mmjcobi_.plgcan[iptt + j + ((*ideriv << 1) + 1) * 496 +
|
|
991] * poljac[j + poljac_dim1];
|
|
/* L410: */
|
|
}
|
|
polcan[(i__ << 1) + 1] = bid;
|
|
/* L400: */
|
|
}
|
|
|
|
/* -------------------------------- The end -----------------------------
|
|
*/
|
|
|
|
L9999:
|
|
if (ibb >= 5) {
|
|
AdvApp2Var_SysBase::mgsomsg_("MMJACAN", 7L);
|
|
}
|
|
return 0;
|
|
} /* mmjacan_ */
|
|
|
|
//=======================================================================
|
|
//function : AdvApp2Var_MathBase::mmjaccv_
|
|
//purpose :
|
|
//=======================================================================
|
|
int AdvApp2Var_MathBase::mmjaccv_(integer *ncoef,
|
|
integer *ndim,
|
|
integer *ider,
|
|
doublereal *crvlgd,
|
|
doublereal *polaux,
|
|
doublereal *crvcan)
|
|
|
|
{
|
|
/* Initialized data */
|
|
|
|
static char nomprg[8+1] = "MMJACCV ";
|
|
|
|
/* System generated locals */
|
|
integer crvlgd_dim1, crvlgd_offset, crvcan_dim1, crvcan_offset,
|
|
polaux_dim1, i__1, i__2;
|
|
|
|
/* Local variables */
|
|
static integer ndeg, i__, nd, ii, ibb;
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* Passage de la base de Jacobi normalisee a la base canonique. */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* LISSAGE,BASE,LEGENDRE */
|
|
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* ------------------ */
|
|
/* NDIM: Dimension de l' espace. */
|
|
/* NCOEF: Degre +1 du polynome. */
|
|
/* IDER: Ordre des polynomes de Jacobi. */
|
|
/* CRVLGD : La courbe dans la base de Jacobi. */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* ------------------- */
|
|
/* POLAUX : Espace auxilliaire. */
|
|
/* CRVCAN : La courbe dans la base canonique [-1,1] */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ---------------- */
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* ----------------------- */
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* -------------------------------- */
|
|
/* 26-04-1988 : RBD ; Cas de la courbe reduite a 1 point. */
|
|
/* 01-03-1988 : JJM ; Creation. */
|
|
|
|
/* > */
|
|
/* *********************************************************************
|
|
*/
|
|
|
|
/* Le nom de la routine */
|
|
/* Parameter adjustments */
|
|
polaux_dim1 = (*ncoef - 1) / 2 + 1;
|
|
crvcan_dim1 = *ncoef - 1 + 1;
|
|
crvcan_offset = crvcan_dim1;
|
|
crvcan -= crvcan_offset;
|
|
crvlgd_dim1 = *ncoef - 1 + 1;
|
|
crvlgd_offset = crvlgd_dim1;
|
|
crvlgd -= crvlgd_offset;
|
|
|
|
/* Function Body */
|
|
|
|
ibb = AdvApp2Var_SysBase::mnfndeb_();
|
|
if (ibb >= 3) {
|
|
AdvApp2Var_SysBase::mgenmsg_(nomprg, 6L);
|
|
}
|
|
|
|
ndeg = *ncoef - 1;
|
|
|
|
i__1 = *ndim;
|
|
for (nd = 1; nd <= i__1; ++nd) {
|
|
/* Chargement du tableau auxilliaire. */
|
|
ii = 0;
|
|
i__2 = ndeg / 2;
|
|
for (i__ = 0; i__ <= i__2; ++i__) {
|
|
polaux[i__] = crvlgd[ii + nd * crvlgd_dim1];
|
|
ii += 2;
|
|
/* L310: */
|
|
}
|
|
|
|
ii = 1;
|
|
if (ndeg >= 1) {
|
|
i__2 = (ndeg - 1) / 2;
|
|
for (i__ = 0; i__ <= i__2; ++i__) {
|
|
polaux[i__ + polaux_dim1] = crvlgd[ii + nd * crvlgd_dim1];
|
|
ii += 2;
|
|
/* L320: */
|
|
}
|
|
}
|
|
/* Appel a la routine de changement de base. */
|
|
AdvApp2Var_MathBase::mmjacan_(ider, &ndeg, polaux, &crvcan[nd * crvcan_dim1]);
|
|
/* L300: */
|
|
}
|
|
|
|
|
|
/* L9999: */
|
|
return 0;
|
|
} /* mmjaccv_ */
|
|
|
|
//=======================================================================
|
|
//function : mmloncv_
|
|
//purpose :
|
|
//=======================================================================
|
|
int mmloncv_(integer *ndimax,
|
|
integer *ndimen,
|
|
integer *ncoeff,
|
|
doublereal *courbe,
|
|
doublereal *tdebut,
|
|
doublereal *tfinal,
|
|
doublereal *xlongc,
|
|
integer *iercod)
|
|
|
|
{
|
|
/* Initialized data */
|
|
|
|
static integer kgar = 0;
|
|
|
|
/* System generated locals */
|
|
integer courbe_dim1, courbe_offset, i__1, i__2;
|
|
|
|
/* Local variables */
|
|
static doublereal tran;
|
|
static integer ngaus;
|
|
static doublereal c1, c2, d1, d2, wgaus[20], uroot[20], x1, x2, dd;
|
|
static integer ii, jj, kk;
|
|
static doublereal som;
|
|
static doublereal der1, der2;
|
|
|
|
|
|
|
|
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : Longueur d'un arc de courbe sur un intervalle donne */
|
|
/* ---------- pour une fonction dont la representation mathematique */
|
|
/* est faite un polynome multidimensionnel. */
|
|
/* Le polynome est en fait un ensemble de polynomes dont les coeffi-
|
|
*/
|
|
/* cients sont ranges dans un tableau a 2 indices, chaque ligne */
|
|
/* etant relative a 1 polynome. */
|
|
/* Le polynome est defini par ses coefficients ordonne par les puis-
|
|
*/
|
|
/* sances croissantes de la variable. */
|
|
/* Tous les polynomes ont le meme nombre de coefficients (donc le */
|
|
/* meme degre). */
|
|
|
|
/* MOTS CLES : LONGUEUR, COURBE */
|
|
/* ----------- */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* -------------------- */
|
|
|
|
/* NDIMAX : Nombre de lignes maximum des tableaux */
|
|
/* (nombre maxi de polynomes). */
|
|
/* NDIMEN : Dimension du polynome (Nombre de polynomes). */
|
|
/* NCOEFF : Nombre de coefficients du polynome (pas de limitation) */
|
|
/* C'est le degre + 1 */
|
|
/* COURBE : Coefficients du polynome ordonne par les puissances */
|
|
/* croissantes. A dimensionner a (NDIMAX,NCOEFF). */
|
|
/* TDEBUT : Bornes inferieure de l'integration pour calcul de la */
|
|
/* longueur. */
|
|
/* TFINAL : Bornes superieure de l'integration pour calcul de la */
|
|
/* longueur. */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* --------------------- */
|
|
/* XLONGC : Longueur de l'arc de courbe */
|
|
|
|
/* IERCOD : Code d'erreur : */
|
|
/* = 0 ==> Tout est OK */
|
|
/* = 1 ==> NDIMEN ou NCOEFF negatif ou nul */
|
|
/* = 2 ==> Pb chargement racines Legendre et poids de Gauss */
|
|
/* par MVGAUS0. */
|
|
|
|
/* Si erreur => XLONGC = 0 */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ------------------ */
|
|
|
|
/* .Neant. */
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* ---------------------- */
|
|
/* Type Name */
|
|
/* MAERMSG R*8 DSQRT I*4 MIN */
|
|
/* MVGAUS0 */
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
|
|
/* Voir VGAUSS pour bien comprendre la technique. */
|
|
/* On integre en verite SQRT (dpi^2) pour i=1,nbdime */
|
|
/* Le calcul de la derivee est mele dans le code pour ne pas faire */
|
|
/* un appel supplementaire a une routine. */
|
|
|
|
/* La fonction que l'on integre est strictement croissante, il */
|
|
/* n'est pas necessaire d'utiliser un haut degre pour la methode */
|
|
/* GAUSS */
|
|
|
|
/* Le degre du polynome de LEGENDRE est fonction du degre du */
|
|
/* polynome a integrer. Il peut varier de 4 a 40 (par pas de 4). */
|
|
|
|
/* La precision (relative) de l'integration est de l'ordre */
|
|
/* de 1.D-8. */
|
|
|
|
/* ATTENTION : si TDEBUT > TFINAL, la longueur est alors NEGATIVE. */
|
|
|
|
/* Attention : la precision sur le resultat n'est pas controlee. */
|
|
/* Si vous desirez la controler utiliser plutot MMCGLC1, tout en */
|
|
/* sachant que les performances (en temps) seront quand meme moins */
|
|
/* bonnes. */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* ------------------------------ */
|
|
/* 8-09-1995 : Performance */
|
|
/* 08-04-94 : JMC ; Rem: Appeler MMCGLC1 pour controler la precision
|
|
*/
|
|
/* 26-04-90 : RBD ; Augmentation du nbre de points KK pour calcul */
|
|
/* + precis, appel a MXVINIT et MXVSAVE, recup */
|
|
/* code d'erreur MVGAUS0, ajout commentaires. */
|
|
/* 08-06-89 : GD ; Suppression des 2 parties de l'integration, */
|
|
/* MVGAUS0 est appelle que si le degre a change. */
|
|
/* 10-06-88 : GD ; Variation dynamique du degre LEGENDRE */
|
|
/* 18-08-87 : GD ; Version originale */
|
|
|
|
/* >=====================================================================
|
|
*/
|
|
|
|
/* ATTENTION : SAUVER KGAR WGAUS et UROOT EVENTUELLEMENT */
|
|
/* ,IERXV */
|
|
/* INTEGER I1,I20 */
|
|
/* PARAMETER (I1=1,I20=20) */
|
|
|
|
/* Parameter adjustments */
|
|
courbe_dim1 = *ndimax;
|
|
courbe_offset = courbe_dim1 + 1;
|
|
courbe -= courbe_offset;
|
|
|
|
/* Function Body */
|
|
|
|
/* ****** Initialisation generale ** */
|
|
|
|
*iercod = 999999;
|
|
*xlongc = 0.;
|
|
|
|
/* ****** Initialisation de UROOT, WGAUS, NGAUS et KGAR ** */
|
|
|
|
/* CALL MXVINIT(IERXV,'INTEGER',I1,KGAR,'INTEGER',I1,NGAUS */
|
|
/* 1 ,'DOUBLE PRECISION',I20,UROOT,'DOUBLE PRECISION',I20,WGAUS) */
|
|
/* IF (IERXV.GT.0) KGAR=0 */
|
|
|
|
/* ****** Test d'egalite des bornes ** */
|
|
|
|
if (*tdebut == *tfinal) {
|
|
*iercod = 0;
|
|
goto L9900;
|
|
}
|
|
|
|
/* ****** Test de la dimension et du nombre de coefficients ** */
|
|
|
|
if (*ndimen <= 0 || *ncoeff <= 0) {
|
|
*iercod = 1;
|
|
goto L9900;
|
|
}
|
|
|
|
/* ****** Calcul du degre optimum ** */
|
|
|
|
kk = *ncoeff / 4 + 1;
|
|
kk = min(kk,10);
|
|
|
|
/* ****** Recuperation des coefficients pour l'integrale (DEGRE=4*KK) */
|
|
/* si KK <> KGAR. */
|
|
|
|
if (kk != kgar) {
|
|
mvgaus0_(&kk, uroot, wgaus, &ngaus, iercod);
|
|
if (*iercod > 0) {
|
|
kgar = 0;
|
|
*iercod = 2;
|
|
goto L9900;
|
|
}
|
|
kgar = kk;
|
|
}
|
|
|
|
/* C1 => Point milieu intervalle */
|
|
/* C2 => 1/2 amplitude intervalle */
|
|
|
|
c1 = (*tfinal + *tdebut) * .5;
|
|
c2 = (*tfinal - *tdebut) * .5;
|
|
|
|
/* ----------------------------------------------------------- */
|
|
/* ****** Integration - Boucle sur les intervalles de GAUSS ** */
|
|
/* ----------------------------------------------------------- */
|
|
|
|
som = 0.;
|
|
|
|
i__1 = ngaus;
|
|
for (jj = 1; jj <= i__1; ++jj) {
|
|
|
|
/* ****** Integration en tenant compte de la symetrie ** */
|
|
|
|
tran = c2 * uroot[jj - 1];
|
|
x1 = c1 + tran;
|
|
x2 = c1 - tran;
|
|
|
|
/* ****** Derivation sur la dimension de l'espace ** */
|
|
|
|
der1 = 0.;
|
|
der2 = 0.;
|
|
i__2 = *ndimen;
|
|
for (kk = 1; kk <= i__2; ++kk) {
|
|
d1 = (*ncoeff - 1) * courbe[kk + *ncoeff * courbe_dim1];
|
|
d2 = d1;
|
|
for (ii = *ncoeff - 1; ii >= 2; --ii) {
|
|
dd = (ii - 1) * courbe[kk + ii * courbe_dim1];
|
|
d1 = d1 * x1 + dd;
|
|
d2 = d2 * x2 + dd;
|
|
/* L100: */
|
|
}
|
|
der1 += d1 * d1;
|
|
der2 += d2 * d2;
|
|
/* L200: */
|
|
}
|
|
|
|
/* ****** Integration ** */
|
|
|
|
som += wgaus[jj - 1] * c2 * (sqrt(der1) + sqrt(der2));
|
|
|
|
/* ****** Fin de boucle dur les intervalles de GAUSS ** */
|
|
|
|
/* L300: */
|
|
}
|
|
|
|
/* ****** Travail termine ** */
|
|
|
|
*xlongc = som;
|
|
|
|
/* ****** On force IERCOD = 0 ** */
|
|
|
|
*iercod = 0;
|
|
|
|
/* ****** Traitement de fin ** */
|
|
|
|
L9900:
|
|
|
|
/* ****** Sauvegarde de UROOT, WGAUS, NGAUS et KGAR ** */
|
|
|
|
/* CALL MXVSAVE(IERXV,'INTEGER',I1,KGAR,'INTEGER',I1,NGAUS */
|
|
/* 1 ,'DOUBLE PRECISION',I20,UROOT,'DOUBLE PRECISION',I20,WGAUS) */
|
|
/* IF (IERXV.GT.0) KGAR=0 */
|
|
|
|
/* ****** Fin du sous-programme ** */
|
|
|
|
if (*iercod != 0) {
|
|
AdvApp2Var_SysBase::maermsg_("MMLONCV", iercod, 7L);
|
|
}
|
|
return 0 ;
|
|
} /* mmloncv_ */
|
|
|
|
//=======================================================================
|
|
//function : AdvApp2Var_MathBase::mmpobas_
|
|
//purpose :
|
|
//=======================================================================
|
|
int AdvApp2Var_MathBase::mmpobas_(doublereal *tparam,
|
|
integer *iordre,
|
|
integer *ncoeff,
|
|
integer *nderiv,
|
|
doublereal *valbas,
|
|
integer *iercod)
|
|
|
|
{
|
|
static integer c__2 = 2;
|
|
static integer c__1 = 1;
|
|
|
|
|
|
/* Initialized data */
|
|
|
|
static doublereal moin11[2] = { -1.,1. };
|
|
|
|
/* System generated locals */
|
|
integer valbas_dim1, i__1;
|
|
|
|
/* Local variables */
|
|
static doublereal vjac[80], herm[24];
|
|
static integer iord[2];
|
|
static doublereal wval[4];
|
|
static integer nwcof, iunit;
|
|
static doublereal wpoly[7];
|
|
static integer ii, jj, iorjac;
|
|
static doublereal hermit[36] /* was [6][3][2] */;
|
|
static integer kk1, kk2, kk3;
|
|
static integer khe, ier;
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* Positionnement sur les polynomes de la base hermite-Jacobi */
|
|
/* et leurs derives succesives */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* PUBLIC, POSITIONEMENT, HERMITE, JACOBI */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* -------------------- */
|
|
/* TPARAM : Parametre pour lequel on se positionne. */
|
|
/* IORDRE : Ordre d'hermite-Jacobi (-1,0,1, ou 2) */
|
|
/* NCOEFF : Nombre de coeeficients des polynomes (Nb de valeur a */
|
|
/* calculer) */
|
|
/* NDERIV : Nombre de derive a calculer (0<= N <=3) */
|
|
/* 0 -> Positionement simple sur les fonctions de base */
|
|
/* N -> Positionement sur les fonctions de base et lerive */
|
|
/* d'ordre 1 a N */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* --------------------- */
|
|
/* VALBAS (NCOEFF, 0:NDERIV) : les valeur calculee */
|
|
/* i */
|
|
/* d vj(t) = VALBAS(J, I) */
|
|
/* -- i */
|
|
/* dt */
|
|
|
|
/* IERCOD : Code d'erreur */
|
|
/* 0 : Ok */
|
|
/* 1 : Incoherance des arguments d'entre */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ------------------ */
|
|
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* --------------------- */
|
|
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* ------------------------------ */
|
|
/* 19-07-1995: PMN; ECRITURE VERSION ORIGINALE. */
|
|
/* > */
|
|
/* ***********************************************************************
|
|
*/
|
|
/* DECLARATIONS */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
|
|
|
|
/* Parameter adjustments */
|
|
valbas_dim1 = *ncoeff;
|
|
--valbas;
|
|
|
|
/* Function Body */
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* INITIALISATIONS */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
*iercod = 0;
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* TRAITEMENT */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
if (*nderiv > 3) {
|
|
goto L9101;
|
|
}
|
|
if (*ncoeff > 20) {
|
|
goto L9101;
|
|
}
|
|
if (*iordre > 2) {
|
|
goto L9101;
|
|
}
|
|
|
|
iord[0] = *iordre;
|
|
iord[1] = *iordre;
|
|
iorjac = (*iordre + 1) << 1;
|
|
|
|
/* (1) Calculs generiques .... */
|
|
|
|
/* (1.a) Calcul des polynomes d'hermite */
|
|
|
|
if (*iordre >= 0) {
|
|
mmherm1_(moin11, &c__2, iord, hermit, &ier);
|
|
if (ier > 0) {
|
|
goto L9102;
|
|
}
|
|
}
|
|
|
|
/* (1.b) Evaluation des polynomes d'hermite */
|
|
|
|
jj = 1;
|
|
iunit = *nderiv + 1;
|
|
khe = (*iordre + 1) * iunit;
|
|
|
|
if (*nderiv > 0) {
|
|
|
|
i__1 = *iordre;
|
|
for (ii = 0; ii <= i__1; ++ii) {
|
|
mmdrvcb_(nderiv, &c__1, &iorjac, &hermit[(ii + 3) * 6 - 18],
|
|
tparam, &herm[jj - 1], &ier);
|
|
if (ier > 0) {
|
|
goto L9102;
|
|
}
|
|
|
|
mmdrvcb_(nderiv, &c__1, &iorjac, &hermit[(ii + 6) * 6 - 18],
|
|
tparam, &herm[jj + khe - 1], &ier);
|
|
if (ier > 0) {
|
|
goto L9102;
|
|
}
|
|
jj += iunit;
|
|
}
|
|
|
|
} else {
|
|
|
|
i__1 = *iordre;
|
|
for (ii = 0; ii <= i__1; ++ii) {
|
|
AdvApp2Var_MathBase::mmpocrb_(&c__1, &iorjac, &hermit[(ii + 3) * 6 - 18], &c__1,
|
|
tparam, &herm[jj - 1]);
|
|
|
|
AdvApp2Var_MathBase::mmpocrb_(&c__1, &iorjac, &hermit[(ii + 6) * 6 - 18], &c__1,
|
|
tparam, &herm[jj + khe - 1]);
|
|
jj += iunit;
|
|
}
|
|
}
|
|
|
|
/* (1.c) Evaluation des polynomes de Jaccobi */
|
|
|
|
ii = *ncoeff - iorjac;
|
|
|
|
mmpojac_(tparam, &iorjac, &ii, nderiv, vjac, &ier);
|
|
if (ier > 0) {
|
|
goto L9102;
|
|
}
|
|
|
|
/* (1.d) Evaluation de W(t) */
|
|
|
|
/* Computing MAX */
|
|
i__1 = iorjac + 1;
|
|
nwcof = max(i__1,1);
|
|
AdvApp2Var_SysBase::mvriraz_((integer *)&nwcof,
|
|
(char *)wpoly);
|
|
wpoly[0] = 1.;
|
|
if (*iordre == 2) {
|
|
wpoly[2] = -3.;
|
|
wpoly[4] = 3.;
|
|
wpoly[6] = -1.;
|
|
} else if (*iordre == 1) {
|
|
wpoly[2] = -2.;
|
|
wpoly[4] = 1.;
|
|
} else if (*iordre == 0) {
|
|
wpoly[2] = -1.;
|
|
}
|
|
|
|
mmdrvcb_(nderiv, &c__1, &nwcof, wpoly, tparam, wval, &ier);
|
|
if (ier > 0) {
|
|
goto L9102;
|
|
}
|
|
|
|
kk1 = *ncoeff - iorjac;
|
|
kk2 = kk1 << 1;
|
|
kk3 = kk1 * 3;
|
|
|
|
/* (2) Evaluation a l'ordre 0 */
|
|
|
|
jj = 1;
|
|
i__1 = iorjac;
|
|
for (ii = 1; ii <= i__1; ++ii) {
|
|
valbas[ii] = herm[jj - 1];
|
|
jj += iunit;
|
|
}
|
|
|
|
i__1 = kk1;
|
|
for (ii = 1; ii <= i__1; ++ii) {
|
|
valbas[ii + iorjac] = wval[0] * vjac[ii - 1];
|
|
}
|
|
|
|
/* (3) Evaluation a l'ordre 1 */
|
|
|
|
if (*nderiv >= 1) {
|
|
jj = 2;
|
|
i__1 = iorjac;
|
|
for (ii = 1; ii <= i__1; ++ii) {
|
|
valbas[ii + valbas_dim1] = herm[jj - 1];
|
|
jj += iunit;
|
|
}
|
|
|
|
|
|
i__1 = kk1;
|
|
for (ii = 1; ii <= i__1; ++ii) {
|
|
valbas[ii + iorjac + valbas_dim1] = wval[0] * vjac[ii + kk1 - 1]
|
|
+ wval[1] * vjac[ii - 1];
|
|
}
|
|
}
|
|
|
|
/* (4) Evaluation a l'ordre 2 */
|
|
|
|
if (*nderiv >= 2) {
|
|
jj = 3;
|
|
i__1 = iorjac;
|
|
for (ii = 1; ii <= i__1; ++ii) {
|
|
valbas[ii + (valbas_dim1 << 1)] = herm[jj - 1];
|
|
jj += iunit;
|
|
}
|
|
|
|
i__1 = kk1;
|
|
for (ii = 1; ii <= i__1; ++ii) {
|
|
valbas[ii + iorjac + (valbas_dim1 << 1)] = wval[0] * vjac[ii +
|
|
kk2 - 1] + wval[1] * 2 * vjac[ii + kk1 - 1] + wval[2] *
|
|
vjac[ii - 1];
|
|
}
|
|
}
|
|
|
|
/* (5) Evaluation a l'ordre 3 */
|
|
|
|
if (*nderiv >= 3) {
|
|
jj = 4;
|
|
i__1 = iorjac;
|
|
for (ii = 1; ii <= i__1; ++ii) {
|
|
valbas[ii + valbas_dim1 * 3] = herm[jj - 1];
|
|
jj += iunit;
|
|
}
|
|
|
|
i__1 = kk1;
|
|
for (ii = 1; ii <= i__1; ++ii) {
|
|
valbas[ii + iorjac + valbas_dim1 * 3] = wval[0] * vjac[ii + kk3 -
|
|
1] + wval[1] * 3 * vjac[ii + kk2 - 1] + wval[2] * 3 *
|
|
vjac[ii + kk1 - 1] + wval[3] * vjac[ii - 1];
|
|
}
|
|
}
|
|
|
|
goto L9999;
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* TRAITEMENT DES ERREURS */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
L9101:
|
|
*iercod = 1;
|
|
goto L9999;
|
|
|
|
L9102:
|
|
*iercod = 2;
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* RETOUR PROGRAMME APPELANT */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
L9999:
|
|
|
|
if (*iercod > 0) {
|
|
AdvApp2Var_SysBase::maermsg_("MMPOBAS", iercod, 7L);
|
|
}
|
|
return 0 ;
|
|
} /* mmpobas_ */
|
|
|
|
//=======================================================================
|
|
//function : AdvApp2Var_MathBase::mmpocrb_
|
|
//purpose :
|
|
//=======================================================================
|
|
int AdvApp2Var_MathBase::mmpocrb_(integer *ndimax,
|
|
integer *ncoeff,
|
|
doublereal *courbe,
|
|
integer *ndim,
|
|
doublereal *tparam,
|
|
doublereal *pntcrb)
|
|
|
|
{
|
|
/* System generated locals */
|
|
integer courbe_dim1, courbe_offset, i__1, i__2;
|
|
|
|
/* Local variables */
|
|
static integer ncof2;
|
|
static integer isize, nd, kcf, ncf;
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* CALCULE LES COORDONNEES D'UN POINT D'UNE COURBE DE PARAMETRE */
|
|
/* DONNE TPARAM ( CECI EN 2D, 3D OU PLUS) */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* TOUS , MATH_ACCES :: COURBE&,PARAMETRE& , POSITIONNEMENT , &POINT
|
|
*/
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* ------------------ */
|
|
/* NDIMAX : format / dimension de la courbe */
|
|
/* NCOEFF : Nbre de coefficients de la courbe */
|
|
/* COURBE : Matrice des coefficients de la courbe */
|
|
/* NDIM : Dimension utile de l'espace de travail */
|
|
/* TPARAM : Valeur du parametre ou est calcule le point */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* ------------------- */
|
|
/* PNTCRB : Coordonnees du point calcule */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ---------------- */
|
|
|
|
/* .Neant. */
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* ---------------------- */
|
|
/* Type Name */
|
|
/* MIRAZ MVPSCR2 MVPSCR3 */
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* -------------------------------- */
|
|
/* 20-11-89 : JG : VERSION ORIGINALE */
|
|
/* > */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* Parameter adjustments */
|
|
courbe_dim1 = *ndimax;
|
|
courbe_offset = courbe_dim1 + 1;
|
|
courbe -= courbe_offset;
|
|
--pntcrb;
|
|
|
|
/* Function Body */
|
|
isize = *ndim << 3;
|
|
AdvApp2Var_SysBase::miraz_((integer *)&isize,
|
|
(char *)&pntcrb[1]);
|
|
|
|
if (*ncoeff <= 0) {
|
|
goto L9999;
|
|
}
|
|
|
|
/* Traitement optimal 3d */
|
|
|
|
if (*ndim == 3 && *ndimax == 3) {
|
|
mvpscr3_(ncoeff, &courbe[courbe_offset], tparam, &pntcrb[1]);
|
|
|
|
/* Traitement optimal 2d */
|
|
|
|
} else if (*ndim == 2 && *ndimax == 2) {
|
|
mvpscr2_(ncoeff, &courbe[courbe_offset], tparam, &pntcrb[1]);
|
|
|
|
/* Dimension quelconque - schema de HORNER */
|
|
|
|
} else if (*tparam == 0.) {
|
|
i__1 = *ndim;
|
|
for (nd = 1; nd <= i__1; ++nd) {
|
|
pntcrb[nd] = courbe[nd + courbe_dim1];
|
|
/* L100: */
|
|
}
|
|
} else if (*tparam == 1.) {
|
|
i__1 = *ncoeff;
|
|
for (ncf = 1; ncf <= i__1; ++ncf) {
|
|
i__2 = *ndim;
|
|
for (nd = 1; nd <= i__2; ++nd) {
|
|
pntcrb[nd] += courbe[nd + ncf * courbe_dim1];
|
|
/* L300: */
|
|
}
|
|
/* L200: */
|
|
}
|
|
} else {
|
|
ncof2 = *ncoeff + 2;
|
|
i__1 = *ndim;
|
|
for (nd = 1; nd <= i__1; ++nd) {
|
|
i__2 = *ncoeff;
|
|
for (ncf = 2; ncf <= i__2; ++ncf) {
|
|
kcf = ncof2 - ncf;
|
|
pntcrb[nd] = (pntcrb[nd] + courbe[nd + kcf * courbe_dim1]) * *
|
|
tparam;
|
|
/* L500: */
|
|
}
|
|
pntcrb[nd] += courbe[nd + courbe_dim1];
|
|
/* L400: */
|
|
}
|
|
}
|
|
|
|
L9999:
|
|
return 0 ;
|
|
} /* mmpocrb_ */
|
|
|
|
//=======================================================================
|
|
//function : AdvApp2Var_MathBase::mmmpocur_
|
|
//purpose :
|
|
//=======================================================================
|
|
int AdvApp2Var_MathBase::mmmpocur_(integer *ncofmx,
|
|
integer *ndim,
|
|
integer *ndeg,
|
|
doublereal *courbe,
|
|
doublereal *tparam,
|
|
doublereal *tabval)
|
|
|
|
{
|
|
/* System generated locals */
|
|
integer courbe_dim1, courbe_offset, i__1;
|
|
|
|
/* Local variables */
|
|
static integer i__, nd;
|
|
static doublereal fu;
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* Positionnement d'un point sur une courbe (ncofmx,ndim). */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* TOUS , AB_SPECIFI :: COURBE&,POLYNOME&,POSITIONNEMENT,&POINT */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* ------------------ */
|
|
/* NCOFMX: Format / degre de la COURBE. */
|
|
/* NDIM : Dimension de l' espace. */
|
|
/* NDEG : Degre du polynome. */
|
|
/* COURBE: Les coefficients de la courbe. */
|
|
/* TPARAM: parametre sur la courbe */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* ------------------- */
|
|
/* TABVAL(NDIM): Le point resultat (ou tableau de valeurs) */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ---------------- */
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* ----------------------- */
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* -------------------------------- */
|
|
/* 05-01-90 : JG : optimisation (supprim appel a MGENMSG) , nettoyage
|
|
*/
|
|
/* 18-09-85 : Cree par JJM. */
|
|
/* > */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* Parameter adjustments */
|
|
--tabval;
|
|
courbe_dim1 = *ncofmx;
|
|
courbe_offset = courbe_dim1 + 1;
|
|
courbe -= courbe_offset;
|
|
|
|
/* Function Body */
|
|
if (*ndeg < 1) {
|
|
i__1 = *ndim;
|
|
for (nd = 1; nd <= i__1; ++nd) {
|
|
tabval[nd] = 0.;
|
|
/* L290: */
|
|
}
|
|
} else {
|
|
i__1 = *ndim;
|
|
for (nd = 1; nd <= i__1; ++nd) {
|
|
fu = courbe[*ndeg + nd * courbe_dim1];
|
|
for (i__ = *ndeg - 1; i__ >= 1; --i__) {
|
|
fu = fu * *tparam + courbe[i__ + nd * courbe_dim1];
|
|
/* L120: */
|
|
}
|
|
tabval[nd] = fu;
|
|
/* L300: */
|
|
}
|
|
}
|
|
return 0 ;
|
|
} /* mmmpocur_ */
|
|
|
|
//=======================================================================
|
|
//function : mmpojac_
|
|
//purpose :
|
|
//=======================================================================
|
|
int mmpojac_(doublereal *tparam,
|
|
integer *iordre,
|
|
integer *ncoeff,
|
|
integer *nderiv,
|
|
doublereal *valjac,
|
|
integer *iercod)
|
|
|
|
{
|
|
static integer c__2 = 2;
|
|
|
|
/* Initialized data */
|
|
|
|
static integer nbcof = -1;
|
|
|
|
/* System generated locals */
|
|
integer valjac_dim1, i__1, i__2;
|
|
|
|
/* Local variables */
|
|
static doublereal cofa, cofb, denom, tnorm[100];
|
|
static integer ii, jj, kk1, kk2;
|
|
static doublereal aux1, aux2;
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* Positionnement sur les polynomes de Jacobi et leurs derives */
|
|
/* successives par un algorithme de recurence */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* RESERVE, POSITIONEMENT, JACOBI */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* -------------------- */
|
|
/* TPARAM : Parametre pour lequel on se positionne. */
|
|
/* IORDRE : Ordre d'hermite-?? (-1,0,1, ou 2) */
|
|
/* NCOEFF : Nombre de coeeficients des polynomes (Nb de valeur a */
|
|
/* calculer) */
|
|
/* NDERIV : Nombre de derive a calculer (0<= N <=3) */
|
|
/* 0 -> Positionement simple sur les fonctions de jacobi */
|
|
/* N -> Positionement sur les fonctions de jacobi et leurs */
|
|
/* derive d'ordre 1 a N. */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* --------------------- */
|
|
/* VALJAC (NCOEFF, 0:NDERIV) : les valeur calculee */
|
|
/* i */
|
|
/* d vj(t) = VALJAC(J, I) */
|
|
/* -- i */
|
|
/* dt */
|
|
|
|
/* IERCOD : Code d'erreur */
|
|
/* 0 : Ok */
|
|
/* 1 : Incoherance des arguments d'entre */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ------------------ */
|
|
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* --------------------- */
|
|
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* ------------------------------ */
|
|
/* 19-07-1995: PMN; ECRITURE VERSION ORIGINALE. */
|
|
/* > */
|
|
/* ***********************************************************************
|
|
*/
|
|
/* DECLARATIONS */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
|
|
/* varaibles statiques */
|
|
|
|
|
|
|
|
/* Parameter adjustments */
|
|
valjac_dim1 = *ncoeff;
|
|
--valjac;
|
|
|
|
/* Function Body */
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* INITIALISATIONS */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
*iercod = 0;
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* TRAITEMENT */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
if (*nderiv > 3) {
|
|
goto L9101;
|
|
}
|
|
if (*ncoeff > 100) {
|
|
goto L9101;
|
|
}
|
|
|
|
/* --- Calcul des normes */
|
|
|
|
/* IF (NCOEFF.GT.NBCOF) THEN */
|
|
i__1 = *ncoeff;
|
|
for (ii = 1; ii <= i__1; ++ii) {
|
|
kk1 = ii - 1;
|
|
aux2 = 1.;
|
|
i__2 = *iordre;
|
|
for (jj = 1; jj <= i__2; ++jj) {
|
|
aux2 = aux2 * (doublereal) (kk1 + *iordre + jj) / (doublereal) (
|
|
kk1 + jj);
|
|
}
|
|
i__2 = (*iordre << 1) + 1;
|
|
tnorm[ii - 1] = sqrt(aux2 * (kk1 * 2. + (*iordre << 1) + 1) / pow__ii(&
|
|
c__2, &i__2));
|
|
}
|
|
|
|
nbcof = *ncoeff;
|
|
|
|
/* END IF */
|
|
|
|
/* --- Positionements triviaux ----- */
|
|
|
|
valjac[1] = 1.;
|
|
aux1 = (doublereal) (*iordre + 1);
|
|
valjac[2] = aux1 * *tparam;
|
|
|
|
if (*nderiv >= 1) {
|
|
valjac[valjac_dim1 + 1] = 0.;
|
|
valjac[valjac_dim1 + 2] = aux1;
|
|
|
|
if (*nderiv >= 2) {
|
|
valjac[(valjac_dim1 << 1) + 1] = 0.;
|
|
valjac[(valjac_dim1 << 1) + 2] = 0.;
|
|
|
|
if (*nderiv >= 3) {
|
|
valjac[valjac_dim1 * 3 + 1] = 0.;
|
|
valjac[valjac_dim1 * 3 + 2] = 0.;
|
|
}
|
|
}
|
|
}
|
|
|
|
/* --- Positionement par reccurence */
|
|
|
|
i__1 = *ncoeff;
|
|
for (ii = 3; ii <= i__1; ++ii) {
|
|
|
|
kk1 = ii - 1;
|
|
kk2 = ii - 2;
|
|
aux1 = (doublereal) (*iordre + kk2);
|
|
aux2 = aux1 * 2;
|
|
cofa = aux2 * (aux2 + 1) * (aux2 + 2);
|
|
cofb = (aux2 + 2) * -2. * aux1 * aux1;
|
|
denom = kk1 * 2. * (kk2 + (*iordre << 1) + 1) * aux2;
|
|
denom = 1. / denom;
|
|
|
|
/* --> Pi(t) */
|
|
valjac[ii] = (cofa * *tparam * valjac[kk1] + cofb * valjac[kk2]) *
|
|
denom;
|
|
/* --> P'i(t) */
|
|
if (*nderiv >= 1) {
|
|
valjac[ii + valjac_dim1] = (cofa * *tparam * valjac[kk1 +
|
|
valjac_dim1] + cofa * valjac[kk1] + cofb * valjac[kk2 +
|
|
valjac_dim1]) * denom;
|
|
/* --> P''i(t) */
|
|
if (*nderiv >= 2) {
|
|
valjac[ii + (valjac_dim1 << 1)] = (cofa * *tparam * valjac[
|
|
kk1 + (valjac_dim1 << 1)] + cofa * 2 * valjac[kk1 +
|
|
valjac_dim1] + cofb * valjac[kk2 + (valjac_dim1 << 1)]
|
|
) * denom;
|
|
}
|
|
/* --> P'i(t) */
|
|
if (*nderiv >= 3) {
|
|
valjac[ii + valjac_dim1 * 3] = (cofa * *tparam * valjac[kk1 +
|
|
valjac_dim1 * 3] + cofa * 3 * valjac[kk1 + (
|
|
valjac_dim1 << 1)] + cofb * valjac[kk2 + valjac_dim1 *
|
|
3]) * denom;
|
|
}
|
|
}
|
|
}
|
|
|
|
/* ---> Normalisation */
|
|
|
|
i__1 = *ncoeff;
|
|
for (ii = 1; ii <= i__1; ++ii) {
|
|
i__2 = *nderiv;
|
|
for (jj = 0; jj <= i__2; ++jj) {
|
|
valjac[ii + jj * valjac_dim1] = tnorm[ii - 1] * valjac[ii + jj *
|
|
valjac_dim1];
|
|
}
|
|
}
|
|
|
|
goto L9999;
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* TRAITEMENT DES ERREURS */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
L9101:
|
|
*iercod = 1;
|
|
goto L9999;
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* RETOUR PROGRAMME APPELANT */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
L9999:
|
|
|
|
if (*iercod > 0) {
|
|
AdvApp2Var_SysBase::maermsg_("MMPOJAC", iercod, 7L);
|
|
}
|
|
return 0 ;
|
|
} /* mmpojac_ */
|
|
|
|
//=======================================================================
|
|
//function : AdvApp2Var_MathBase::mmposui_
|
|
//purpose :
|
|
//=======================================================================
|
|
int AdvApp2Var_MathBase::mmposui_(integer *dimmat,
|
|
integer *,//nistoc,
|
|
integer *aposit,
|
|
integer *posuiv,
|
|
integer *iercod)
|
|
|
|
{
|
|
/* System generated locals */
|
|
integer i__1, i__2;
|
|
|
|
/* Local variables */
|
|
static logical ldbg;
|
|
static integer imin, jmin, i__, j, k;
|
|
static logical trouve;
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* REMPLISSAGE DE LA TABLE DE POSITIONNEMENT POSUIV QUI PERMET DE */
|
|
/* PARCOURIR EN COLONNE LA PARTIE TRAINGULAIRE INFERIEUR DE LA */
|
|
/* MATRICE SOUS FORME DE PROFIL */
|
|
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* RESERVE, MATRICE, PROFIL */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* -------------------- */
|
|
|
|
/* NISTOC: NOMBRE DE COEFFICIENTS DANS LE PROFILE */
|
|
/* DIMMAT: NOMBRE DE LIGNE DE LA MATRICE CARRE SYMETRIQUE */
|
|
/* APOSIT: TABLE DE POSITIONNEMENT DES TERMES DE STOCKAGE */
|
|
/* APOSIT(1,I) CONTIENT LE NOMBRE DE TERMES-1 SUR LA LIGNE
|
|
*/
|
|
/* I DANS LE PROFIL DE LA MATRICE */
|
|
/* APOSIT(2,I) CONTIENT L'INDICE DE STOCKAGE DU TERME DIAGONA
|
|
L*/
|
|
/* DE LA LIGNE I */
|
|
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* --------------------- */
|
|
/* POSUIV: POSUIV(K) (OU K EST L'INDICE DE STOCKAGE DE MAT(I,J)) */
|
|
/* CONTIENT LE PLUS PETIT NUMERO IMIN>I DE LA LIGNE QUI */
|
|
/* POSSEDE UN TERME MAT(IMIN,J) QUI EST DANS LE PROFIL. */
|
|
/* S'IL N'Y A PAS LE TERME MAT(IMIN,J) DANS LE PROFIL */
|
|
/* ALORS POSUIV(K)=-1 */
|
|
|
|
|
|
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ------------------ */
|
|
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* --------------------- */
|
|
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* ------------------------------ */
|
|
/* 23-08-95 : KHN; ECRITURE VERSION ORIGINALE. */
|
|
/* > */
|
|
/* ***********************************************************************
|
|
*/
|
|
/* DECLARATIONS */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* INITIALISATIONS */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* Parameter adjustments */
|
|
aposit -= 3;
|
|
--posuiv;
|
|
|
|
/* Function Body */
|
|
ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 2;
|
|
if (ldbg) {
|
|
AdvApp2Var_SysBase::mgenmsg_("MMPOSUI", 7L);
|
|
}
|
|
*iercod = 0;
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* TRAITEMENT */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
|
|
|
|
i__1 = *dimmat;
|
|
for (i__ = 1; i__ <= i__1; ++i__) {
|
|
jmin = i__ - aposit[(i__ << 1) + 1];
|
|
i__2 = i__;
|
|
for (j = jmin; j <= i__2; ++j) {
|
|
imin = i__ + 1;
|
|
trouve = FALSE_;
|
|
while(! trouve && imin <= *dimmat) {
|
|
if (imin - aposit[(imin << 1) + 1] <= j) {
|
|
trouve = TRUE_;
|
|
} else {
|
|
++imin;
|
|
}
|
|
}
|
|
k = aposit[(i__ << 1) + 2] - i__ + j;
|
|
if (trouve) {
|
|
posuiv[k] = imin;
|
|
} else {
|
|
posuiv[k] = -1;
|
|
}
|
|
}
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
goto L9999;
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* TRAITEMENT DES ERREURS */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* RETOUR PROGRAMME APPELANT */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
L9999:
|
|
|
|
/* ___ DESALLOCATION, ... */
|
|
|
|
AdvApp2Var_SysBase::maermsg_("MMPOSUI", iercod, 7L);
|
|
if (ldbg) {
|
|
AdvApp2Var_SysBase::mgsomsg_("MMPOSUI", 7L);
|
|
}
|
|
return 0 ;
|
|
} /* mmposui_ */
|
|
|
|
//=======================================================================
|
|
//function : AdvApp2Var_MathBase::mmresol_
|
|
//purpose :
|
|
//=======================================================================
|
|
int AdvApp2Var_MathBase::mmresol_(integer *hdimen,
|
|
integer *gdimen,
|
|
integer *hnstoc,
|
|
integer *gnstoc,
|
|
integer *mnstoc,
|
|
doublereal *matsyh,
|
|
doublereal *matsyg,
|
|
doublereal *vecsyh,
|
|
doublereal *vecsyg,
|
|
integer *hposit,
|
|
integer *hposui,
|
|
integer *gposit,
|
|
integer *mmposui,
|
|
integer *mposit,
|
|
doublereal *vecsol,
|
|
integer *iercod)
|
|
|
|
{
|
|
static integer c__100 = 100;
|
|
|
|
/* System generated locals */
|
|
integer i__1, i__2;
|
|
|
|
/* Local variables */
|
|
static logical ldbg;
|
|
static doublereal mcho[100];
|
|
static integer jmin, jmax, i__, j, k, l;
|
|
static long int iofv1, iofv2, iofv3, iofv4;
|
|
static doublereal v1[100], v2[100], v3[100], v4[100];
|
|
static integer deblig, dimhch;
|
|
static doublereal hchole[100];
|
|
static long int iofmch, iofmam, iofhch;
|
|
static doublereal matsym[100];
|
|
static integer ier;
|
|
static integer aux;
|
|
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* RESOLUTION DU SYSTEME */
|
|
/* H t(G) V B */
|
|
/* = */
|
|
/* G 0 L C */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* RESERVE, RESOLUTION, SYSTEME, LAGRANGIEN */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* -------------------- */
|
|
/* HDIMEN: NOMBRE DE LIGNE(OU COLONNE) DE LA MATRICE HESSIENNE */
|
|
/* GDIMEN: NOMBRE DE LIGNE DE LA MATRICE DES CONTRAINTES */
|
|
/* HNSTOC: NOMBRES DE TERMES DANS LE PROFIL DE LA MATRICE HESSIENNE
|
|
*/
|
|
/* GNSTOC: NOMBRES DE TERMES DANS LE PROFIL DE LA MATRICE DES */
|
|
/* CONTRAINTES */
|
|
/* MNSTOC: NOMBRES DE TERMES DANS LE PROFIL DE LA MATRICE */
|
|
/* M= G H t(G) */
|
|
/* ou H EST LA MATRICE HESSIENNE ET G LA MATRICE DES */
|
|
/* CONTRAINTES */
|
|
/* MATSYH: PARTIE TRIANGULAIRE INFERIEUR DE LA MATRICE */
|
|
/* HESSIENNE SOUS FORME DE PROFIL */
|
|
/* MATSYG: MATRICE DES CONTRAINTES SOUS FORME DE PROFIL */
|
|
/* VECSYH: VECTEUR DU SECOND MEMBRE ASSOCIE A MATSYH */
|
|
/* VECSYG: VECTEUR DU SECOND MEMBRE ASSOCIE A MATSYG */
|
|
/* HPOSIT: TABLE DE POSITIONNEMENT DE LA MATRICE HESSIENNE */
|
|
/* HPOSIT(1,I) CONTIENT LE NOMBRE DE TERMES -1 */
|
|
/* QUI SONT DANS LE PROFIL A LA LIGNE I */
|
|
/* HPOSIT(2,I) CONTIENT L'INDICE DE STOCKAGE DU TERME */
|
|
/* DIAGNALE DE LA MATRICE A LA LIGNE I */
|
|
/* HPOSUI: TABLE PERMETTANT DE BALAYER EN COLONNE LA MATRICE */
|
|
/* HESSIENNE SOUS FORME DE PROFIL */
|
|
/* HPOSUI(K) CONTIENT LE NUMERO DE LIGNE IMIN SUIVANT LA LIGN
|
|
E*/
|
|
/* COURANT I OU H(I,J)=MATSYH(K) TEL QUE IL EXISTE DANS LA */
|
|
/* MEME COLONNE J UN TERME DANS LE PROFIL DE LA LIGNE IMIN */
|
|
/* SI UN TEL TERME N'EXISTE PAS IMIN=-1 */
|
|
/* GPOSIT: TABLE DE POSITIONNEMENT DE LA MATRICE DES CONTRAINTES */
|
|
/* GPOSIT(1,I) CONTIENT LE NOMBRE DE TERMES DE LA LIGNE I */
|
|
/* QUI SONT DANS LE PROFIL */
|
|
/* GPOSIT(2,I) CONTIENT L'INDICE DE STOKAGE DU DERNIER TERME
|
|
*/
|
|
/* DE LA LIGNE I QUI EST DANS LE PROFIL */
|
|
/* GPOSIT(3,I) CONTIENT LE NUMERO DE COLONNE CORRESPONDANT */
|
|
/* AU PREMIER TERME DE LA LIGNE I QUI EST DANS */
|
|
/* LE PROFIL */
|
|
/* MMPOSUI, MPOSIT: MEME STRUCTURE QUE HPOSUI, MAIS POUR LA MATRICE
|
|
*/
|
|
/* M=G H t(G) */
|
|
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* --------------------- */
|
|
/* VECSOL: VECTEUR SOLUTION V DU SYSTEME */
|
|
/* IERCOD: CODE D'ERREUR */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ------------------ */
|
|
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* --------------------- */
|
|
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* ------------------------------ */
|
|
/* 21-09-96 : KHN; ECRITURE VERSION ORIGINALE. */
|
|
/* > */
|
|
/* ***********************************************************************
|
|
*/
|
|
/* DECLARATIONS */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* INITIALISATIONS */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* Parameter adjustments */
|
|
--vecsol;
|
|
hposit -= 3;
|
|
--vecsyh;
|
|
--hposui;
|
|
--matsyh;
|
|
--matsyg;
|
|
--vecsyg;
|
|
gposit -= 4;
|
|
--mmposui;
|
|
mposit -= 3;
|
|
|
|
/* Function Body */
|
|
ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 2;
|
|
if (ldbg) {
|
|
AdvApp2Var_SysBase::mgenmsg_("MMRESOL", 7L);
|
|
}
|
|
*iercod = 0;
|
|
iofhch = 0;
|
|
iofv1 = 0;
|
|
iofv2 = 0;
|
|
iofv3 = 0;
|
|
iofv4 = 0;
|
|
iofmam = 0;
|
|
iofmch = 0;
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* TRAITEMENT */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* Allocation dynamique */
|
|
|
|
AdvApp2Var_SysBase::macrar8_(hdimen, &c__100, v1, &iofv1, &ier);
|
|
if (ier > 0) {
|
|
goto L9102;
|
|
}
|
|
dimhch = hposit[(*hdimen << 1) + 2];
|
|
AdvApp2Var_SysBase::macrar8_(&dimhch, &c__100, hchole, &iofhch, &ier);
|
|
if (ier > 0) {
|
|
goto L9102;
|
|
}
|
|
|
|
/* RESOL DU SYST 1 H V1 = b */
|
|
/* ou H=MATSYH et b=VECSYH */
|
|
|
|
mmchole_(hnstoc, hdimen, &matsyh[1], &hposit[3], &hposui[1], &hchole[
|
|
iofhch], &ier);
|
|
if (ier > 0) {
|
|
goto L9101;
|
|
}
|
|
mmrslss_(hnstoc, hdimen, &hchole[iofhch], &hposit[3], &hposui[1], &vecsyh[
|
|
1], &v1[iofv1], &ier);
|
|
if (ier > 0) {
|
|
goto L9102;
|
|
}
|
|
|
|
/* CAS OU IL Y A DES CONTRAINTES */
|
|
|
|
if (*gdimen > 0) {
|
|
|
|
/* CALCUL LE VECTEUR DU SECOND MEMBRE V2=G H(-1) b -c = G v1-c */
|
|
/* DU SYSTEME D'INCONNU LE VECTEUR MULTIP DE LAGRANGE */
|
|
/* ou G=MATSYG */
|
|
/* c=VECSYG */
|
|
|
|
AdvApp2Var_SysBase::macrar8_(gdimen, &c__100, v2, &iofv2, &ier);
|
|
if (ier > 0) {
|
|
goto L9102;
|
|
}
|
|
AdvApp2Var_SysBase::macrar8_(hdimen, &c__100, v3, &iofv3, &ier);
|
|
if (ier > 0) {
|
|
goto L9102;
|
|
}
|
|
AdvApp2Var_SysBase::macrar8_(gdimen, &c__100, v4, &iofv4, &ier);
|
|
if (ier > 0) {
|
|
goto L9102;
|
|
}
|
|
AdvApp2Var_SysBase::macrar8_(mnstoc, &c__100, matsym, &iofmam, &ier);
|
|
if (ier > 0) {
|
|
goto L9102;
|
|
}
|
|
|
|
deblig = 1;
|
|
mmatvec_(gdimen, hdimen, &gposit[4], gnstoc, &matsyg[1], &v1[iofv1], &
|
|
deblig, &v2[iofv2], &ier);
|
|
if (ier > 0) {
|
|
goto L9101;
|
|
}
|
|
i__1 = *gdimen;
|
|
for (i__ = 1; i__ <= i__1; ++i__) {
|
|
v2[i__ + iofv2 - 1] -= vecsyg[i__];
|
|
}
|
|
|
|
/* CALCUL de la matrice M= G H(-1) t(G) */
|
|
/* RESOL DU SYST 2 : H qi = gi */
|
|
/* ou gi est un vecteur colonne de t(G) */
|
|
/* qi=v3 */
|
|
/* puis calcul G qi */
|
|
/* puis construire M sous forme de profil */
|
|
|
|
|
|
|
|
i__1 = *gdimen;
|
|
for (i__ = 1; i__ <= i__1; ++i__) {
|
|
AdvApp2Var_SysBase::mvriraz_((integer *)hdimen, (char *)&v1[iofv1]);
|
|
AdvApp2Var_SysBase::mvriraz_((integer *)hdimen, (char *)&v3[iofv3]);
|
|
AdvApp2Var_SysBase::mvriraz_((integer *)gdimen, (char *)&v4[iofv4]);
|
|
jmin = gposit[i__ * 3 + 3];
|
|
jmax = gposit[i__ * 3 + 1] + gposit[i__ * 3 + 3] - 1;
|
|
aux = gposit[i__ * 3 + 2] - gposit[i__ * 3 + 1] - jmin + 1;
|
|
i__2 = jmax;
|
|
for (j = jmin; j <= i__2; ++j) {
|
|
k = j + aux;
|
|
v1[j + iofv1 - 1] = matsyg[k];
|
|
}
|
|
mmrslss_(hnstoc, hdimen, &hchole[iofhch], &hposit[3], &hposui[1],
|
|
&v1[iofv1], &v3[iofv3], &ier);
|
|
if (ier > 0) {
|
|
goto L9101;
|
|
}
|
|
|
|
deblig = i__;
|
|
mmatvec_(gdimen, hdimen, &gposit[4], gnstoc, &matsyg[1], &v3[
|
|
iofv3], &deblig, &v4[iofv4], &ier);
|
|
if (ier > 0) {
|
|
goto L9101;
|
|
}
|
|
|
|
k = mposit[(i__ << 1) + 2];
|
|
matsym[k + iofmam - 1] = v4[i__ + iofv4 - 1];
|
|
while(mmposui[k] > 0) {
|
|
l = mmposui[k];
|
|
k = mposit[(l << 1) + 2] - l + i__;
|
|
matsym[k + iofmam - 1] = v4[l + iofv4 - 1];
|
|
}
|
|
}
|
|
|
|
|
|
/* RESOL SYST 3 M L = V2 */
|
|
/* AVEC L=V4 */
|
|
|
|
|
|
AdvApp2Var_SysBase::mvriraz_((integer *)gdimen, (char *)&v4[iofv4]);
|
|
AdvApp2Var_SysBase::macrar8_(mnstoc, &c__100, mcho, &iofmch, &ier);
|
|
if (ier > 0) {
|
|
goto L9102;
|
|
}
|
|
mmchole_(mnstoc, gdimen, &matsym[iofmam], &mposit[3], &mmposui[1], &
|
|
mcho[iofmch], &ier);
|
|
if (ier > 0) {
|
|
goto L9101;
|
|
}
|
|
mmrslss_(mnstoc, gdimen, &mcho[iofmch], &mposit[3], &mmposui[1], &v2[
|
|
iofv2], &v4[iofv4], &ier);
|
|
if (ier > 0) {
|
|
goto L9102;
|
|
}
|
|
|
|
|
|
/* CALCUL LE VECTEUR DU SECOND MEMBRE DU SYSTEME Hx = b - t(G) L
|
|
*/
|
|
/* = V1 */
|
|
|
|
AdvApp2Var_SysBase::mvriraz_((integer *)hdimen, (char *)&v1[iofv1]);
|
|
mmtmave_(gdimen, hdimen, &gposit[4], gnstoc, &matsyg[1], &v4[iofv4], &
|
|
v1[iofv1], &ier);
|
|
if (ier > 0) {
|
|
goto L9101;
|
|
}
|
|
i__1 = *hdimen;
|
|
for (i__ = 1; i__ <= i__1; ++i__) {
|
|
v1[i__ + iofv1 - 1] = vecsyh[i__] - v1[i__ + iofv1 - 1];
|
|
}
|
|
|
|
/* RESOL SYST 4 Hx = b - t(G) L */
|
|
|
|
|
|
mmrslss_(hnstoc, hdimen, &hchole[iofhch], &hposit[3], &hposui[1], &v1[
|
|
iofv1], &vecsol[1], &ier);
|
|
if (ier > 0) {
|
|
goto L9102;
|
|
}
|
|
} else {
|
|
i__1 = *hdimen;
|
|
for (i__ = 1; i__ <= i__1; ++i__) {
|
|
vecsol[i__] = v1[i__ + iofv1 - 1];
|
|
}
|
|
}
|
|
|
|
goto L9999;
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* TRAITEMENT DES ERREURS */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
|
|
L9101:
|
|
*iercod = 1;
|
|
goto L9999;
|
|
|
|
L9102:
|
|
AdvApp2Var_SysBase::mswrdbg_("MMRESOL : PROBLEME AVEC DIMMAT", 30L);
|
|
*iercod = 2;
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* RETOUR PROGRAMME APPELANT */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
L9999:
|
|
|
|
/* ___ DESALLOCATION, ... */
|
|
AdvApp2Var_SysBase::macrdr8_(hdimen, &c__100, v1, &iofv1, &ier);
|
|
if (*iercod == 0 && ier > 0) {
|
|
*iercod = 3;
|
|
}
|
|
AdvApp2Var_SysBase::macrdr8_(&dimhch, &c__100, hchole, &iofhch, &ier);
|
|
if (*iercod == 0 && ier > 0) {
|
|
*iercod = 3;
|
|
}
|
|
AdvApp2Var_SysBase::macrdr8_(gdimen, &c__100, v2, &iofv2, &ier);
|
|
if (*iercod == 0 && ier > 0) {
|
|
*iercod = 3;
|
|
}
|
|
AdvApp2Var_SysBase::macrdr8_(hdimen, &c__100, v3, &iofv3, &ier);
|
|
if (*iercod == 0 && ier > 0) {
|
|
*iercod = 3;
|
|
}
|
|
AdvApp2Var_SysBase::macrdr8_(gdimen, &c__100, v4, &iofv4, &ier);
|
|
if (*iercod == 0 && ier > 0) {
|
|
*iercod = 3;
|
|
}
|
|
AdvApp2Var_SysBase::macrdr8_(mnstoc, &c__100, matsym, &iofmam, &ier);
|
|
if (*iercod == 0 && ier > 0) {
|
|
*iercod = 3;
|
|
}
|
|
AdvApp2Var_SysBase::macrdr8_(mnstoc, &c__100, mcho, &iofmch, &ier);
|
|
if (*iercod == 0 && ier > 0) {
|
|
*iercod = 3;
|
|
}
|
|
|
|
AdvApp2Var_SysBase::maermsg_("MMRESOL", iercod, 7L);
|
|
if (ldbg) {
|
|
AdvApp2Var_SysBase::mgsomsg_("MMRESOL", 7L);
|
|
}
|
|
return 0 ;
|
|
} /* mmresol_ */
|
|
|
|
//=======================================================================
|
|
//function : mmrslss_
|
|
//purpose :
|
|
//=======================================================================
|
|
int mmrslss_(integer *,//mxcoef,
|
|
integer *dimens,
|
|
doublereal *smatri,
|
|
integer *sposit,
|
|
integer *posuiv,
|
|
doublereal *mscnmbr,
|
|
doublereal *soluti,
|
|
integer *iercod)
|
|
{
|
|
/* System generated locals */
|
|
integer i__1, i__2;
|
|
|
|
/* Local variables */
|
|
static logical ldbg;
|
|
static integer i__, j;
|
|
static doublereal somme;
|
|
static integer pointe, ptcour;
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- T */
|
|
/* Resoud le systeme lineaire SS x = b ou S est une matrice */
|
|
/* triangulaire inferieure donnee sous forme profil */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* RESERVE, MATRICE_PROFILE, RESOLUTION, CHOLESKI */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* -------------------- */
|
|
/* MXCOEF : Nombre maximal de coefficient non nuls dans la matrice */
|
|
/* DIMENS : Dimension de la matrice */
|
|
/* SMATRI(MXCOEF) : Valeurs des coefficients de la matrice */
|
|
/* SPOSIT(2,DIMENS): */
|
|
/* SPOSIT(1,*) : Distance diagonnal-extrimite de la ligne */
|
|
/* SPOSIT(2,*) : Position des termes diagonnaux dans AMATRI */
|
|
/* POSUIV(MXCOEF): premiere ligne inferieure non hors profil */
|
|
/* MSCNMBR(DIMENS): Vecteur second membre de l'equation */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* --------------------- */
|
|
/* SOLUTI(NDIMEN) : Vecteur resultat */
|
|
/* IERCOD : Code d'erreur 0 : ok */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ------------------ */
|
|
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* --------------------- */
|
|
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
/* T */
|
|
/* SS est la decomposition de choleski d'une matrice symetrique */
|
|
/* definie postive, qui peut s'obtenir par la routine MMCHOLE. */
|
|
|
|
/* Pour une matrice pleine on peut utiliser MRSLMSC */
|
|
|
|
/* NIVEAU DE DEBUG = 4 */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* ------------------------------ */
|
|
/* 14-02-1994: PMN; ECRITURE VERSION ORIGINALE. */
|
|
/* > */
|
|
/* ***********************************************************************
|
|
*/
|
|
/* DECLARATIONS */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* INITIALISATIONS */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* Parameter adjustments */
|
|
--posuiv;
|
|
--smatri;
|
|
--soluti;
|
|
--mscnmbr;
|
|
sposit -= 3;
|
|
|
|
/* Function Body */
|
|
ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 4;
|
|
if (ldbg) {
|
|
AdvApp2Var_SysBase::mgenmsg_("MMRSLSS", 7L);
|
|
}
|
|
*iercod = 0;
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* TRAITEMENT */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* ----- Resolution de Sw = b */
|
|
|
|
i__1 = *dimens;
|
|
for (i__ = 1; i__ <= i__1; ++i__) {
|
|
|
|
pointe = sposit[(i__ << 1) + 2];
|
|
somme = 0.;
|
|
i__2 = i__ - 1;
|
|
for (j = i__ - sposit[(i__ << 1) + 1]; j <= i__2; ++j) {
|
|
somme += smatri[pointe - (i__ - j)] * soluti[j];
|
|
}
|
|
|
|
soluti[i__] = (mscnmbr[i__] - somme) / smatri[pointe];
|
|
}
|
|
/* T */
|
|
/* ----- Resolution de S u = w */
|
|
|
|
for (i__ = *dimens; i__ >= 1; --i__) {
|
|
|
|
pointe = sposit[(i__ << 1) + 2];
|
|
j = posuiv[pointe];
|
|
somme = 0.;
|
|
while(j > 0) {
|
|
ptcour = sposit[(j << 1) + 2] - (j - i__);
|
|
somme += smatri[ptcour] * soluti[j];
|
|
j = posuiv[ptcour];
|
|
}
|
|
|
|
soluti[i__] = (soluti[i__] - somme) / smatri[pointe];
|
|
}
|
|
|
|
goto L9999;
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* TRAITEMENT DES ERREURS */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* RETOUR PROGRAMME APPELANT */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
L9999:
|
|
|
|
AdvApp2Var_SysBase::maermsg_("MMRSLSS", iercod, 7L);
|
|
if (ldbg) {
|
|
AdvApp2Var_SysBase::mgsomsg_("MMRSLSS", 7L);
|
|
}
|
|
return 0 ;
|
|
} /* mmrslss_ */
|
|
|
|
//=======================================================================
|
|
//function : mmrslw_
|
|
//purpose :
|
|
//=======================================================================
|
|
int mmrslw_(integer *normax,
|
|
integer *nordre,
|
|
integer *ndimen,
|
|
doublereal *epspiv,
|
|
doublereal *abmatr,
|
|
doublereal *xmatri,
|
|
integer *iercod)
|
|
{
|
|
/* System generated locals */
|
|
integer abmatr_dim1, abmatr_offset, xmatri_dim1, xmatri_offset, i__1,
|
|
i__2, i__3;
|
|
doublereal d__1;
|
|
|
|
/* Local variables */
|
|
static integer kpiv;
|
|
static doublereal pivot;
|
|
static integer ii, jj, kk;
|
|
static doublereal akj;
|
|
|
|
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* Resolution d' un systeme lineaire A.x = B de N equations a N */
|
|
/* inconnues par la methode de Gauss (pivot partiel) ou : */
|
|
/* A est une matrice NORDRE * NORDRE, */
|
|
/* B est une matrice NORDRE (lignes) * NDIMEN (colonnes), */
|
|
/* x est une matrice NORDRE (lignes) * NDIMEN (colonnes). */
|
|
/* Dans ce programme, A et B sont stockes dans la matrice ABMATR dont */
|
|
/* les lignes et les colonnes ont ete inversees. ABMATR(k,j) est le */
|
|
/* terme A(j,k) si k <= NORDRE, B(j,k-NORDRE) sinon (cf. exemple). */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* TOUS, MATH_ACCES::EQUATION&, MATRICE&, RESOLUTION, GAUSS, &SOLUTION */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* ------------------ */
|
|
/* NORMAX : Taille maximale du premier indice de XMATRI. Cet argument */
|
|
/* ne sert que pour la declaration de dimension de XMATRI et */
|
|
/* doit etre superieur ou egal a NORDRE. */
|
|
/* NORDRE : Ordre de la matrice i.e. nombre d'equations et */
|
|
/* d'inconnues du systeme lineaire a resoudre. */
|
|
/* NDIMEN : Nombre de second membre. */
|
|
/* EPSPIV : Valeur minimale d'un pivot. Si au cours du calcul la */
|
|
/* valeur absolue du pivot est inferieure a EPSPIV, le */
|
|
/* systeme d'equations est declare singulier. EPSPIV doit */
|
|
/* etre un "petit" reel. */
|
|
|
|
/* ABMATR(NORDRE+NDIMEN,NORDRE) : Matrice auxiliaire contenant la */
|
|
/* matrice A et la matrice B. */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* ------------------- */
|
|
/* XMATRI : Matrice contenant les NORDRE*NDIMEN solutions. */
|
|
/* IERCOD=0 indique que toutes les solutions sont calculees. */
|
|
/* IERCOD=1 indique que la matrice est de rang inferieur a NORDRE */
|
|
/* (le systeme est singulier). */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ---------------- */
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* ----------------------- */
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
/* ATTENTION : les indices de ligne et de colonne sont inverses */
|
|
/* par rapport aux indices habituels. */
|
|
/* Le systeme : */
|
|
/* a1*x + b1*y = c1 */
|
|
/* a2*x + b2*y = c2 */
|
|
/* doit etre represente par la matrice ABMATR : */
|
|
|
|
/* ABMATR(1,1) = a1 ABMATR(1,2) = a2 */
|
|
/* ABMATR(2,1) = b1 ABMATR(2,2) = b2 */
|
|
/* ABMATR(3,1) = c1 ABMATR(3,2) = c2 */
|
|
|
|
/* Pour resoudre ce systeme, il faut poser: */
|
|
|
|
/* NORDRE = 2 (il y a 2 equations a 2 inconnues), */
|
|
/* NDIMEN = 1 (il y a un seul second membre), */
|
|
/* NORMAX peut etre pris quelconque >= NORDRE. */
|
|
|
|
/* Pour utiliser cette routine, il est conseille de se */
|
|
/* servir de l'une des interfaces : MMRSLWI ou de MMMRSLWD. */
|
|
|
|
/* HISTORIQUE DES MODIFICATIONS : */
|
|
/* -------------------------------- */
|
|
/* 24-11-1995 : JPI ; annulation des modifs concernant la factorisation
|
|
*/
|
|
/* de 1/PIVOT (Pb numerique) */
|
|
/* 08-09-1995 : JMF ; performances */
|
|
/* 06-04-1990 : RBD ; Ajout commentaires et Implicit none. */
|
|
/* 22-02-1988 : JJM ; Appel MFNDEB -> MNFNDEB */
|
|
/* 22-02-1988 : JJM ; Appel GERMSG -> MAERMSG */
|
|
/* 21-09-1987 : creation de la matrice unique ABMATR et des */
|
|
/* interfaces MMRSLWI et MMMRSLWD (RBD). */
|
|
/* 01-07-1987 : Cree par R. Beraud. */
|
|
/* > */
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
/* Le nom de la routine */
|
|
|
|
/* INTEGER IBB,MNFNDEB */
|
|
|
|
/* IBB=MNFNDEB() */
|
|
/* IF (IBB.GE.2) CALL MGENMSG(NOMPR) */
|
|
/* Parameter adjustments */
|
|
xmatri_dim1 = *normax;
|
|
xmatri_offset = xmatri_dim1 + 1;
|
|
xmatri -= xmatri_offset;
|
|
abmatr_dim1 = *nordre + *ndimen;
|
|
abmatr_offset = abmatr_dim1 + 1;
|
|
abmatr -= abmatr_offset;
|
|
|
|
/* Function Body */
|
|
*iercod = 0;
|
|
|
|
/* *********************************************************************
|
|
*/
|
|
/* Triangulation de la matrice ABMATR. */
|
|
/* *********************************************************************
|
|
*/
|
|
|
|
i__1 = *nordre;
|
|
for (kk = 1; kk <= i__1; ++kk) {
|
|
|
|
/* ---------- Recherche du pivot maxi sur la colonne KK. ------------
|
|
--- */
|
|
|
|
pivot = *epspiv;
|
|
kpiv = 0;
|
|
i__2 = *nordre;
|
|
for (jj = kk; jj <= i__2; ++jj) {
|
|
akj = (d__1 = abmatr[kk + jj * abmatr_dim1], abs(d__1));
|
|
if (akj > pivot) {
|
|
pivot = akj;
|
|
kpiv = jj;
|
|
}
|
|
/* L100: */
|
|
}
|
|
if (kpiv == 0) {
|
|
goto L9900;
|
|
}
|
|
|
|
/* --------- Permutation de la ligne KPIV et avec la ligne KK. ------
|
|
--- */
|
|
|
|
if (kpiv != kk) {
|
|
i__2 = *nordre + *ndimen;
|
|
for (jj = kk; jj <= i__2; ++jj) {
|
|
akj = abmatr[jj + kk * abmatr_dim1];
|
|
abmatr[jj + kk * abmatr_dim1] = abmatr[jj + kpiv *
|
|
abmatr_dim1];
|
|
abmatr[jj + kpiv * abmatr_dim1] = akj;
|
|
/* L200: */
|
|
}
|
|
}
|
|
|
|
/* -------------------- Elimination et triangularisation. -----------
|
|
--- */
|
|
|
|
pivot = -abmatr[kk + kk * abmatr_dim1];
|
|
i__2 = *nordre;
|
|
for (ii = kk + 1; ii <= i__2; ++ii) {
|
|
akj = abmatr[kk + ii * abmatr_dim1] / pivot;
|
|
i__3 = *nordre + *ndimen;
|
|
for (jj = kk + 1; jj <= i__3; ++jj) {
|
|
abmatr[jj + ii * abmatr_dim1] += akj * abmatr[jj + kk *
|
|
abmatr_dim1];
|
|
/* L400: */
|
|
}
|
|
/* L300: */
|
|
}
|
|
|
|
|
|
/* L1000: */
|
|
}
|
|
|
|
/* *********************************************************************
|
|
*/
|
|
/* Resolution du systeme d'equations triangulaires. */
|
|
/* La matrice ABMATR(NORDRE+JJ,II), contient les second membres du */
|
|
/* systeme pour 1<=j<=NDIMEN et 1<=i<=NORDRE. */
|
|
/* *********************************************************************
|
|
*/
|
|
|
|
|
|
/* ---------------- Calcul des solutions en remontant. -----------------
|
|
*/
|
|
|
|
for (kk = *nordre; kk >= 1; --kk) {
|
|
pivot = abmatr[kk + kk * abmatr_dim1];
|
|
i__1 = *ndimen;
|
|
for (ii = 1; ii <= i__1; ++ii) {
|
|
akj = abmatr[ii + *nordre + kk * abmatr_dim1];
|
|
i__2 = *nordre;
|
|
for (jj = kk + 1; jj <= i__2; ++jj) {
|
|
akj -= abmatr[jj + kk * abmatr_dim1] * xmatri[jj + ii *
|
|
xmatri_dim1];
|
|
/* L800: */
|
|
}
|
|
xmatri[kk + ii * xmatri_dim1] = akj / pivot;
|
|
/* L700: */
|
|
}
|
|
/* L600: */
|
|
}
|
|
goto L9999;
|
|
|
|
/* ------Si la valeur absolue de l' un des pivot est plus petit --------
|
|
*/
|
|
/* ------------ que EPSPIV: recuperation du code d' erreur. ------------
|
|
*/
|
|
|
|
L9900:
|
|
*iercod = 1;
|
|
|
|
|
|
|
|
L9999:
|
|
if (*iercod > 0) {
|
|
AdvApp2Var_SysBase::maermsg_("MMRSLW ", iercod, 7L);
|
|
}
|
|
/* IF (IBB.GE.2) CALL MGSOMSG(NOMPR) */
|
|
return 0 ;
|
|
} /* mmrslw_ */
|
|
|
|
//=======================================================================
|
|
//function : AdvApp2Var_MathBase::mmmrslwd_
|
|
//purpose :
|
|
//=======================================================================
|
|
int AdvApp2Var_MathBase::mmmrslwd_(integer *normax,
|
|
integer *nordre,
|
|
integer *ndim,
|
|
doublereal *amat,
|
|
doublereal *bmat,
|
|
doublereal *epspiv,
|
|
doublereal *aaux,
|
|
doublereal *xmat,
|
|
integer *iercod)
|
|
|
|
{
|
|
/* System generated locals */
|
|
integer amat_dim1, amat_offset, bmat_dim1, bmat_offset, xmat_dim1,
|
|
xmat_offset, aaux_dim1, aaux_offset, i__1, i__2;
|
|
|
|
/* Local variables */
|
|
static integer i__, j;
|
|
static integer ibb;
|
|
|
|
/* IMPLICIT DOUBLE PRECISION (A-H,O-Z) */
|
|
/* IMPLICIT INTEGER (I-N) */
|
|
|
|
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* Resolution d' un systeme lineaire par la methode de Gauss ou */
|
|
/* le second membre est un tableau de vecteurs. Methode du pivot */
|
|
/* partiel. */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* TOUS , MATH_ACCES :: */
|
|
/* SYSTEME&,EQUATION&, RESOLUTION,GAUSS ,&VECTEUR */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* ------------------ */
|
|
/* NORMAX : Dimensionnement maxi de AMAT. */
|
|
/* NORDRE : Ordre de la matrice. */
|
|
/* NDIM : Nombre de colonnes de BMAT et XMAT. */
|
|
/* AMAT(NORMAX,NORDRE) : La matrice traitee. */
|
|
/* BMAT(NORMAX,NDIM) : La matrice des second membre. */
|
|
/* XMAT(NORMAX,NDIM) : La matrice des solutions. */
|
|
/* EPSPIV : Valeur minimale d'un pivot. */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* ------------------- */
|
|
/* AAUX(NORDRE+NDIM,NORDRE) : Matrice auxiliaire. */
|
|
/* XMAT(NORMAX,NDIM) : La matrice des solutions. */
|
|
/* IERCOD=0 indique que les solutions dans XMAT sont valables. */
|
|
/* IERCOD=1 indique que la matrice AMAT est de rang inferieur */
|
|
/* a NORDRE. */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ---------------- */
|
|
|
|
/* .Neant. */
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* ---------------------- */
|
|
/* Type Name */
|
|
/* MAERMSG MGENMSG MGSOMSG */
|
|
/* MMRSLW I*4 MNFNDEB */
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
/* ATTENTION :les lignes et les colonnes sont dans l' ordre */
|
|
/* habituel : */
|
|
/* 1er indice = indice ligne */
|
|
/* 2eme indice = indice colonne */
|
|
/* Exemple, Le systeme : */
|
|
/* a1*x + b1*y = c1 */
|
|
/* a2*x + b2*y = c2 */
|
|
/* est represente par la matrice AMAT : */
|
|
|
|
/* AMAT(1,1) = a1 AMAT(2,1) = a2 */
|
|
/* AMAT(1,2) = b1 AMAT(2,2) = b2 */
|
|
|
|
/* Le premier indice est l' indice de ligne, le second indice */
|
|
/* est l' indice des colonnes (Comparer avec MMRSLWI qui est */
|
|
/* plus rapide). */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* -------------------------------- */
|
|
/* 11-09-1995 : JMF ; Implicit none */
|
|
/* 22-02-1988 : JJM ; Appel MFNDEB -> MNFNDEB */
|
|
/* 22-02-1988 : JJM ; Appel GERMSG -> MAERMSG */
|
|
/* 17-09-1987: Cree par RBD */
|
|
/* > */
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
/* Le nom de la routine */
|
|
|
|
/* Parameter adjustments */
|
|
amat_dim1 = *normax;
|
|
amat_offset = amat_dim1 + 1;
|
|
amat -= amat_offset;
|
|
xmat_dim1 = *normax;
|
|
xmat_offset = xmat_dim1 + 1;
|
|
xmat -= xmat_offset;
|
|
aaux_dim1 = *nordre + *ndim;
|
|
aaux_offset = aaux_dim1 + 1;
|
|
aaux -= aaux_offset;
|
|
bmat_dim1 = *normax;
|
|
bmat_offset = bmat_dim1 + 1;
|
|
bmat -= bmat_offset;
|
|
|
|
/* Function Body */
|
|
ibb = AdvApp2Var_SysBase::mnfndeb_();
|
|
if (ibb >= 3) {
|
|
AdvApp2Var_SysBase::mgenmsg_("MMMRSLW", 7L);
|
|
}
|
|
|
|
/* Initialisation de la matrice auxiliaire. */
|
|
|
|
i__1 = *nordre;
|
|
for (i__ = 1; i__ <= i__1; ++i__) {
|
|
i__2 = *nordre;
|
|
for (j = 1; j <= i__2; ++j) {
|
|
aaux[j + i__ * aaux_dim1] = amat[i__ + j * amat_dim1];
|
|
/* L200: */
|
|
}
|
|
/* L100: */
|
|
}
|
|
|
|
/* Second membre. */
|
|
|
|
i__1 = *nordre;
|
|
for (i__ = 1; i__ <= i__1; ++i__) {
|
|
i__2 = *ndim;
|
|
for (j = 1; j <= i__2; ++j) {
|
|
aaux[j + *nordre + i__ * aaux_dim1] = bmat[i__ + j * bmat_dim1];
|
|
/* L400: */
|
|
}
|
|
/* L300: */
|
|
}
|
|
|
|
/* Resolution du systeme d' equations. */
|
|
|
|
mmrslw_(normax, nordre, ndim, epspiv, &aaux[aaux_offset], &xmat[
|
|
xmat_offset], iercod);
|
|
|
|
|
|
if (*iercod != 0) {
|
|
AdvApp2Var_SysBase::maermsg_("MMMRSLW", iercod, 7L);
|
|
}
|
|
if (ibb >= 3) {
|
|
AdvApp2Var_SysBase::mgsomsg_("MMMRSLW", 7L);
|
|
}
|
|
return 0 ;
|
|
} /* mmmrslwd_ */
|
|
|
|
//=======================================================================
|
|
//function : AdvApp2Var_MathBase::mmrtptt_
|
|
//purpose :
|
|
//=======================================================================
|
|
int AdvApp2Var_MathBase::mmrtptt_(integer *ndglgd,
|
|
doublereal *rtlegd)
|
|
|
|
{
|
|
static integer ideb, nmod2, nsur2, ilong, ibb;
|
|
|
|
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* Extrait du Common LDGRTL les racines STRICTEMENT positives du */
|
|
/* polynome de Legendre de degre NDGLGD, pour 2 <= NDGLGD <= 61. */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* TOUS, AB_SPECIFI::COMMON&, EXTRACTION, &RACINE, &LEGENDRE. */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* ------------------ */
|
|
/* NDGLGD : Degre mathematique du polynome de Legendre. */
|
|
/* Ce degre doit etre superieur ou egal a 2 et */
|
|
/* inferieur ou egal a 61. */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* ------------------- */
|
|
/* RTLEGD : Le tableau des racines strictement positives du */
|
|
/* polynome de Legendre de degre NDGLGD. */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ---------------- */
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* ----------------------- */
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
/* ATTENTION: La condition sur NDEGRE ( 2 <= NDEGRE <= 61) n'est */
|
|
/* pas testee. A l'appelant de faire le test. */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* -------------------------------- */
|
|
/* 23-03-1990 : RBD ; Ajout commentaires + declaration. */
|
|
/* 15-01-1990 : NAK ; MLGDRTL PAR INCLUDE MMLGDRT */
|
|
/* 21-04-1989 : RBD ; Creation. */
|
|
/* > */
|
|
/* **********************************************************************
|
|
*/
|
|
/* Le nom de la routine */
|
|
|
|
|
|
/* Le common MLGDRTL: */
|
|
/* Ce common comprend les racines POSITIVES des polynomes de Legendre */
|
|
/* ET les poids des formules de quadrature de Gauss sur toutes les */
|
|
/* racines POSITIVES des polynomes de Legendre. */
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* Le common des racines de Legendre. */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* BASE LEGENDRE */
|
|
|
|
/* DEMSCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* ------------------------------ */
|
|
/* 11-01-90 : NAK ; Creation version originale */
|
|
/* > */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
|
|
|
|
|
|
/* ROOTAB : Tableau de toutes les racines des polynomes de Legendre */
|
|
/* comprises entre ]0,1]. Elles sont rangees pour des degres croissants
|
|
*/
|
|
/* de 2 a 61. */
|
|
/* HILTAB : Tableau des interpolants de Legendre concernant ROOTAB. */
|
|
/* L' adressage est le meme. */
|
|
/* HI0TAB : Tableau des interpolants de Legendre pour la racine x=0 */
|
|
/* des polynomes de degre IMPAIR. */
|
|
/* RTLTB0 : Tableau des Li(uk) ou les uk sont les racines d' un */
|
|
/* polynome de Legendre de degre PAIR. */
|
|
/* RTLTB1 : Tableau des Li(uk) ou les uk sont les racines d' un */
|
|
/* polynome de Legendre de degre IMPAIR. */
|
|
|
|
|
|
/************************************************************************
|
|
*****/
|
|
/* Parameter adjustments */
|
|
--rtlegd;
|
|
|
|
/* Function Body */
|
|
ibb = AdvApp2Var_SysBase::mnfndeb_();
|
|
if (ibb >= 3) {
|
|
AdvApp2Var_SysBase::mgenmsg_("MMRTPTT", 7L);
|
|
}
|
|
if (*ndglgd < 2) {
|
|
goto L9999;
|
|
}
|
|
|
|
nsur2 = *ndglgd / 2;
|
|
nmod2 = *ndglgd % 2;
|
|
|
|
ilong = nsur2 << 3;
|
|
ideb = nsur2 * (nsur2 - 1) / 2 + 1;
|
|
AdvApp2Var_SysBase::mcrfill_((integer *)&ilong,
|
|
(char *)&mlgdrtl_.rootab[ideb + nmod2 * 465 - 1],
|
|
(char *)&rtlegd[1]);
|
|
|
|
/* ----------------------------- The end --------------------------------
|
|
*/
|
|
|
|
L9999:
|
|
if (ibb >= 3) {
|
|
AdvApp2Var_SysBase::mgsomsg_("MMRTPTT", 7L);
|
|
}
|
|
return 0;
|
|
} /* mmrtptt_ */
|
|
|
|
//=======================================================================
|
|
//function : AdvApp2Var_MathBase::mmsrre2_
|
|
//purpose :
|
|
//=======================================================================
|
|
int AdvApp2Var_MathBase::mmsrre2_(doublereal *tparam,
|
|
integer *nbrval,
|
|
doublereal *tablev,
|
|
doublereal *epsil,
|
|
integer *numint,
|
|
integer *itypen,
|
|
integer *iercod)
|
|
{
|
|
/* System generated locals */
|
|
doublereal d__1;
|
|
|
|
/* Local variables */
|
|
static integer ideb, ifin, imil, ibb;
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* -------- */
|
|
|
|
/* Recherche l'intervalle correspondant a une valeur donnee dans */
|
|
/* une suite croissante de reels double precision. */
|
|
|
|
/* MOTS CLES : */
|
|
/* --------- */
|
|
/* TOUS,MATH_ACCES::TABLEAU&,POINT&,CORRESPONDANCE,&RANG */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* ------------------ */
|
|
|
|
/* TPARAM : Valeur a tester. */
|
|
/* NBRVAL : Taille de TABLEV */
|
|
/* TABLEV : Tableau de reels. */
|
|
/* EPSIL : Epsilon de precision */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* ------------------- */
|
|
|
|
/* NUMINT : Numero de l'intervalle (entre 1 et NBRVAL-1). */
|
|
/* ITYPEN : = 0 TPARAM est a l'interieur de l'intervalle NUMINT */
|
|
/* = 1 : TPARAM correspond a la borne inferieure de */
|
|
/* l'intervalle fourni. */
|
|
/* = 2 : TPARAM correspond a la borne superieure de */
|
|
/* l'intervalle fourni. */
|
|
|
|
/* IERCOD : Code d'erreur */
|
|
/* = 0 : OK */
|
|
/* = 1 : TABLEV ne contient pas assez d' elements. */
|
|
/* = 2 : TPARAM hors des bornes de TABLEV. */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ---------------- */
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* ------------------- */
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* --------------------------------- */
|
|
/* Il y a NBRVAL valeurs dans TABLEV soit NBRVAL-1 intervalles. */
|
|
/* On fait une recherche de l' intervalle contenant TPARAM par */
|
|
/* dichotomie. Complexite de l' algorithme : Log(n)/Log(2).(RBD). */
|
|
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* ---------------------------- */
|
|
/* 13-07-93 : MCL ; Version originale (a partir de MSRREI) */
|
|
/* > */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
|
|
/* Initialisations */
|
|
|
|
/* Parameter adjustments */
|
|
--tablev;
|
|
|
|
/* Function Body */
|
|
ibb = AdvApp2Var_SysBase::mnfndeb_();
|
|
if (ibb >= 6) {
|
|
AdvApp2Var_SysBase::mgenmsg_("MMSRRE2", 7L);
|
|
}
|
|
|
|
*iercod = 0;
|
|
*numint = 0;
|
|
*itypen = 0;
|
|
ideb = 1;
|
|
ifin = *nbrval;
|
|
|
|
/* TABLEV doit contenir au moins deux valeurs */
|
|
|
|
if (*nbrval < 2) {
|
|
*iercod = 1;
|
|
goto L9999;
|
|
}
|
|
|
|
/* TPARAM doit etre entre les bornes extremes de TABLEV. */
|
|
|
|
if (*tparam < tablev[1] || *tparam > tablev[*nbrval]) {
|
|
*iercod = 2;
|
|
goto L9999;
|
|
}
|
|
|
|
/* ----------------------- RECHERCHE DE L'INTERVALLE --------------------
|
|
*/
|
|
|
|
L1000:
|
|
|
|
/* Test de fin de boucle (on a trouve). */
|
|
|
|
if (ideb + 1 == ifin) {
|
|
*numint = ideb;
|
|
goto L2000;
|
|
}
|
|
|
|
/* Recherche par dichotomie sur les valeurs croissantes de TABLEV. */
|
|
|
|
imil = (ideb + ifin) / 2;
|
|
if (*tparam >= tablev[ideb] && *tparam <= tablev[imil]) {
|
|
ifin = imil;
|
|
} else {
|
|
ideb = imil;
|
|
}
|
|
|
|
goto L1000;
|
|
|
|
/* -------------- TEST POUR VOIR SI TPARAM N'EST PAS UNE VALEUR ---------
|
|
*/
|
|
/* ------------------------ DE TABLEV A EPSIL PRES ----------------------
|
|
*/
|
|
|
|
L2000:
|
|
if ((d__1 = *tparam - tablev[ideb], abs(d__1)) < *epsil) {
|
|
*itypen = 1;
|
|
goto L9999;
|
|
}
|
|
if ((d__1 = *tparam - tablev[ifin], abs(d__1)) < *epsil) {
|
|
*itypen = 2;
|
|
goto L9999;
|
|
}
|
|
|
|
/* --------------------------- THE END ----------------------------------
|
|
*/
|
|
|
|
L9999:
|
|
if (*iercod > 0) {
|
|
AdvApp2Var_SysBase::maermsg_("MMSRRE2", iercod, 7L);
|
|
}
|
|
if (ibb >= 6) {
|
|
AdvApp2Var_SysBase::mgsomsg_("MMSRRE2", 7L);
|
|
}
|
|
return 0 ;
|
|
} /* mmsrre2_ */
|
|
|
|
//=======================================================================
|
|
//function : mmtmave_
|
|
//purpose :
|
|
//=======================================================================
|
|
int mmtmave_(integer *nligne,
|
|
integer *ncolon,
|
|
integer *gposit,
|
|
integer *,//gnstoc,
|
|
doublereal *gmatri,
|
|
doublereal *vecin,
|
|
doublereal *vecout,
|
|
integer *iercod)
|
|
|
|
{
|
|
/* System generated locals */
|
|
integer i__1, i__2;
|
|
|
|
/* Local variables */
|
|
static logical ldbg;
|
|
static integer imin, imax, i__, j, k;
|
|
static doublereal somme;
|
|
static integer aux;
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* t */
|
|
/* EFFECUE LE PRODUIT G V */
|
|
/* OU LA MATRICE G EST SOUS FORME DE PROFIL */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* RESERVE, PRODUIT, MATRICE, PROFIL, VECTEUR */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* -------------------- */
|
|
/* NLIGNE : NOMBRE DE LIGNE DE LA MATRICE */
|
|
/* NCOLON : NOMBRE DE COLONNE DE LA MATRICE */
|
|
/* GPOSIT: TABLE DE POSITIONNEMENT DES TERMES DE STOCKAGE */
|
|
/* GPOSIT(1,I) CONTIENT LE NOMBRE DE TERMES-1 SUR LA LIGNE
|
|
*/
|
|
/* I DANS LE PROFIL DE LA MATRICE */
|
|
/* GPOSIT(2,I) CONTIENT L'INDICE DE STOCKAGE DU TERME DIAGONA
|
|
L*/
|
|
/* DE LA LIGNE I */
|
|
/* GPOSIT(3,I) CONTIENT L'INDICE COLONE DU PREMIER TERME DU
|
|
*/
|
|
/* PROFIL DE LA LIGNE I */
|
|
/* GNSTOC : NOMBRE DE TERME DANS LE PROFIL DE GMATRI */
|
|
/* GMATRI : MATRICE DES CONTRAINTES SOUS FORME DE PROFIL */
|
|
/* VECIN : VECTEUR D'ENTRE */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* --------------------- */
|
|
/* VECOUT :VECTEUR PRODUIT */
|
|
/* IERCOD : CODE D'ERREUR */
|
|
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ------------------ */
|
|
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* --------------------- */
|
|
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* ------------------------------ */
|
|
/* 21-08-95 : KHN; ECRITURE VERSION ORIGINALE. */
|
|
/* > */
|
|
/* ***********************************************************************
|
|
*/
|
|
/* DECLARATIONS */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* INITIALISATIONS */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* Parameter adjustments */
|
|
--vecin;
|
|
gposit -= 4;
|
|
--vecout;
|
|
--gmatri;
|
|
|
|
/* Function Body */
|
|
ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 2;
|
|
if (ldbg) {
|
|
AdvApp2Var_SysBase::mgenmsg_("MMTMAVE", 7L);
|
|
}
|
|
*iercod = 0;
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* TRAITEMENT */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
|
|
|
|
i__1 = *ncolon;
|
|
for (i__ = 1; i__ <= i__1; ++i__) {
|
|
somme = 0.;
|
|
i__2 = *nligne;
|
|
for (j = 1; j <= i__2; ++j) {
|
|
imin = gposit[j * 3 + 3];
|
|
imax = gposit[j * 3 + 1] + gposit[j * 3 + 3] - 1;
|
|
aux = gposit[j * 3 + 2] - gposit[j * 3 + 1] - imin + 1;
|
|
if (imin <= i__ && i__ <= imax) {
|
|
k = i__ + aux;
|
|
somme += gmatri[k] * vecin[j];
|
|
}
|
|
}
|
|
vecout[i__] = somme;
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
goto L9999;
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* TRAITEMENT DES ERREURS */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* RETOUR PROGRAMME APPELANT */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
L9999:
|
|
|
|
/* ___ DESALLOCATION, ... */
|
|
|
|
AdvApp2Var_SysBase::maermsg_("MMTMAVE", iercod, 7L);
|
|
if (ldbg) {
|
|
AdvApp2Var_SysBase::mgsomsg_("MMTMAVE", 7L);
|
|
}
|
|
return 0 ;
|
|
} /* mmtmave_ */
|
|
|
|
//=======================================================================
|
|
//function : mmtrpj0_
|
|
//purpose :
|
|
//=======================================================================
|
|
int mmtrpj0_(integer *ncofmx,
|
|
integer *ndimen,
|
|
integer *ncoeff,
|
|
doublereal *epsi3d,
|
|
doublereal *crvlgd,
|
|
doublereal *ycvmax,
|
|
doublereal *epstrc,
|
|
integer *ncfnew)
|
|
|
|
{
|
|
/* System generated locals */
|
|
integer crvlgd_dim1, crvlgd_offset, i__1, i__2;
|
|
doublereal d__1;
|
|
|
|
/* Local variables */
|
|
static integer ncut, i__;
|
|
static doublereal bidon, error;
|
|
static integer nd;
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* Baisse le degre d' une courbe definie sur (-1,1) au sens de */
|
|
/* Legendre a une precision donnee. */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* LEGENDRE,POLYGONE,TRONCONNAGE,COURBE,LISSAGE. */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* ------------------ */
|
|
/* NCOFMX : Nbre maxi de coeff. de la courbe (dimensionnement). */
|
|
/* NDIMEN : Dimension de l' espace. */
|
|
/* NCOEFF : Le degre +1 du polynome. */
|
|
/* EPSI3D : La precision demandee pour l' approximation. */
|
|
/* CRVLGD : La courbe dont on veut baisser le degre. */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* ------------------- */
|
|
/* EPSTRC : La precision de l' approximation. */
|
|
/* NCFNEW : Le degre +1 du polynome resultat. */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ---------------- */
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* ----------------------- */
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* -------------------------------- */
|
|
/* 17-05-1991 : RBD ; Si le degre n'est pas baisse, l'erreur est nulle */
|
|
/* 12-12-1989 : RBD ; Creation. */
|
|
/* > */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
|
|
/* ------- Degre minimum pouvant etre atteint : Arret a 1 (RBD) ---------
|
|
*/
|
|
|
|
/* Parameter adjustments */
|
|
--ycvmax;
|
|
crvlgd_dim1 = *ncofmx;
|
|
crvlgd_offset = crvlgd_dim1 + 1;
|
|
crvlgd -= crvlgd_offset;
|
|
|
|
/* Function Body */
|
|
*ncfnew = 1;
|
|
/* ------------------- Init pour calcul d' erreur -----------------------
|
|
*/
|
|
i__1 = *ndimen;
|
|
for (i__ = 1; i__ <= i__1; ++i__) {
|
|
ycvmax[i__] = 0.;
|
|
/* L100: */
|
|
}
|
|
*epstrc = 0.;
|
|
error = 0.;
|
|
|
|
/* Coupure des coefficients. */
|
|
|
|
ncut = 2;
|
|
/* ------ Boucle sur la serie de Legendre :NCOEFF --> 2 (RBD) -----------
|
|
*/
|
|
i__1 = ncut;
|
|
for (i__ = *ncoeff; i__ >= i__1; --i__) {
|
|
/* Facteur de renormalisation. */
|
|
bidon = ((i__ - 1) * 2. + 1.) / 2.;
|
|
bidon = sqrt(bidon);
|
|
i__2 = *ndimen;
|
|
for (nd = 1; nd <= i__2; ++nd) {
|
|
ycvmax[nd] += (d__1 = crvlgd[i__ + nd * crvlgd_dim1], abs(d__1)) *
|
|
bidon;
|
|
/* L310: */
|
|
}
|
|
/* On arrete de couper si la norme devient trop grande. */
|
|
error = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
|
|
if (error > *epsi3d) {
|
|
*ncfnew = i__;
|
|
goto L9999;
|
|
}
|
|
|
|
/* --- Erreur max cumulee lorsque le I-eme coeff est ote. */
|
|
|
|
*epstrc = error;
|
|
|
|
/* L300: */
|
|
}
|
|
|
|
/* --------------------------------- Fin --------------------------------
|
|
*/
|
|
|
|
L9999:
|
|
return 0;
|
|
} /* mmtrpj0_ */
|
|
|
|
//=======================================================================
|
|
//function : mmtrpj2_
|
|
//purpose :
|
|
//=======================================================================
|
|
int mmtrpj2_(integer *ncofmx,
|
|
integer *ndimen,
|
|
integer *ncoeff,
|
|
doublereal *epsi3d,
|
|
doublereal *crvlgd,
|
|
doublereal *ycvmax,
|
|
doublereal *epstrc,
|
|
integer *ncfnew)
|
|
|
|
{
|
|
/* Initialized data */
|
|
|
|
static doublereal xmaxj[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 };
|
|
|
|
/* System generated locals */
|
|
integer crvlgd_dim1, crvlgd_offset, i__1, i__2;
|
|
doublereal d__1;
|
|
|
|
/* Local variables */
|
|
static integer ncut, i__;
|
|
static doublereal bidon, error;
|
|
static integer ia, nd;
|
|
static doublereal bid, eps1;
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* Baisse le degre d' une courbe definie sur (-1,1) au sens de */
|
|
/* Legendre a une precision donnee. */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* LEGENDRE,POLYGONE,TRONCONNAGE,COURBE,LISSAGE. */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* ------------------ */
|
|
/* NCOFMX : Nbre maxi de coeff. de la courbe (dimensionnement). */
|
|
/* NDIMEN : Dimension de l' espace. */
|
|
/* NCOEFF : Le degre +1 du polynome. */
|
|
/* EPSI3D : La precision demandee pour l' approximation. */
|
|
/* CRVLGD : La courbe dont on veut baisser le degre. */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* ------------------- */
|
|
/* YCVMAX : Tableau auxiliaire (erreur max sur chaque dimension).
|
|
*/
|
|
/* EPSTRC : La precision de l' approximation. */
|
|
/* NCFNEW : Le degre +1 du polynome resultat. */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ---------------- */
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* ----------------------- */
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* -------------------------------- */
|
|
/* 17-05-1991 : RBD ; Si le degre n'est pas baisse, l'erreur est nulle */
|
|
/* 15-01-1991 : RBD ; Correction coupure des coeff. nuls du polynome */
|
|
/* d' interpolation. */
|
|
/* 12-12-1989 : RBD ; Creation. */
|
|
|
|
/* > */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
|
|
/* Parameter adjustments */
|
|
--ycvmax;
|
|
crvlgd_dim1 = *ncofmx;
|
|
crvlgd_offset = crvlgd_dim1 + 1;
|
|
crvlgd -= crvlgd_offset;
|
|
|
|
/* Function Body */
|
|
|
|
|
|
|
|
/* Degre minimum pouvant etre atteint : Arret a IA (RBD). -------------
|
|
*/
|
|
ia = 2;
|
|
*ncfnew = ia;
|
|
/* Init pour calcul d' erreur. */
|
|
i__1 = *ndimen;
|
|
for (i__ = 1; i__ <= i__1; ++i__) {
|
|
ycvmax[i__] = 0.;
|
|
/* L100: */
|
|
}
|
|
*epstrc = 0.;
|
|
error = 0.;
|
|
|
|
/* Coupure des coefficients. */
|
|
|
|
ncut = ia + 1;
|
|
/* ------ Boucle sur la serie de Jacobi :NCOEFF --> IA+1 (RBD) ----------
|
|
*/
|
|
i__1 = ncut;
|
|
for (i__ = *ncoeff; i__ >= i__1; --i__) {
|
|
/* Facteur de renormalisation. */
|
|
bidon = xmaxj[i__ - ncut];
|
|
i__2 = *ndimen;
|
|
for (nd = 1; nd <= i__2; ++nd) {
|
|
ycvmax[nd] += (d__1 = crvlgd[i__ + nd * crvlgd_dim1], abs(d__1)) *
|
|
bidon;
|
|
/* L310: */
|
|
}
|
|
/* On arrete de couper si la norme devient trop grande. */
|
|
error = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
|
|
if (error > *epsi3d) {
|
|
*ncfnew = i__;
|
|
goto L400;
|
|
}
|
|
|
|
/* --- Erreur max cumulee lorsque le I-eme coeff est ote. */
|
|
|
|
*epstrc = error;
|
|
|
|
/* L300: */
|
|
}
|
|
|
|
/* ------- Coupure des coeff. nuls du pol. d' interpolation (RBD) -------
|
|
*/
|
|
|
|
L400:
|
|
if (*ncfnew == ia) {
|
|
AdvApp2Var_MathBase::mmeps1_(&eps1);
|
|
for (i__ = ia; i__ >= 2; --i__) {
|
|
bid = 0.;
|
|
i__1 = *ndimen;
|
|
for (nd = 1; nd <= i__1; ++nd) {
|
|
bid += (d__1 = crvlgd[i__ + nd * crvlgd_dim1], abs(d__1));
|
|
/* L600: */
|
|
}
|
|
if (bid > eps1) {
|
|
*ncfnew = i__;
|
|
goto L9999;
|
|
}
|
|
/* L500: */
|
|
}
|
|
/* --- Si tous les coeff peuvent etre otes, c'est un point. */
|
|
*ncfnew = 1;
|
|
}
|
|
|
|
/* --------------------------------- Fin --------------------------------
|
|
*/
|
|
|
|
L9999:
|
|
return 0;
|
|
} /* mmtrpj2_ */
|
|
|
|
//=======================================================================
|
|
//function : mmtrpj4_
|
|
//purpose :
|
|
//=======================================================================
|
|
int mmtrpj4_(integer *ncofmx,
|
|
integer *ndimen,
|
|
integer *ncoeff,
|
|
doublereal *epsi3d,
|
|
doublereal *crvlgd,
|
|
doublereal *ycvmax,
|
|
doublereal *epstrc,
|
|
integer *ncfnew)
|
|
{
|
|
/* Initialized data */
|
|
|
|
static doublereal xmaxj[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 };
|
|
|
|
/* System generated locals */
|
|
integer crvlgd_dim1, crvlgd_offset, i__1, i__2;
|
|
doublereal d__1;
|
|
|
|
/* Local variables */
|
|
static integer ncut, i__;
|
|
static doublereal bidon, error;
|
|
static integer ia, nd;
|
|
static doublereal bid, eps1;
|
|
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* Baisse le degre d' une courbe definie sur (-1,1) au sens de */
|
|
/* Legendre a une precision donnee. */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* LEGENDRE,POLYGONE,TRONCONNAGE,COURBE,LISSAGE. */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* ------------------ */
|
|
/* NCOFMX : Nbre maxi de coeff. de la courbe (dimensionnement). */
|
|
/* NDIMEN : Dimension de l' espace. */
|
|
/* NCOEFF : Le degre +1 du polynome. */
|
|
/* EPSI3D : La precision demandee pour l' approximation. */
|
|
/* CRVLGD : La courbe dont on veut baisser le degre. */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* ------------------- */
|
|
/* YCVMAX : Tableau auxiliaire (erreur max sur chaque dimension).
|
|
*/
|
|
/* EPSTRC : La precision de l' approximation. */
|
|
/* NCFNEW : Le degre +1 du polynome resultat. */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ---------------- */
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* ----------------------- */
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* -------------------------------- */
|
|
/* 17-05-1991 : RBD ; Si le degre n'est pas baisse, l'erreur est nulle */
|
|
/* 15-01-1991 : RBD ; Correction coupure des coeff. nuls du polynome */
|
|
/* d' interpolation. */
|
|
/* 12-12-1989 : RBD ; Creation. */
|
|
|
|
/* > */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
|
|
/* Parameter adjustments */
|
|
--ycvmax;
|
|
crvlgd_dim1 = *ncofmx;
|
|
crvlgd_offset = crvlgd_dim1 + 1;
|
|
crvlgd -= crvlgd_offset;
|
|
|
|
/* Function Body */
|
|
|
|
|
|
|
|
/* Degre minimum pouvant etre atteint : Arret a IA (RBD). -------------
|
|
*/
|
|
ia = 4;
|
|
*ncfnew = ia;
|
|
/* Init pour calcul d' erreur. */
|
|
i__1 = *ndimen;
|
|
for (i__ = 1; i__ <= i__1; ++i__) {
|
|
ycvmax[i__] = 0.;
|
|
/* L100: */
|
|
}
|
|
*epstrc = 0.;
|
|
error = 0.;
|
|
|
|
/* Coupure des coefficients. */
|
|
|
|
ncut = ia + 1;
|
|
/* ------ Boucle sur la serie de Jacobi :NCOEFF --> IA+1 (RBD) ----------
|
|
*/
|
|
i__1 = ncut;
|
|
for (i__ = *ncoeff; i__ >= i__1; --i__) {
|
|
/* Facteur de renormalisation. */
|
|
bidon = xmaxj[i__ - ncut];
|
|
i__2 = *ndimen;
|
|
for (nd = 1; nd <= i__2; ++nd) {
|
|
ycvmax[nd] += (d__1 = crvlgd[i__ + nd * crvlgd_dim1], abs(d__1)) *
|
|
bidon;
|
|
/* L310: */
|
|
}
|
|
/* On arrete de couper si la norme devient trop grande. */
|
|
error = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
|
|
if (error > *epsi3d) {
|
|
*ncfnew = i__;
|
|
goto L400;
|
|
}
|
|
|
|
/* --- Erreur max cumulee lorsque le I-eme coeff est ote. */
|
|
|
|
*epstrc = error;
|
|
|
|
/* L300: */
|
|
}
|
|
|
|
/* ------- Coupure des coeff. nuls du pol. d' interpolation (RBD) -------
|
|
*/
|
|
|
|
L400:
|
|
if (*ncfnew == ia) {
|
|
AdvApp2Var_MathBase::mmeps1_(&eps1);
|
|
for (i__ = ia; i__ >= 2; --i__) {
|
|
bid = 0.;
|
|
i__1 = *ndimen;
|
|
for (nd = 1; nd <= i__1; ++nd) {
|
|
bid += (d__1 = crvlgd[i__ + nd * crvlgd_dim1], abs(d__1));
|
|
/* L600: */
|
|
}
|
|
if (bid > eps1) {
|
|
*ncfnew = i__;
|
|
goto L9999;
|
|
}
|
|
/* L500: */
|
|
}
|
|
/* --- Si tous les coeff peuvent etre otes, c'est un point. */
|
|
*ncfnew = 1;
|
|
}
|
|
|
|
/* --------------------------------- Fin --------------------------------
|
|
*/
|
|
|
|
L9999:
|
|
return 0;
|
|
} /* mmtrpj4_ */
|
|
|
|
//=======================================================================
|
|
//function : mmtrpj6_
|
|
//purpose :
|
|
//=======================================================================
|
|
int mmtrpj6_(integer *ncofmx,
|
|
integer *ndimen,
|
|
integer *ncoeff,
|
|
doublereal *epsi3d,
|
|
doublereal *crvlgd,
|
|
doublereal *ycvmax,
|
|
doublereal *epstrc,
|
|
integer *ncfnew)
|
|
|
|
{
|
|
/* Initialized data */
|
|
|
|
static doublereal xmaxj[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 crvlgd_dim1, crvlgd_offset, i__1, i__2;
|
|
doublereal d__1;
|
|
|
|
/* Local variables */
|
|
static integer ncut, i__;
|
|
static doublereal bidon, error;
|
|
static integer ia, nd;
|
|
static doublereal bid, eps1;
|
|
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* Baisse le degre d' une courbe definie sur (-1,1) au sens de */
|
|
/* Legendre a une precision donnee. */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* LEGENDRE,POLYGONE,TRONCONNAGE,COURBE,LISSAGE. */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* ------------------ */
|
|
/* NCOFMX : Nbre maxi de coeff. de la courbe (dimensionnement). */
|
|
/* NDIMEN : Dimension de l' espace. */
|
|
/* NCOEFF : Le degre +1 du polynome. */
|
|
/* EPSI3D : La precision demandee pour l' approximation. */
|
|
/* CRVLGD : La courbe dont on veut baisser le degre. */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* ------------------- */
|
|
/* YCVMAX : Tableau auxiliaire (erreur max sur chaque dimension).
|
|
*/
|
|
/* EPSTRC : La precision de l' approximation. */
|
|
/* NCFNEW : Le degre +1 du polynome resultat. */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ---------------- */
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* ----------------------- */
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* -------------------------------- */
|
|
/* 17-05-1991 : RBD ; Si le degre n'est pas baisse, l'erreur est nulle */
|
|
/* 15-01-1991 : RBD ; Correction coupure des coeff. nuls du polynome */
|
|
/* d' interpolation. */
|
|
/* 12-12-1989 : RBD ; Creation. */
|
|
|
|
/* > */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
|
|
/* Parameter adjustments */
|
|
--ycvmax;
|
|
crvlgd_dim1 = *ncofmx;
|
|
crvlgd_offset = crvlgd_dim1 + 1;
|
|
crvlgd -= crvlgd_offset;
|
|
|
|
/* Function Body */
|
|
|
|
|
|
|
|
/* Degre minimum pouvant etre atteint : Arret a IA (RBD). -------------
|
|
*/
|
|
ia = 6;
|
|
*ncfnew = ia;
|
|
/* Init pour calcul d' erreur. */
|
|
i__1 = *ndimen;
|
|
for (i__ = 1; i__ <= i__1; ++i__) {
|
|
ycvmax[i__] = 0.;
|
|
/* L100: */
|
|
}
|
|
*epstrc = 0.;
|
|
error = 0.;
|
|
|
|
/* Coupure des coefficients. */
|
|
|
|
ncut = ia + 1;
|
|
/* ------ Boucle sur la serie de Jacobi :NCOEFF --> IA+1 (RBD) ----------
|
|
*/
|
|
i__1 = ncut;
|
|
for (i__ = *ncoeff; i__ >= i__1; --i__) {
|
|
/* Facteur de renormalisation. */
|
|
bidon = xmaxj[i__ - ncut];
|
|
i__2 = *ndimen;
|
|
for (nd = 1; nd <= i__2; ++nd) {
|
|
ycvmax[nd] += (d__1 = crvlgd[i__ + nd * crvlgd_dim1], abs(d__1)) *
|
|
bidon;
|
|
/* L310: */
|
|
}
|
|
/* On arrete de couper si la norme devient trop grande. */
|
|
error = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
|
|
if (error > *epsi3d) {
|
|
*ncfnew = i__;
|
|
goto L400;
|
|
}
|
|
|
|
/* --- Erreur max cumulee lorsque le I-eme coeff est ote. */
|
|
|
|
*epstrc = error;
|
|
|
|
/* L300: */
|
|
}
|
|
|
|
/* ------- Coupure des coeff. nuls du pol. d' interpolation (RBD) -------
|
|
*/
|
|
|
|
L400:
|
|
if (*ncfnew == ia) {
|
|
AdvApp2Var_MathBase::mmeps1_(&eps1);
|
|
for (i__ = ia; i__ >= 2; --i__) {
|
|
bid = 0.;
|
|
i__1 = *ndimen;
|
|
for (nd = 1; nd <= i__1; ++nd) {
|
|
bid += (d__1 = crvlgd[i__ + nd * crvlgd_dim1], abs(d__1));
|
|
/* L600: */
|
|
}
|
|
if (bid > eps1) {
|
|
*ncfnew = i__;
|
|
goto L9999;
|
|
}
|
|
/* L500: */
|
|
}
|
|
/* --- Si tous les coeff peuvent etre otes, c'est un point. */
|
|
*ncfnew = 1;
|
|
}
|
|
|
|
/* --------------------------------- Fin --------------------------------
|
|
*/
|
|
|
|
L9999:
|
|
return 0;
|
|
} /* mmtrpj6_ */
|
|
|
|
//=======================================================================
|
|
//function : AdvApp2Var_MathBase::mmtrpjj_
|
|
//purpose :
|
|
//=======================================================================
|
|
int AdvApp2Var_MathBase::mmtrpjj_(integer *ncofmx,
|
|
integer *ndimen,
|
|
integer *ncoeff,
|
|
doublereal *epsi3d,
|
|
integer *iordre,
|
|
doublereal *crvlgd,
|
|
doublereal *ycvmax,
|
|
doublereal *errmax,
|
|
integer *ncfnew)
|
|
{
|
|
/* System generated locals */
|
|
integer crvlgd_dim1, crvlgd_offset;
|
|
|
|
/* Local variables */
|
|
static integer ia;
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* Baisse le degre d' une courbe definie sur (-1,1) au sens de */
|
|
/* Legendre a une precision donnee. */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* LEGENDRE,POLYGONE,TRONCONNAGE,COURBE,LISSAGE. */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* ------------------ */
|
|
/* NCOFMX : Nbre maxi de coeff. de la courbe (dimensionnement). */
|
|
/* NDIMEN : Dimension de l' espace. */
|
|
/* NCOEFF : Le degre +1 du polynome. */
|
|
/* EPSI3D : La precision demandee pour l' approximation. */
|
|
/* IORDRE : Ordre de continuite aux extremites. */
|
|
/* CRVLGD : La courbe dont on veut baisser le degre. */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* ------------------- */
|
|
/* ERRMAX : La precision de l' approximation. */
|
|
/* NCFNEW : Le degre +1 du polynome resultat. */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ---------------- */
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* ----------------------- */
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* -------------------------------- */
|
|
/* 06-08-91 : RBD; Declaration de dimension de YCVMAX. */
|
|
/* 18-01-90 : RBD; Creation. */
|
|
|
|
/* > */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
|
|
/* Parameter adjustments */
|
|
--ycvmax;
|
|
crvlgd_dim1 = *ncofmx;
|
|
crvlgd_offset = crvlgd_dim1 + 1;
|
|
crvlgd -= crvlgd_offset;
|
|
|
|
/* Function Body */
|
|
ia = (*iordre + 1) << 1;
|
|
|
|
if (ia == 0) {
|
|
mmtrpj0_(ncofmx, ndimen, ncoeff, epsi3d, &crvlgd[crvlgd_offset], &
|
|
ycvmax[1], errmax, ncfnew);
|
|
} else if (ia == 2) {
|
|
mmtrpj2_(ncofmx, ndimen, ncoeff, epsi3d, &crvlgd[crvlgd_offset], &
|
|
ycvmax[1], errmax, ncfnew);
|
|
} else if (ia == 4) {
|
|
mmtrpj4_(ncofmx, ndimen, ncoeff, epsi3d, &crvlgd[crvlgd_offset], &
|
|
ycvmax[1], errmax, ncfnew);
|
|
} else {
|
|
mmtrpj6_(ncofmx, ndimen, ncoeff, epsi3d, &crvlgd[crvlgd_offset], &
|
|
ycvmax[1], errmax, ncfnew);
|
|
}
|
|
|
|
/* ------------------------ Fin -----------------------------------------
|
|
*/
|
|
|
|
return 0;
|
|
} /* mmtrpjj_ */
|
|
|
|
//=======================================================================
|
|
//function : AdvApp2Var_MathBase::mmunivt_
|
|
//purpose :
|
|
//=======================================================================
|
|
int AdvApp2Var_MathBase::mmunivt_(integer *ndimen,
|
|
doublereal *vector,
|
|
doublereal *vecnrm,
|
|
doublereal *epsiln,
|
|
integer *iercod)
|
|
{
|
|
|
|
static doublereal c_b2 = 10.;
|
|
|
|
/* System generated locals */
|
|
integer i__1;
|
|
doublereal d__1;
|
|
|
|
/* Local variables */
|
|
static integer nchif, iunit, izero;
|
|
static doublereal vnorm;
|
|
static integer ii;
|
|
static doublereal bid;
|
|
static doublereal eps0;
|
|
|
|
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* CALCUL DU VECTEUR NORME A PARTIR D'UN VECTEUR QUELCONQUE */
|
|
/* AVEC UNE PRECISION DONNEE PAR L' UTILISATEUR. */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* TOUS, MATH_ACCES :: */
|
|
/* VECTEUR&, NORMALISATION, &VECTEUR */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* ------------------ */
|
|
/* NDIMEN : DIMENSION DE L'ESPACE */
|
|
/* VECTOR : VECTEUR A NORMER */
|
|
/* EPSILN : L' EPSILON EN DESSOUS DUQUEL ON CONSIDERE QUE LA */
|
|
/* NORME DU VECTEUR EST NULLE. SI EPSILN<=0, UNE VALEUR */
|
|
/* PAR DEFAUT EST IMPOSEE (10.D-17 SUR VAX). */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* ------------------- */
|
|
/* VECNRM : VECTEUR NORME */
|
|
/* IERCOD 101 : LE VECTEUR EST NUL A EPSILN PRES. */
|
|
/* 0 : OK. */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ---------------- */
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* ----------------------- */
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
/* VECTOR et VECNRM peuvent etre identiques. */
|
|
|
|
/* On calcule la norme du vecteur et on divise chaque composante par
|
|
*/
|
|
/* cette norme. Apres cela on verifie si toutes les composantes du */
|
|
/* vecteur sauf une vaut 0 a la precision machine pres. Dans */
|
|
/* ce cas on met les composantes quasi-nulles a 0.D0. */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* -------------------------------- */
|
|
/* 14-12-90 : RBD; Correction cas ou une seule composante est */
|
|
/* significative, appel a MAOVSR8 pour la precision */
|
|
/* machine. */
|
|
/* 11-01-89 : RBD; Correction precision par defaut. */
|
|
/* 05-10-88 : RBD; Creation d' apres UNITVT. */
|
|
/* 23-01-85 : DH ; Creation version originale de UNITVT. */
|
|
/* > */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
|
|
/* Parameter adjustments */
|
|
--vecnrm;
|
|
--vector;
|
|
|
|
/* Function Body */
|
|
*iercod = 0;
|
|
|
|
/* -------- Precision par defaut : le zero machine 10.D-17 sur Vax ------
|
|
*/
|
|
|
|
AdvApp2Var_SysBase::maovsr8_(&nchif);
|
|
if (*epsiln <= 0.) {
|
|
i__1 = -nchif;
|
|
eps0 = AdvApp2Var_MathBase::pow__di(&c_b2, &i__1);
|
|
} else {
|
|
eps0 = *epsiln;
|
|
}
|
|
|
|
/* ----------------------------- Calcul de la norme ---------------------
|
|
*/
|
|
|
|
vnorm = AdvApp2Var_MathBase::mzsnorm_(ndimen, &vector[1]);
|
|
if (vnorm <= eps0) {
|
|
AdvApp2Var_SysBase::mvriraz_((integer *)ndimen, (char *)&vecnrm[1]);
|
|
*iercod = 101;
|
|
goto L9999;
|
|
}
|
|
|
|
/* ---------------------- Calcul du vecteur norme -----------------------
|
|
*/
|
|
|
|
izero = 0;
|
|
i__1 = (-nchif - 1) / 2;
|
|
eps0 = AdvApp2Var_MathBase::pow__di(&c_b2, &i__1);
|
|
i__1 = *ndimen;
|
|
for (ii = 1; ii <= i__1; ++ii) {
|
|
vecnrm[ii] = vector[ii] / vnorm;
|
|
if ((d__1 = vecnrm[ii], abs(d__1)) <= eps0) {
|
|
++izero;
|
|
} else {
|
|
iunit = ii;
|
|
}
|
|
/* L20: */
|
|
}
|
|
|
|
/* ------ Cas ou toutes les coordonnees sauf une sont presque nulles ----
|
|
*/
|
|
/* ------------- alors l' une des coordonnees vaut 1.D0 ou -1.D0 --------
|
|
*/
|
|
|
|
if (izero == *ndimen - 1) {
|
|
bid = vecnrm[iunit];
|
|
i__1 = *ndimen;
|
|
for (ii = 1; ii <= i__1; ++ii) {
|
|
vecnrm[ii] = 0.;
|
|
/* L30: */
|
|
}
|
|
if (bid > 0.) {
|
|
vecnrm[iunit] = 1.;
|
|
} else {
|
|
vecnrm[iunit] = -1.;
|
|
}
|
|
}
|
|
|
|
/* -------------------------------- The end -----------------------------
|
|
*/
|
|
|
|
L9999:
|
|
return 0;
|
|
} /* mmunivt_ */
|
|
|
|
//=======================================================================
|
|
//function : AdvApp2Var_MathBase::mmveps3_
|
|
//purpose :
|
|
//=======================================================================
|
|
int AdvApp2Var_MathBase::mmveps3_(doublereal *eps03)
|
|
{
|
|
/* Initialized data */
|
|
|
|
static char nomprg[8+1] = "MMEPS1 ";
|
|
|
|
static integer ibb;
|
|
|
|
|
|
|
|
/************************************************************************
|
|
*******/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* Extraction du EPS1 du COMMON MPRCSN. */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* MPRCSN,PRECISON,EPS3. */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* ------------------ */
|
|
/* Humm. */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* ------------------- */
|
|
/* EPS3 : Le zero spatial du denominateur (10**-9) */
|
|
/* EPS3 devrait valoir 10**-15 */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ---------------- */
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* ----------------------- */
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* -------------------------------- */
|
|
/* 08-01-90 : ACS ; MPRCSN REMPLACE PAR INCLUDE */
|
|
/* 21-01-1988: JJM ; Creation. */
|
|
|
|
/* > */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* DONNE LES TOLERANCES DE NULLITE DANS STRIM */
|
|
/* AINSI QUE LES BORNES DES PROCESSUS ITERATIFS */
|
|
|
|
/* CONTEXTE GENERAL, MODIFIABLE PAR L'UTILISATEUR */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* PARAMETRE , TOLERANCE */
|
|
|
|
/* DEMSCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
/* INITIALISATION : PROFIL , **VIA MPRFTX** A L' ENTREE DANS STRI
|
|
M*/
|
|
|
|
/* CHARGEMENT DES VALEURS PAR DEFAUT DU PROFIL DANS MPRFTX A L'ENTRE
|
|
E*/
|
|
/* DANS STRIM. ELLES SONT CONSERVEES DANS DES VARIABLES LOCALES */
|
|
/* DE MPRFTX */
|
|
|
|
/* REMISE DES VALEURS PAR DEFAUT : MDFINT */
|
|
/* MODIFICATION INTERACTIVE PAR L'UTILISATEUR : MDBINT */
|
|
|
|
/* FONCTION D'ACCES : MMEPS1 ... EPS1 */
|
|
/* MEPSPB ... EPS3,EPS4 */
|
|
/* MEPSLN ... EPS2, NITERM , NITERR */
|
|
/* MEPSNR ... EPS2 , NITERM */
|
|
/* MITERR ... NITERR */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* ------------------------------ */
|
|
/* 01-02-90 : NAK ; ENTETE */
|
|
/* > */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* NITERM : NB D'ITERATIONS MAXIMAL */
|
|
/* NITERR : NB D'ITERATIONS RAPIDES */
|
|
/* EPS1 : TOLERANCE DE DISTANCE 3D NULLE */
|
|
/* EPS2 : TOLERANCE DE DISTANCE PARAMETRIQUE NULLE */
|
|
/* EPS3 : TOLERANCE POUR EVITER LES DIVISIONS PAR 0.. */
|
|
/* EPS4 : TOLERANCE ANGULAIRE */
|
|
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
ibb = AdvApp2Var_SysBase::mnfndeb_();
|
|
if (ibb >= 5) {
|
|
AdvApp2Var_SysBase::mgenmsg_(nomprg, 6L);
|
|
}
|
|
|
|
*eps03 = mmprcsn_.eps3;
|
|
|
|
return 0;
|
|
} /* mmveps3_ */
|
|
|
|
//=======================================================================
|
|
//function : AdvApp2Var_MathBase::mmvncol_
|
|
//purpose :
|
|
//=======================================================================
|
|
int AdvApp2Var_MathBase::mmvncol_(integer *ndimen,
|
|
doublereal *vecin,
|
|
doublereal *vecout,
|
|
integer *iercod)
|
|
|
|
{
|
|
/* System generated locals */
|
|
integer i__1;
|
|
|
|
/* Local variables */
|
|
static logical ldbg;
|
|
static integer d__;
|
|
static doublereal vaux1[3], vaux2[3];
|
|
static logical colin;
|
|
static doublereal valaux;
|
|
static integer aux;
|
|
static logical nul;
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* CALCUL UN VECTEUR NON COLINEAIRE A UN VECTEUR DONNEE */
|
|
/* NON NUL */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* PUBLIC, VECTEUR, LIBRE */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* -------------------- */
|
|
/* ndimen :dimension de l'espace */
|
|
/* vecin :vecteur entre */
|
|
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* --------------------- */
|
|
|
|
/* vecout : vecteur non colineaire a vecin */
|
|
/* COMMONS UTILISES : */
|
|
/* ------------------ */
|
|
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* --------------------- */
|
|
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* ------------------------------ */
|
|
/* 25-08-95 : KHN; ECRITURE VERSION ORIGINALE. */
|
|
/* > */
|
|
/* ***********************************************************************
|
|
*/
|
|
/* DECLARATIONS */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* INITIALISATIONS */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* Parameter adjustments */
|
|
--vecout;
|
|
--vecin;
|
|
|
|
/* Function Body */
|
|
ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 2;
|
|
if (ldbg) {
|
|
AdvApp2Var_SysBase::mgenmsg_("MMVNCOL", 7L);
|
|
}
|
|
*iercod = 0;
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* TRAITEMENT */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
if (*ndimen <= 1 || *ndimen > 3) {
|
|
goto L9101;
|
|
}
|
|
nul = FALSE_;
|
|
d__ = 1;
|
|
aux = 0;
|
|
while(d__ <= *ndimen) {
|
|
if (vecin[d__] == 0.) {
|
|
++aux;
|
|
}
|
|
++d__;
|
|
}
|
|
if (aux == *ndimen) {
|
|
goto L9101;
|
|
}
|
|
|
|
|
|
for (d__ = 1; d__ <= 3; ++d__) {
|
|
vaux1[d__ - 1] = 0.;
|
|
}
|
|
i__1 = *ndimen;
|
|
for (d__ = 1; d__ <= i__1; ++d__) {
|
|
vaux1[d__ - 1] = vecin[d__];
|
|
vaux2[d__ - 1] = vecin[d__];
|
|
}
|
|
colin = TRUE_;
|
|
d__ = 0;
|
|
while(colin) {
|
|
++d__;
|
|
if (d__ > 3) {
|
|
goto L9101;
|
|
}
|
|
vaux2[d__ - 1] += 1;
|
|
valaux = vaux1[1] * vaux2[2] - vaux1[2] * vaux2[1];
|
|
if (valaux == 0.) {
|
|
valaux = vaux1[2] * vaux2[0] - vaux1[0] * vaux2[2];
|
|
if (valaux == 0.) {
|
|
valaux = vaux1[0] * vaux2[1] - vaux1[1] * vaux2[0];
|
|
if (valaux != 0.) {
|
|
colin = FALSE_;
|
|
}
|
|
} else {
|
|
colin = FALSE_;
|
|
}
|
|
} else {
|
|
colin = FALSE_;
|
|
}
|
|
}
|
|
if (colin) {
|
|
goto L9101;
|
|
}
|
|
i__1 = *ndimen;
|
|
for (d__ = 1; d__ <= i__1; ++d__) {
|
|
vecout[d__] = vaux2[d__ - 1];
|
|
}
|
|
|
|
goto L9999;
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* TRAITEMENT DES ERREURS */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
|
|
L9101:
|
|
*iercod = 1;
|
|
goto L9999;
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* RETOUR PROGRAMME APPELANT */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
L9999:
|
|
|
|
|
|
AdvApp2Var_SysBase::maermsg_("MMVNCOL", iercod, 7L);
|
|
if (ldbg) {
|
|
AdvApp2Var_SysBase::mgsomsg_("MMVNCOL", 7L);
|
|
}
|
|
return 0 ;
|
|
} /* mmvncol_ */
|
|
|
|
//=======================================================================
|
|
//function : AdvApp2Var_MathBase::mmwprcs_
|
|
//purpose :
|
|
//=======================================================================
|
|
void AdvApp2Var_MathBase::mmwprcs_(doublereal *epsil1,
|
|
doublereal *epsil2,
|
|
doublereal *epsil3,
|
|
doublereal *epsil4,
|
|
integer *niter1,
|
|
integer *niter2)
|
|
|
|
{
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* ACCES EN ECRITURE POUR LE COMMON MPRCSN */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* ECRITURE */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* -------------------- */
|
|
/* EPSIL1 : TOLERANCE DE DISTANCE 3D NULLE */
|
|
/* EPSIL2 : TOLERANCE DE DISTANCE PARAMETRIQUE NULLE */
|
|
/* EPSIL3 : TOLERANCE POUR EVITER LES DIVISIONS PAR 0.. */
|
|
/* EPSIL4 : TOLERANCE ANGULAIRE */
|
|
/* NITER1 : NB D'ITERATIONS MAXIMAL */
|
|
/* NITER2 : NB D'ITERATIONS RAPIDES */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* --------------------- */
|
|
/* NEANT */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ------------------ */
|
|
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* --------------------- */
|
|
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* ------------------------------ */
|
|
/* 13-05-96 : JPI; ECRITURE VERSION ORIGINALE. */
|
|
/* > */
|
|
/* ***********************************************************************
|
|
*/
|
|
/* DECLARATIONS */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* INITIALISATIONS */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* TRAITEMENT */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* DONNE LES TOLERANCES DE NULLITE DANS STRIM */
|
|
/* AINSI QUE LES BORNES DES PROCESSUS ITERATIFS */
|
|
|
|
/* CONTEXTE GENERAL, MODIFIABLE PAR L'UTILISATEUR */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* PARAMETRE , TOLERANCE */
|
|
|
|
/* DEMSCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
/* INITIALISATION : PROFIL , **VIA MPRFTX** A L' ENTREE DANS STRI
|
|
M*/
|
|
|
|
/* CHARGEMENT DES VALEURS PAR DEFAUT DU PROFIL DANS MPRFTX A L'ENTRE
|
|
E*/
|
|
/* DANS STRIM. ELLES SONT CONSERVEES DANS DES VARIABLES LOCALES */
|
|
/* DE MPRFTX */
|
|
|
|
/* REMISE DES VALEURS PAR DEFAUT : MDFINT */
|
|
/* MODIFICATION INTERACTIVE PAR L'UTILISATEUR : MDBINT */
|
|
|
|
/* FONCTION D'ACCES : MMEPS1 ... EPS1 */
|
|
/* MEPSPB ... EPS3,EPS4 */
|
|
/* MEPSLN ... EPS2, NITERM , NITERR */
|
|
/* MEPSNR ... EPS2 , NITERM */
|
|
/* MITERR ... NITERR */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* ------------------------------ */
|
|
/* 01-02-90 : NAK ; ENTETE */
|
|
/* > */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* NITERM : NB D'ITERATIONS MAXIMAL */
|
|
/* NITERR : NB D'ITERATIONS RAPIDES */
|
|
/* EPS1 : TOLERANCE DE DISTANCE 3D NULLE */
|
|
/* EPS2 : TOLERANCE DE DISTANCE PARAMETRIQUE NULLE */
|
|
/* EPS3 : TOLERANCE POUR EVITER LES DIVISIONS PAR 0.. */
|
|
/* EPS4 : TOLERANCE ANGULAIRE */
|
|
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
mmprcsn_.eps1 = *epsil1;
|
|
mmprcsn_.eps2 = *epsil2;
|
|
mmprcsn_.eps3 = *epsil3;
|
|
mmprcsn_.eps4 = *epsil4;
|
|
mmprcsn_.niterm = *niter1;
|
|
mmprcsn_.niterr = *niter2;
|
|
return ;
|
|
} /* mmwprcs_ */
|
|
|
|
|
|
//=======================================================================
|
|
//function : AdvApp2Var_MathBase::pow__di
|
|
//purpose :
|
|
//=======================================================================
|
|
doublereal AdvApp2Var_MathBase::pow__di (doublereal *x,
|
|
integer *n)
|
|
{
|
|
|
|
register integer ii ;
|
|
doublereal result ;
|
|
integer absolute ;
|
|
result = 1.0e0 ;
|
|
if ( *n > 0 ) {absolute = *n;}
|
|
else {absolute = -*n;}
|
|
/* System generated locals */
|
|
for(ii = 0 ; ii < absolute ; ii++) {
|
|
result *= *x ;
|
|
}
|
|
if (*n < 0) {
|
|
result = 1.0e0 / result ;
|
|
}
|
|
return result ;
|
|
}
|
|
|
|
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* Calcul la fonction puissance entiere pas forcement de la maniere
|
|
la plus efficace ;
|
|
*/
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* PUISSANCE */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* ------------------ */
|
|
/* X : argument de X**N */
|
|
/* N : puissance */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* ------------------- */
|
|
/* retourne X**N */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ---------------- */
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* ----------------------- */
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* -------------------------------- */
|
|
/* 16-10-95 : XAB ; Creation */
|
|
/* > */
|
|
/* ***********************************************************************/
|
|
|
|
//=======================================================================
|
|
//function : pow__ii
|
|
//purpose :
|
|
//=======================================================================
|
|
integer pow__ii(integer *x,
|
|
integer *n)
|
|
|
|
{
|
|
register integer ii ;
|
|
integer result ;
|
|
integer absolute ;
|
|
result = 1 ;
|
|
if ( *n > 0 ) {absolute = *n;}
|
|
else {absolute = -*n;}
|
|
/* System generated locals */
|
|
for(ii = 0 ; ii < absolute ; ii++) {
|
|
result *= *x ;
|
|
}
|
|
if (*n < 0) {
|
|
result = 1 / result ;
|
|
}
|
|
return result ;
|
|
}
|
|
|
|
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* Calcul la fonction puissance entiere pas forcement de la maniere
|
|
la plus efficace ;
|
|
*/
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* PUISSANCE */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* ------------------ */
|
|
/* X : argument de X**N */
|
|
/* N : puissance */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* ------------------- */
|
|
/* retourne X**N */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ---------------- */
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* ----------------------- */
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* -------------------------------- */
|
|
/* 16-10-95 : XAB ; Creation */
|
|
/* > */
|
|
/* ***********************************************************************/
|
|
|
|
//=======================================================================
|
|
//function : AdvApp2Var_MathBase::msc_
|
|
//purpose :
|
|
//=======================================================================
|
|
doublereal AdvApp2Var_MathBase::msc_(integer *ndimen,
|
|
doublereal *vecte1,
|
|
doublereal *vecte2)
|
|
|
|
{
|
|
/* System generated locals */
|
|
integer i__1;
|
|
doublereal ret_val;
|
|
|
|
/* Local variables */
|
|
static integer i__;
|
|
static doublereal x;
|
|
|
|
|
|
|
|
/************************************************************************
|
|
*******/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* Calcul du produit scalaire de 2 vecteurs dans l' espace */
|
|
/* de dimension NDIMEN. */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* PRODUIT MSCALAIRE. */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* ------------------ */
|
|
/* NDIMEN : Dimension de l' espace. */
|
|
/* VECTE1,VECTE2: Les vecteurs. */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* ------------------- */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ---------------- */
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* ----------------------- */
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* -------------------------------- */
|
|
/* 18-07-1988: RBD ; Changement de nom des arguments pour plus */
|
|
/* de lisibilite. */
|
|
/* 16-01-1987: Verification implicite NDIMEN >0 JJM. */
|
|
|
|
/* > */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
|
|
/* PRODUIT MSCALAIRE */
|
|
/* Parameter adjustments */
|
|
--vecte2;
|
|
--vecte1;
|
|
|
|
/* Function Body */
|
|
x = 0.;
|
|
|
|
i__1 = *ndimen;
|
|
for (i__ = 1; i__ <= i__1; ++i__) {
|
|
x += vecte1[i__] * vecte2[i__];
|
|
/* L100: */
|
|
}
|
|
ret_val = x;
|
|
|
|
/* ----------------------------------- THE END --------------------------
|
|
*/
|
|
|
|
return ret_val;
|
|
} /* msc_ */
|
|
|
|
//=======================================================================
|
|
//function : mvcvin2_
|
|
//purpose :
|
|
//=======================================================================
|
|
int mvcvin2_(integer *ncoeff,
|
|
doublereal *crvold,
|
|
doublereal *crvnew,
|
|
integer *iercod)
|
|
|
|
{
|
|
/* System generated locals */
|
|
integer i__1, i__2;
|
|
|
|
/* Local variables */
|
|
static integer m1jm1, ncfm1, j, k;
|
|
static doublereal bid;
|
|
static doublereal cij1, cij2;
|
|
|
|
|
|
|
|
/************************************************************************
|
|
*******/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* INVERSION DU PARAMETRAGE SUR UNE CRBE 2D. */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* COURBE,2D,INVERSION,PARAMETRE. */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* ------------------ */
|
|
/* NCOEFF : NBRE DE COEFF DE LA COURBE. */
|
|
/* CRVOLD : LA COURBE D'ORIGINE */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* ------------------- */
|
|
/* CRVNEW : LA CRBE RESULTAT APRES CHANGT DE T EN 1-T */
|
|
/* IERCOD : 0 OK, */
|
|
/* 10 NBRE DE COEFF NUL OU TROP GRAND. */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ---------------- */
|
|
/* MCCNP */
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* ---------------------- */
|
|
/* Neant */
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
/* L' APPEL SUIVANT EST TOUT A FAIT LEGAL : */
|
|
/* CALL MVCVIN2(NCOEFF,CURVE,CURVE,IERCOD), LE TABLEAU CURVE */
|
|
/* DEVENANT UN ARGUMENT D' ENTREE ET DE SORTIE (RBD). */
|
|
/* A CAUSE DE MCCNP, LE NBRE DE COEFF DE LA COURBE EST LIMITE A */
|
|
/* NDGCNP+1 = 61. */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* -------------------------------- */
|
|
/* 24-09-93 : MPS ; PRISE EN COMPTE NCOEFF=1 */
|
|
/* IMPLICIT NONE */
|
|
/* 09-01-90 : TE ; COMMON MCCNP -> MCNCNP.INC & INDICES DES CNP */
|
|
/* 05-08-88 : RBD ; ACTIVATION DE L' IERCOD */
|
|
/* 27-06-88 : RBD ; VERIFICATION QUE LES IDENTIFICATEURS CRVNEW ET */
|
|
/* CRVOLD PEUVENT DESIGNER LA MEME COURBE. */
|
|
/* 14-04-88 : NAK ; VERSION ORIGINALE */
|
|
/* > */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* Sert a fournir les coefficients du binome (triangle de Pascal). */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* Coeff du binome de 0 a 60. read only . init par block data */
|
|
|
|
/* DEMSCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
/* Les coefficients du binome forment une matrice triangulaire. */
|
|
/* On complete cette matrice dans le tableau CNP par sa transposee. */
|
|
/* On a donc: CNP(I,J) = CNP(J,I) pour I et J = 0, ..., 60. */
|
|
|
|
/* L'initialisation est faite a partir du block-data MMLLL09.RES, */
|
|
/* cree par le programme MQINICNP.FOR (voir l'equipe (AC) ). */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* ------------------------------ */
|
|
/* 03-07-90 : RBD; Ajout commentaires (nom du block-data). */
|
|
/* 19-06-90 : RBD; Le commun MMCMCNP remplace MCCNP qui est obsolete.
|
|
*/
|
|
/* 08-01-90 : TE ; CREATION */
|
|
/* > */
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* Parameter adjustments */
|
|
crvnew -= 3;
|
|
crvold -= 3;
|
|
|
|
/* Function Body */
|
|
if (*ncoeff < 1 || *ncoeff - 1 > 60) {
|
|
*iercod = 10;
|
|
goto L9999;
|
|
}
|
|
*iercod = 0;
|
|
|
|
|
|
/* TERME CONSTANT DE LA NOUVELLE COURBE */
|
|
|
|
cij1 = crvold[3];
|
|
cij2 = crvold[4];
|
|
i__1 = *ncoeff;
|
|
for (k = 2; k <= i__1; ++k) {
|
|
cij1 += crvold[(k << 1) + 1];
|
|
cij2 += crvold[(k << 1) + 2];
|
|
}
|
|
crvnew[3] = cij1;
|
|
crvnew[4] = cij2;
|
|
if (*ncoeff == 1) {
|
|
goto L9999;
|
|
}
|
|
|
|
/* PUISSANCES INTERMEDIAIRES DU PARAMETRE */
|
|
|
|
ncfm1 = *ncoeff - 1;
|
|
m1jm1 = 1;
|
|
i__1 = ncfm1;
|
|
for (j = 2; j <= i__1; ++j) {
|
|
m1jm1 = -m1jm1;
|
|
cij1 = crvold[(j << 1) + 1];
|
|
cij2 = crvold[(j << 1) + 2];
|
|
i__2 = *ncoeff;
|
|
for (k = j + 1; k <= i__2; ++k) {
|
|
bid = mmcmcnp_.cnp[k - 1 + (j - 1) * 61];
|
|
cij1 += crvold[(k << 1) + 1] * bid;
|
|
cij2 += crvold[(k << 1) + 2] * bid;
|
|
}
|
|
crvnew[(j << 1) + 1] = cij1 * m1jm1;
|
|
crvnew[(j << 1) + 2] = cij2 * m1jm1;
|
|
}
|
|
|
|
/* TERME DE PLUS HAUT DEGRE */
|
|
|
|
crvnew[(*ncoeff << 1) + 1] = -crvold[(*ncoeff << 1) + 1] * m1jm1;
|
|
crvnew[(*ncoeff << 1) + 2] = -crvold[(*ncoeff << 1) + 2] * m1jm1;
|
|
|
|
L9999:
|
|
if (*iercod > 0) {
|
|
AdvApp2Var_SysBase::maermsg_("MVCVIN2", iercod, 7L);
|
|
}
|
|
return 0 ;
|
|
} /* mvcvin2_ */
|
|
|
|
//=======================================================================
|
|
//function : mvcvinv_
|
|
//purpose :
|
|
//=======================================================================
|
|
int mvcvinv_(integer *ncoeff,
|
|
doublereal *crvold,
|
|
doublereal *crvnew,
|
|
integer *iercod)
|
|
|
|
{
|
|
/* System generated locals */
|
|
integer i__1, i__2;
|
|
|
|
/* Local variables */
|
|
static integer m1jm1, ncfm1, j, k;
|
|
static doublereal bid;
|
|
//extern /* Subroutine */ int maermsg_();
|
|
static doublereal cij1, cij2, cij3;
|
|
|
|
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* INVERSION DU PARAMETRAGE SUR UNE CRBE 3D (I.E. INVERSION DU */
|
|
/* SENS DE PARCOURS). */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* COURBE,INVERSION,PARAMETRE. */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* ------------------ */
|
|
/* NCOEFF : NBRE DE COEFF DE LA COURBE. */
|
|
/* CRVOLD : lA COURBE D'ORIGINE */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* ------------------- */
|
|
/* CRVNEW : LA CRBE RESULTAT APRES CHANGT DE T EN 1-T */
|
|
/* IERCOD : 0 OK, */
|
|
/* 10 NBRE DE COEFF NUL OU TROP GRAND. */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ---------------- */
|
|
/* MCCNP */
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* ---------------------- */
|
|
/* Neant */
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
/* L' APPEL SUIVANT EST TOUT A FAIT LEGAL : */
|
|
/* CALL MVCVINV(NCOEFF,CURVE,CURVE,IERCOD), LE TABLEAU CURVE */
|
|
/* DEVENANT UN ARGUMENT D' ENTREE ET DE SORTIE (RBD). */
|
|
/* LE NOMBRE DE COEFF DE LA COURBE EST LIMITE A NDGCNP+1 = 61 */
|
|
/* A CAUSE DE L' UTILISATION DU COMMUN MCCNP. */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* -------------------------------- */
|
|
/* 10-05-90 : JG ; NCOEFF=1 n'etait pas gere */
|
|
/* 09-01-90 : TE ; COMMON MCCNP -> MMCMCNP.INC & INDICES DES CNP */
|
|
/* 05-08-88 : RBD ; ACTIVATION DE L' IERCOD */
|
|
/* 27-06-88 : RBD ; VERIFICATION QUE LES IDENTIFICATEURS CRVNEW ET */
|
|
/* CRVOLD PEUVENT DESIGNER LA MEME COURBE. */
|
|
/* 02-03-87 : NAK ; BRSTN --> MCCNP */
|
|
/* 01-10-86 : NAK ; PRISE EN COMPTE LES ISOS DE LA FORME 1-T */
|
|
/* > */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* Sert a fournir les coefficients du binome (triangle de Pascal). */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* Coeff du binome de 0 a 60. read only . init par block data */
|
|
|
|
/* DEMSCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
/* Les coefficients du binome forment une matrice triangulaire. */
|
|
/* On complete cette matrice dans le tableau CNP par sa transposee. */
|
|
/* On a donc: CNP(I,J) = CNP(J,I) pour I et J = 0, ..., 60. */
|
|
|
|
/* L'initialisation est faite a partir du block-data MMLLL09.RES, */
|
|
/* cree par le programme MQINICNP.FOR (voir l'equipe (AC) ). */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* ------------------------------ */
|
|
/* 03-07-90 : RBD; Ajout commentaires (nom du block-data). */
|
|
/* 19-06-90 : RBD; Le commun MMCMCNP remplace MCCNP qui est obsolete.
|
|
*/
|
|
/* 08-01-90 : TE ; CREATION */
|
|
/* > */
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* Parameter adjustments */
|
|
crvnew -= 4;
|
|
crvold -= 4;
|
|
|
|
/* Function Body */
|
|
if (*ncoeff < 1 || *ncoeff - 1 > 60) {
|
|
*iercod = 10;
|
|
goto L9999;
|
|
}
|
|
*iercod = 0;
|
|
|
|
/* TERME CONSTANT DE LA NOUVELLE COURBE */
|
|
|
|
cij1 = crvold[4];
|
|
cij2 = crvold[5];
|
|
cij3 = crvold[6];
|
|
i__1 = *ncoeff;
|
|
for (k = 2; k <= i__1; ++k) {
|
|
cij1 += crvold[k * 3 + 1];
|
|
cij2 += crvold[k * 3 + 2];
|
|
cij3 += crvold[k * 3 + 3];
|
|
/* L30: */
|
|
}
|
|
crvnew[4] = cij1;
|
|
crvnew[5] = cij2;
|
|
crvnew[6] = cij3;
|
|
if (*ncoeff == 1) {
|
|
goto L9999;
|
|
}
|
|
|
|
/* PUISSANCES INTERMEDIAIRES DU PARAMETRE */
|
|
|
|
ncfm1 = *ncoeff - 1;
|
|
m1jm1 = 1;
|
|
i__1 = ncfm1;
|
|
for (j = 2; j <= i__1; ++j) {
|
|
m1jm1 = -m1jm1;
|
|
cij1 = crvold[j * 3 + 1];
|
|
cij2 = crvold[j * 3 + 2];
|
|
cij3 = crvold[j * 3 + 3];
|
|
i__2 = *ncoeff;
|
|
for (k = j + 1; k <= i__2; ++k) {
|
|
bid = mmcmcnp_.cnp[k - 1 + (j - 1) * 61];
|
|
cij1 += crvold[k * 3 + 1] * bid;
|
|
cij2 += crvold[k * 3 + 2] * bid;
|
|
cij3 += crvold[k * 3 + 3] * bid;
|
|
/* L40: */
|
|
}
|
|
crvnew[j * 3 + 1] = cij1 * m1jm1;
|
|
crvnew[j * 3 + 2] = cij2 * m1jm1;
|
|
crvnew[j * 3 + 3] = cij3 * m1jm1;
|
|
/* L50: */
|
|
}
|
|
|
|
/* TERME DE PLUS HAUT DEGRE */
|
|
|
|
crvnew[*ncoeff * 3 + 1] = -crvold[*ncoeff * 3 + 1] * m1jm1;
|
|
crvnew[*ncoeff * 3 + 2] = -crvold[*ncoeff * 3 + 2] * m1jm1;
|
|
crvnew[*ncoeff * 3 + 3] = -crvold[*ncoeff * 3 + 3] * m1jm1;
|
|
|
|
L9999:
|
|
AdvApp2Var_SysBase::maermsg_("MVCVINV", iercod, 7L);
|
|
return 0;
|
|
} /* mvcvinv_ */
|
|
|
|
//=======================================================================
|
|
//function : mvgaus0_
|
|
//purpose :
|
|
//=======================================================================
|
|
int mvgaus0_(integer *kindic,
|
|
doublereal *urootl,
|
|
doublereal *hiltab,
|
|
integer *nbrval,
|
|
integer *iercod)
|
|
|
|
{
|
|
/* System generated locals */
|
|
integer i__1;
|
|
|
|
/* Local variables */
|
|
static doublereal tamp[40];
|
|
static integer ndegl, kg, ii;
|
|
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* -------- */
|
|
/* Chargement pour un degre donne des racines du polynome de LEGENDRE */
|
|
/* DEFINI SUR [-1,1] et des poids des formules de quadrature de Gauss */
|
|
/* (bases sur les interpolants de LAGRANGE correspondants). */
|
|
/* La symetrie par rapport a 0 entre [-1,0] et [0,1] est utilisee. */
|
|
|
|
/* MOTS CLES : */
|
|
/* --------- */
|
|
/* . VOLUMIQUE,LEGENDRE,LAGRANGE,GAUSS */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* ------------------ */
|
|
|
|
/* KINDIC : Prends les valeurs de 1 a 10 en fonction du degre du */
|
|
/* polynome a utiliser. */
|
|
/* Le degre du polynome est egal a 4 k, c'est a dire 4, 8, */
|
|
/* 12, 16, 20, 24, 28, 32, 36 et 40. */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* ------------------- */
|
|
|
|
/* UROOTL : Racines du polynome de LEGENDRE dans le domaine [1,0] */
|
|
/* ordonnees en decroissant. Pour le domaine [-1,0], il faut */
|
|
/* prendre les valeurs opposees. */
|
|
/* HILTAB : Interpolant de LAGRANGE associes aux racines. Pour les */
|
|
/* racines opposes, les interpolants sont egaux. */
|
|
/* NBRVAL : Nombre de coefficients. C'est egal a la moitie du degre en */
|
|
/* raison de la symetrie (i.e. 2*KINDIC). */
|
|
|
|
/* IERCOD : Code d'erreur : */
|
|
/* < 0 ==> Attention - Warning */
|
|
/* =-1 ==> Valeur de KINDIC erronne. NBRVAL est force a 20 */
|
|
/* (ordre 40) */
|
|
/* = 0 ==> Tout est OK */
|
|
|
|
/* COMMON UTILISES : */
|
|
/* ---------------- */
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* ------------------- */
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* --------------------------------- */
|
|
/* Si KINDIC n'est pas bon (i.e < 1 ou > 10), le degre est pris */
|
|
/* a 40 directement (ATTENTION au debordement - pour l'eviter, */
|
|
/* prevoir UROOTL et HILTAB dimensionne a 20 au moins). */
|
|
|
|
/* La valeur des coefficients a ete calculee en quadruple precision
|
|
*/
|
|
/* par JJM avec l'aide de GD. */
|
|
/* La verification des racines a ete faite par GD. */
|
|
|
|
/* Voir les explications detaillees sur le listing */
|
|
|
|
/* $ HISTORIQUES DES MODIFICATIONS : */
|
|
/* ----------------------------- */
|
|
/* . 23-03-90 : RBD; Les valeurs sont extraites du commun MLGDRTL
|
|
*/
|
|
/* via MMEXTHI et MMEXTRL. */
|
|
/* . 28-06-88 : JP; DECLARATIONS REAL *8 MAL PLACEES */
|
|
/* . 08-08-87 : GD; Version originale */
|
|
/* > */
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
|
|
/* ------------------------------------ */
|
|
/* ****** Test de validite de KINDIC ** */
|
|
/* ------------------------------------ */
|
|
|
|
/* Parameter adjustments */
|
|
--hiltab;
|
|
--urootl;
|
|
|
|
/* Function Body */
|
|
*iercod = 0;
|
|
kg = *kindic;
|
|
if (kg < 1 || kg > 10) {
|
|
kg = 10;
|
|
*iercod = -1;
|
|
}
|
|
*nbrval = kg << 1;
|
|
ndegl = *nbrval << 1;
|
|
|
|
/* ----------------------------------------------------------------------
|
|
*/
|
|
/* ****** Chargement des NBRVAL racines positives en fonction du degre **
|
|
*/
|
|
/* ----------------------------------------------------------------------
|
|
*/
|
|
/* ATTENTION : Le signe moins (-) dans la boucle est intentionnel. */
|
|
|
|
mmextrl_(&ndegl, tamp);
|
|
i__1 = *nbrval;
|
|
for (ii = 1; ii <= i__1; ++ii) {
|
|
urootl[ii] = -tamp[ii - 1];
|
|
/* L100: */
|
|
}
|
|
|
|
/* ------------------------------------------------------------------- */
|
|
/* ****** Chargement des NBRVAL poids de Gauss en fonction du degre ** */
|
|
/* ------------------------------------------------------------------- */
|
|
|
|
mmexthi_(&ndegl, tamp);
|
|
i__1 = *nbrval;
|
|
for (ii = 1; ii <= i__1; ++ii) {
|
|
hiltab[ii] = tamp[ii - 1];
|
|
/* L200: */
|
|
}
|
|
|
|
/* ------------------------------- */
|
|
/* ****** Fin du sous-programme ** */
|
|
/* ------------------------------- */
|
|
|
|
return 0;
|
|
} /* mvgaus0_ */
|
|
|
|
//=======================================================================
|
|
//function : mvpscr2_
|
|
//purpose :
|
|
//=======================================================================
|
|
int mvpscr2_(integer *ncoeff,
|
|
doublereal *curve2,
|
|
doublereal *tparam,
|
|
doublereal *pntcrb)
|
|
{
|
|
/* System generated locals */
|
|
integer i__1;
|
|
|
|
/* Local variables */
|
|
static integer ndeg, kk;
|
|
static doublereal xxx, yyy;
|
|
|
|
|
|
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* POSITIONNEMENT SUR UNE COURBE (NCF,2) DANS L'ESPACE DE DIMENSION 2. */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* TOUS,MATH_ACCES:: COURBE&,POSITIONNEMENT,&POINT. */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* ------------------ */
|
|
/* NCOEFF : NOMBRE DE COEFFICIENTS DE LA COURBE */
|
|
/* CURVE2 : EQUATION DE LA COURBE 2D */
|
|
/* TPARAM : VALEUR DU PARAMETRE AU POINT CONSIDERE */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* ------------------- */
|
|
/* PNTCRB : COORDONNEES DU POINT CORRESPONDANT AU PARAMETRE */
|
|
/* TPARAM SUR LA COURBE 2D CURVE2. */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ---------------- */
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* ---------------------- */
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
/* MSCHEMA DE HORNER. */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* -------------------------------- */
|
|
/* 16-05-90 : RBD; Optimisation sur une idee de GD. */
|
|
/* 12-09-86 : NAK;ECRITURE VERSION ORIGINALE */
|
|
/* > */
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
|
|
/* -------- INITIALISATIONS ET TRAITEMENT DES CAS PARTICULIERS ----------
|
|
*/
|
|
|
|
/* ---> Cas ou NCOEFF > 1 (cas STANDARD). */
|
|
/* Parameter adjustments */
|
|
--pntcrb;
|
|
curve2 -= 3;
|
|
|
|
/* Function Body */
|
|
if (*ncoeff >= 2) {
|
|
goto L1000;
|
|
}
|
|
/* ---> Cas ou NCOEFF <= 1. */
|
|
if (*ncoeff <= 0) {
|
|
pntcrb[1] = 0.;
|
|
pntcrb[2] = 0.;
|
|
goto L9999;
|
|
} else if (*ncoeff == 1) {
|
|
pntcrb[1] = curve2[3];
|
|
pntcrb[2] = curve2[4];
|
|
goto L9999;
|
|
}
|
|
|
|
/* -------------------- MSCHEMA DE HORNER (CAS PARTICULIER) --------------
|
|
*/
|
|
|
|
L1000:
|
|
|
|
if (*tparam == 1.) {
|
|
xxx = 0.;
|
|
yyy = 0.;
|
|
i__1 = *ncoeff;
|
|
for (kk = 1; kk <= i__1; ++kk) {
|
|
xxx += curve2[(kk << 1) + 1];
|
|
yyy += curve2[(kk << 1) + 2];
|
|
/* L100: */
|
|
}
|
|
goto L5000;
|
|
} else if (*tparam == 0.) {
|
|
pntcrb[1] = curve2[3];
|
|
pntcrb[2] = curve2[4];
|
|
goto L9999;
|
|
}
|
|
|
|
/* ---------------------------- MSCHEMA DE HORNER ------------------------
|
|
*/
|
|
/* ---> Ici TPARAM est different de 1.D0 et de 0.D0. */
|
|
|
|
ndeg = *ncoeff - 1;
|
|
xxx = curve2[(*ncoeff << 1) + 1];
|
|
yyy = curve2[(*ncoeff << 1) + 2];
|
|
for (kk = ndeg; kk >= 1; --kk) {
|
|
xxx = xxx * *tparam + curve2[(kk << 1) + 1];
|
|
yyy = yyy * *tparam + curve2[(kk << 1) + 2];
|
|
/* L200: */
|
|
}
|
|
goto L5000;
|
|
|
|
/* ------------------------ RECUPERATION DU POINT CALCULE ---------------
|
|
*/
|
|
|
|
L5000:
|
|
pntcrb[1] = xxx;
|
|
pntcrb[2] = yyy;
|
|
|
|
/* ------------------------------ THE END -------------------------------
|
|
*/
|
|
|
|
L9999:
|
|
return 0;
|
|
} /* mvpscr2_ */
|
|
|
|
//=======================================================================
|
|
//function : mvpscr3_
|
|
//purpose :
|
|
//=======================================================================
|
|
int mvpscr3_(integer *ncoeff,
|
|
doublereal *curve3,
|
|
doublereal *tparam,
|
|
doublereal *pntcrb)
|
|
|
|
{
|
|
/* System generated locals */
|
|
integer i__1;
|
|
|
|
/* Local variables */
|
|
static integer ndeg, kk;
|
|
static doublereal xxx, yyy, zzz;
|
|
|
|
|
|
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* POSITIONNEMENT SUR UNE COURBE (3,NCF) DANS L'ESPACE DE DIMENSION 3. */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* TOUS, MATH_ACCES:: COURBE&,POSITIONNEMENT,&POINT. */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* ------------------ */
|
|
/* NCOEFF : NOMBRE DE COEFFICIENTS DE LA COURBE */
|
|
/* CURVE3 : EQUATION DE LA COURBE 3D */
|
|
/* TPARAM : VALEUR DU PARAMETRE AU POINT CONSIDERE */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* ------------------- */
|
|
/* PNTCRB : COORDONNEES DU POINT CORRESPONDANT AU PARAMETRE */
|
|
/* TPARAM SUR LA COURBE 3D CURVE3. */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ---------------- */
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* ---------------------- */
|
|
/* Neant */
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
/* MSCHEMA DE HORNER. */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* -------------------------------- */
|
|
/* 16-05-90 : RBD; Optimisation sur une idee de GD (gain=10 pour */
|
|
/* cent pour des courbes de degre 10 a 20). */
|
|
/* 12-09-86 : NAK; ECRITURE VERSION ORIGINALE */
|
|
/* > */
|
|
/* **********************************************************************
|
|
*/
|
|
/* DECLARATIONS */
|
|
/* **********************************************************************
|
|
*/
|
|
|
|
|
|
/* -------- INITIALISATIONS ET TRAITEMENT DES CAS PARTICULIERS ----------
|
|
*/
|
|
|
|
/* ---> Cas ou NCOEFF > 1 (cas STANDARD). */
|
|
/* Parameter adjustments */
|
|
--pntcrb;
|
|
curve3 -= 4;
|
|
|
|
/* Function Body */
|
|
if (*ncoeff >= 2) {
|
|
goto L1000;
|
|
}
|
|
/* ---> Cas ou NCOEFF <= 1. */
|
|
if (*ncoeff <= 0) {
|
|
pntcrb[1] = 0.;
|
|
pntcrb[2] = 0.;
|
|
pntcrb[3] = 0.;
|
|
goto L9999;
|
|
} else if (*ncoeff == 1) {
|
|
pntcrb[1] = curve3[4];
|
|
pntcrb[2] = curve3[5];
|
|
pntcrb[3] = curve3[6];
|
|
goto L9999;
|
|
}
|
|
|
|
/* -------------------- MSCHEMA DE HORNER (CAS PARTICULIER) --------------
|
|
*/
|
|
|
|
L1000:
|
|
|
|
if (*tparam == 1.) {
|
|
xxx = 0.;
|
|
yyy = 0.;
|
|
zzz = 0.;
|
|
i__1 = *ncoeff;
|
|
for (kk = 1; kk <= i__1; ++kk) {
|
|
xxx += curve3[kk * 3 + 1];
|
|
yyy += curve3[kk * 3 + 2];
|
|
zzz += curve3[kk * 3 + 3];
|
|
/* L100: */
|
|
}
|
|
goto L5000;
|
|
} else if (*tparam == 0.) {
|
|
pntcrb[1] = curve3[4];
|
|
pntcrb[2] = curve3[5];
|
|
pntcrb[3] = curve3[6];
|
|
goto L9999;
|
|
}
|
|
|
|
/* ---------------------------- MSCHEMA DE HORNER ------------------------
|
|
*/
|
|
/* ---> Ici TPARAM est different de 1.D0 et de 0.D0. */
|
|
|
|
ndeg = *ncoeff - 1;
|
|
xxx = curve3[*ncoeff * 3 + 1];
|
|
yyy = curve3[*ncoeff * 3 + 2];
|
|
zzz = curve3[*ncoeff * 3 + 3];
|
|
for (kk = ndeg; kk >= 1; --kk) {
|
|
xxx = xxx * *tparam + curve3[kk * 3 + 1];
|
|
yyy = yyy * *tparam + curve3[kk * 3 + 2];
|
|
zzz = zzz * *tparam + curve3[kk * 3 + 3];
|
|
/* L200: */
|
|
}
|
|
goto L5000;
|
|
|
|
/* ------------------------ RECUPERATION DU POINT CALCULE ---------------
|
|
*/
|
|
|
|
L5000:
|
|
pntcrb[1] = xxx;
|
|
pntcrb[2] = yyy;
|
|
pntcrb[3] = zzz;
|
|
|
|
/* ------------------------------ THE END -------------------------------
|
|
*/
|
|
|
|
L9999:
|
|
return 0;
|
|
} /* mvpscr3_ */
|
|
|
|
//=======================================================================
|
|
//function : AdvApp2Var_MathBase::mvsheld_
|
|
//purpose :
|
|
//=======================================================================
|
|
int AdvApp2Var_MathBase::mvsheld_(integer *n,
|
|
integer *is,
|
|
doublereal *dtab,
|
|
integer *icle)
|
|
|
|
{
|
|
/* System generated locals */
|
|
integer dtab_dim1, dtab_offset, i__1, i__2;
|
|
|
|
/* Local variables */
|
|
static integer incr;
|
|
static doublereal dsave;
|
|
static integer i3, i4, i5, incrp1;
|
|
|
|
|
|
/************************************************************************
|
|
*******/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* TRI LES COLONNES D'UN TABLEAU DE REAL*8 SUIVANT LA METHODE DE SHE
|
|
LL*/
|
|
/* (DANS L'ORDRE CROISSANT) */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* POINT-ENTREE, TRI, SHELL */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* ------------------ */
|
|
/* N : NOMBRE DE COLONNES DU TABLEAU */
|
|
/* IS : NOMBRE DE LIGNE DU TABLEAU */
|
|
/* DTAB : TABLEAU DE REAL*8 A TRIER */
|
|
/* ICLE : POSITION DE LA CLE SUR LA COLONNE */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* ------------------- */
|
|
/* DTAB : TABLEAU TRIE */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ---------------- */
|
|
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* ---------------------- */
|
|
/* Neant */
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
/* METHODE CLASSIQUE DE SHELL : TRI PAR SERIES */
|
|
/* La declaration DTAB(IS, 1) correspond en fait a DTAB(IS, *) */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* -------------------------------- */
|
|
/* 24-09-93 : PMN; NETTOYAGE ET CORRECTION DE L'EN-TETE */
|
|
/* 13-07-84 : BF ; VERSION D'ORIGINE */
|
|
|
|
/* > */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
|
|
/* Parameter adjustments */
|
|
dtab_dim1 = *is;
|
|
dtab_offset = dtab_dim1 + 1;
|
|
dtab -= dtab_offset;
|
|
|
|
/* Function Body */
|
|
if (*n <= 1) {
|
|
goto L9900;
|
|
}
|
|
/* ------------------------ */
|
|
|
|
/* INITIALISATION DE LA SUITE DES INCREMENTS */
|
|
/* RECHERCHE DU PLUS GRAND INCREMENT TEL QUE INCR < N/9 */
|
|
|
|
incr = 1;
|
|
L1001:
|
|
if (incr >= *n / 9) {
|
|
goto L1002;
|
|
}
|
|
/* ----------------------------- */
|
|
incr = incr * 3 + 1;
|
|
goto L1001;
|
|
|
|
/* BOUCLE SUR LES INCREMENTS JUSQU'A INCR = 1 */
|
|
/* TRI PAR SERIES DISTANTES DE INCR */
|
|
|
|
L1002:
|
|
incrp1 = incr + 1;
|
|
/* ----------------- */
|
|
i__1 = *n;
|
|
for (i3 = incrp1; i3 <= i__1; ++i3) {
|
|
/* ---------------------- */
|
|
|
|
/* METTRE L'ELEMENT I3 A SA PLACE DANS SA SERIE */
|
|
|
|
i4 = i3 - incr;
|
|
L1004:
|
|
if (i4 < 1) {
|
|
goto L1003;
|
|
}
|
|
/* ------------------------- */
|
|
if (dtab[*icle + i4 * dtab_dim1] <= dtab[*icle + (i4 + incr) *
|
|
dtab_dim1]) {
|
|
goto L1003;
|
|
}
|
|
|
|
i__2 = *is;
|
|
for (i5 = 1; i5 <= i__2; ++i5) {
|
|
/* ------------------ */
|
|
dsave = dtab[i5 + i4 * dtab_dim1];
|
|
dtab[i5 + i4 * dtab_dim1] = dtab[i5 + (i4 + incr) * dtab_dim1];
|
|
dtab[i5 + (i4 + incr) * dtab_dim1] = dsave;
|
|
}
|
|
/* -------- */
|
|
i4 -= incr;
|
|
goto L1004;
|
|
|
|
L1003:
|
|
;
|
|
}
|
|
/* -------- */
|
|
|
|
/* PASSAGE A L'INCREMENT SUIVANT */
|
|
|
|
incr /= 3;
|
|
if (incr >= 1) {
|
|
goto L1002;
|
|
}
|
|
|
|
L9900:
|
|
return 0 ;
|
|
} /* mvsheld_ */
|
|
|
|
//=======================================================================
|
|
//function : AdvApp2Var_MathBase::mzsnorm_
|
|
//purpose :
|
|
//=======================================================================
|
|
doublereal AdvApp2Var_MathBase::mzsnorm_(integer *ndimen,
|
|
doublereal *vecteu)
|
|
|
|
{
|
|
/* System generated locals */
|
|
integer i__1;
|
|
doublereal ret_val, d__1, d__2;
|
|
|
|
/* Local variables */
|
|
static doublereal xsom;
|
|
static integer i__, irmax;
|
|
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* FONCTION : */
|
|
/* ---------- */
|
|
/* Sert a calculer la norme euclidienne d'un vecteur : */
|
|
/* ____________________________ */
|
|
/* Z = V V(1)**2 + V(2)**2 + ... */
|
|
|
|
/* MOTS CLES : */
|
|
/* ----------- */
|
|
/* SURMFACIQUE, */
|
|
|
|
/* ARGUMENTS D'ENTREE : */
|
|
/* ------------------ */
|
|
/* NDIMEN : Dimension du vecteur */
|
|
/* VECTEU : vecteur de dimension NDIMEN */
|
|
|
|
/* ARGUMENTS DE SORTIE : */
|
|
/* ------------------- */
|
|
/* MZSNORM : Valeur de la norme euclidienne du vecteur VECTEU */
|
|
|
|
/* COMMONS UTILISES : */
|
|
/* ---------------- */
|
|
|
|
/* .Neant. */
|
|
|
|
/* REFERENCES APPELEES : */
|
|
/* ---------------------- */
|
|
/* Type Name */
|
|
/* R*8 ABS R*8 SQRT */
|
|
|
|
/* DESCRIPTION/REMARQUES/LIMITATIONS : */
|
|
/* ----------------------------------- */
|
|
/* Pour limiter les risques d'overflow, on met en facteur */
|
|
/* le terme de plus forte valeur absolue : */
|
|
/* _______________________ */
|
|
/* Z = !V(1)! * V 1 + (V(2)/V(1))**2 + ... */
|
|
|
|
/* $ HISTORIQUE DES MODIFICATIONS : */
|
|
/* -------------------------------- */
|
|
/* 11-09-1995 : JMF ; implicit none */
|
|
/* 20-03-89 : DH ; Creation version originale */
|
|
/* > */
|
|
/* ***********************************************************************
|
|
*/
|
|
/* DECLARATIONS */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* TRAITEMENT */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
/* ___ Recherche du terme de plus forte valeur absolue */
|
|
|
|
/* Parameter adjustments */
|
|
--vecteu;
|
|
|
|
/* Function Body */
|
|
irmax = 1;
|
|
i__1 = *ndimen;
|
|
for (i__ = 2; i__ <= i__1; ++i__) {
|
|
if ((d__1 = vecteu[irmax], abs(d__1)) < (d__2 = vecteu[i__], abs(d__2)
|
|
)) {
|
|
irmax = i__;
|
|
}
|
|
/* L100: */
|
|
}
|
|
|
|
/* ___ Calcul de la norme */
|
|
|
|
if ((d__1 = vecteu[irmax], abs(d__1)) < 1.) {
|
|
xsom = 0.;
|
|
i__1 = *ndimen;
|
|
for (i__ = 1; i__ <= i__1; ++i__) {
|
|
/* Computing 2nd power */
|
|
d__1 = vecteu[i__];
|
|
xsom += d__1 * d__1;
|
|
/* L200: */
|
|
}
|
|
ret_val = sqrt(xsom);
|
|
} else {
|
|
xsom = 0.;
|
|
i__1 = *ndimen;
|
|
for (i__ = 1; i__ <= i__1; ++i__) {
|
|
if (i__ == irmax) {
|
|
xsom += 1.;
|
|
} else {
|
|
/* Computing 2nd power */
|
|
d__1 = vecteu[i__] / vecteu[irmax];
|
|
xsom += d__1 * d__1;
|
|
}
|
|
/* L300: */
|
|
}
|
|
ret_val = (d__1 = vecteu[irmax], abs(d__1)) * sqrt(xsom);
|
|
}
|
|
|
|
/* ***********************************************************************
|
|
*/
|
|
/* RETOUR PROGRAMME APPELANT */
|
|
/* ***********************************************************************
|
|
*/
|
|
|
|
return ret_val;
|
|
} /* mzsnorm_ */
|
|
|