/* MA1FDI.f -- translated by f2c (version 19960827).
   You must link the resulting object file with the libraries:
	-lf2c -lm   (in that order)
*/

#include "Data_f2c.h"

/* Subroutine */ int mma1fdi_(ndimen, uvfonc, foncnp, isofav, tconst, nbroot, 
	ttable, iordre, ideriv, fpntab, somtab, diftab, contr1, contr2, 
	iercod)
integer *ndimen;
doublereal *uvfonc;
/* Subroutine */ int (*foncnp) ();
integer *isofav;
doublereal *tconst;
integer *nbroot;
doublereal *ttable;
integer *iordre, *ideriv;
doublereal *fpntab, *somtab, *diftab, *contr1, *contr2;
integer *iercod;
{
    /* System generated locals */
    integer fpntab_dim1, somtab_dim1, somtab_offset, diftab_dim1, 
	    diftab_offset, contr1_dim1, contr1_offset, contr2_dim1, 
	    contr2_offset, i__1, i__2;
    doublereal d__1;

    /* Builtin functions */
    double pow__di();

    /* Local variables */
    static integer ideb, ifin, nroo2, ideru, iderv;
    static doublereal renor;
    static integer ii, nd, ibb, iim, nbp, iip;
    extern integer mnfndeb_();
    extern /* Subroutine */ int maermsg_(), mgenmsg_();
    static doublereal bid1, bid2;
    extern /* Subroutine */ int mgsomsg_();




/* < */
/* **NOTICE */
/*  THIS SOFTWARE IS THE PROPERTY OF CISIGRAPH. */
/*  THIS CODE MUST NOT BE DISTRIBUTED OR COPIED WITHOUT THE PRIOR */
/*  WRITTEN PERMISSION OF CISIGRAPH AND IS ONLY TO BE USED ON THE */
/*  SITE WHERE IT IS INSTALLED BY CISIGRAPH */
/* **NOTICE */

/* ********************************************************************** 
*/

/*     FONCTION : */
/*     ---------- */
/*     Discretisation d' une fonction non polynomiale F(U,V) ou d'une */
/*     de ses derivees a isoparametre fixe. */

/*     MOTS CLES : */
/*     ----------- */
/*     TOUS, AB_SPECIFI::FONCTION&, DISCRETISATION, &POINT */

/*     ARGUMENTS D'ENTREE : */
/*     ------------------ */
/*     NDIMEN: Dimension de l' espace. */
/*     UVFONC: Bornes du pave de definition en U et en V de la fonction */
/*             a approcher. */
/*     FONCNP: Le NOM de la fonction non polynomiale a approcher */
/*             (programme externe). */
/*     ISOFAV: Isoparametre fixe pour la discretisation; */
/*             = 1, on discretise a U fixe et V variable. */
/*             = 2, on discretise a V fixe et U variable. */
/*     TCONST: Valeur de l'iso fixe. */
/*     NBROOT: Nbre de parametres INTERNES de discretisation. */
/*             (s'il y a des contraintes, on doit ajouter 2 extremites). 
*/
/*             C'est aussi le nbre de racine du polynome de Legendre ou */
/*             on discretise. */
/*     TTABLE: Tableau des parametres de discretisation et des 2 */
/*             extremites */
/*             (Respectivement (-1, NBROOT racines de Legendre,1) */
/*             recadrees dans l'intervalle adequat. */
/*     IORDRE: Ordre de contrainte impose aux extremites de l'iso. */
/*             (Si Iso-U, on doit calculer les derivees en V et vice */
/*             versa). */
/*             = 0, on calcule les extremites de l'iso */
/*             = 1, on calcule, en plus, la derivee 1ere dans le sens */
/*                  de l'iso */
/*             = 2, on calcule, en plus, la derivee 2nde dans le sens */
/*                  de l'iso */
/*     IDERIV: Ordre de derivee transverse a l'iso fixee (Si Iso-U=Uc */
/*             fixee, on discretise la derivee d'ordre IDERIV en U de */
/*             F(Uc,v). Idem si on fixe une iso-V). */
/*             Varie de 0 (positionnement) a 2 (derivee 2nde). */

/*     ARGUMENTS DE SORTIE : */
/*     ------------------- */
/*     FPNTAB: Tableau auxiliaire. */
/*     SOMTAB: Tableau des NBROOT/2 sommes des 2 points d'indices */
/*             NBROOT-II+1 et II, pour II = 1, NBROOT/2 */
/*     DIFTAB: Tableau des NBROOT/2 differences des 2 points d'indices */
/*             NBROOT-II+1 et II, pour II = 1, NBROOT/2 */
/*     CONTR1: Contient, si IORDRE>=0, les IORDRE+1 valeurs en TTABLE(0) 
*/
/*             (1ere extremitee) de derivees de F(Uc,Ve) ou F(Ue,Vc), */
/*             voir ci dessous. */
/*     CONTR2: Contient, si IORDRE>=0, les IORDRE+1 valeurs en */
/*             TTABLE(NBROOT+1) (2eme extremitee) de: */
/*                Si ISOFAV=1, derivee d'ordre IDERIV en U, derivee */
/*             d'ordre 0 a IORDRE en V de F(Uc,Ve) ou Uc=TCONST */
/*             (valeur de l'iso fixe) et Ve est l'extremite fixe. */
/*                Si ISOFAV=2, derivee d'ordre IDERIV en V, derivee */
/*             d'ordre 0 a IORDRE en U de F(Ue,Vc) ou Vc=TCONST */
/*             (valeur de l'iso fixe) et Ue est l'extremite fixe. */
/*     IERCOD: Code d' erreur > 100; Pb dans l' evaluation de FONCNP, */
/*             le code d'erreur renvoye est egal au code d' erreur */
/*             de FONCNP + 100. */

/*     COMMONS UTILISES   : */
/*     ---------------- */

/*     REFERENCES APPELEES   : */
/*     ----------------------- */

/*     DESCRIPTION/REMARQUES/LIMITATIONS : */
/*     ----------------------------------- */
/*     Les resultats de la discretisation sont ranges dans 2 tableaux */
/*     SOMTAB et DIFTAB pour gagner du temps par la suite lors du */
/*     calcul des coefficients de la courbe d' approximation. */

/*     Si NBROOT est impair, on stocke dans SOMTAB(0,*) et DIFTAB(0,*) */
/*     les valeurs de la racine mediane de Legendre (0.D0 dans (-1,1)). */

/*     La fonction F(u,v) definie dans UVFONC est reparametre dans */
/*     (-1,1)x(-1,1). On renormalise donc les derivees 1eres et 2ndes. */

/* $    HISTORIQUE DES MODIFICATIONS   : */
/*     -------------------------------- */
/*     24-06-1991: RBD; Creation. */
/* > */
/* ********************************************************************** 
*/

/*   Le nom de la routine */


    /* Parameter adjustments */
    uvfonc -= 3;
    diftab_dim1 = *nbroot / 2 + 1;
    diftab_offset = diftab_dim1;
    diftab -= diftab_offset;
    somtab_dim1 = *nbroot / 2 + 1;
    somtab_offset = somtab_dim1;
    somtab -= somtab_offset;
    fpntab_dim1 = *ndimen;
    --fpntab;
    contr2_dim1 = *ndimen;
    contr2_offset = contr2_dim1 + 1;
    contr2 -= contr2_offset;
    contr1_dim1 = *ndimen;
    contr1_offset = contr1_dim1 + 1;
    contr1 -= contr1_offset;

    /* Function Body */
    ibb = mnfndeb_();
    if (ibb >= 3) {
	mgenmsg_("MMA1FDI", 7L);
    }
    *iercod = 0;

/* --------------- Definition du nbre de points a calculer -------------- 
*/
/* --> Si contraintes, on prend aussi les bornes */
    if (*iordre >= 0) {
	ideb = 0;
	ifin = *nbroot + 1;
/* --> Sinon, seule les racines de Legendre (recadrees) sont utilisees
. */
    } else {
	ideb = 1;
	ifin = *nbroot;
    }
/* --> Nbre de point a calculer. */
    nbp = ifin - ideb + 1;
    nroo2 = *nbroot / 2;

/* --------------- Determination de l'ordre de derivation global -------- 
*/
/* --> Ici ISOFAV ne prend que les valeurs 1 ou 2. */
/*    Si Iso-U, on derive en U a l'ordre IDERIV */
    if (*isofav == 1) {
	ideru = *ideriv;
	iderv = 0;
	d__1 = (uvfonc[4] - uvfonc[3]) / 2.;
	renor = pow__di(&d__1, ideriv);
/*    Si Iso-V, on derive en V a l'ordre IDERIV */
    } else {
	ideru = 0;
	iderv = *ideriv;
	d__1 = (uvfonc[6] - uvfonc[5]) / 2.;
	renor = pow__di(&d__1, ideriv);
    }

/* ----------- Discretisation sur les racines du polynome --------------- 
*/
/* ---------------------- de Legendre de degre NBROOT ------------------- 
*/

    (*foncnp)(ndimen, &uvfonc[3], &uvfonc[5], isofav, tconst, &nbp, &ttable[
	    ideb], &ideru, &iderv, &fpntab[ideb * fpntab_dim1 + 1], iercod);
    if (*iercod > 0) {
	goto L9999;
    }
    i__1 = *ndimen;
    for (nd = 1; nd <= i__1; ++nd) {
	i__2 = nroo2;
	for (ii = 1; ii <= i__2; ++ii) {
	    iip = (*nbroot + 1) / 2 + ii;
	    iim = nroo2 - ii + 1;
	    bid1 = fpntab[nd + iim * fpntab_dim1];
	    bid2 = fpntab[nd + iip * fpntab_dim1];
	    somtab[ii + nd * somtab_dim1] = renor * (bid2 + bid1);
	    diftab[ii + nd * diftab_dim1] = renor * (bid2 - bid1);
/* L200: */
	}
/* L100: */
    }

/* ------------ Cas ou l' on discretise sur les racines d' un ----------- 
*/
/* ---------- polynome de Legendre de degre impair, 0 est racine -------- 
*/

    if (*nbroot % 2 == 1) {
	i__1 = *ndimen;
	for (nd = 1; nd <= i__1; ++nd) {
	    somtab[nd * somtab_dim1] = renor * fpntab[nd + (nroo2 + 1) * 
		    fpntab_dim1];
	    diftab[nd * diftab_dim1] = renor * fpntab[nd + (nroo2 + 1) * 
		    fpntab_dim1];
/* L300: */
	}
    } else {
	i__1 = *ndimen;
	for (nd = 1; nd <= i__1; ++nd) {
	    somtab[nd * somtab_dim1] = 0.;
	    diftab[nd * diftab_dim1] = 0.;
	}
    }


/* --------------------- Prise en compte des contraintes ---------------- 
*/

    if (*iordre >= 0) {
/* --> Recup des extremites deja calculees. */
	i__1 = *ndimen;
	for (nd = 1; nd <= i__1; ++nd) {
	    contr1[nd + contr1_dim1] = renor * fpntab[nd];
	    contr2[nd + contr2_dim1] = renor * fpntab[nd + (*nbroot + 1) * 
		    fpntab_dim1];
/* L400: */
	}
/* --> Nbre de pts a calculer/appel a FONCNP */
	nbp = 1;
/*    Si Iso-U, on derive en V jusqu'a l'ordre IORDRE */
	if (*isofav == 1) {
/* --> Facteur de normalisation derivee 1ere. */
	    bid1 = (uvfonc[6] - uvfonc[5]) / 2.;
	    i__1 = *iordre;
	    for (iderv = 1; iderv <= i__1; ++iderv) {
		(*foncnp)(ndimen, &uvfonc[3], &uvfonc[5], isofav, tconst, &
			nbp, ttable, &ideru, &iderv, &contr1[(iderv + 1) * 
			contr1_dim1 + 1], iercod);
		if (*iercod > 0) {
		    goto L9999;
		}
/* L500: */
	    }
	    i__1 = *iordre;
	    for (iderv = 1; iderv <= i__1; ++iderv) {
		(*foncnp)(ndimen, &uvfonc[3], &uvfonc[5], isofav, tconst, &
			nbp, &ttable[*nbroot + 1], &ideru, &iderv, &contr2[(
			iderv + 1) * contr2_dim1 + 1], iercod);
		if (*iercod > 0) {
		    goto L9999;
		}
/* L510: */
	    }
/*    Si Iso-V, on derive en U jusqu'a l'ordre IORDRE */
	} else {
/* --> Facteur de normalisation derivee 1ere. */
	    bid1 = (uvfonc[4] - uvfonc[3]) / 2.;
	    i__1 = *iordre;
	    for (ideru = 1; ideru <= i__1; ++ideru) {
		(*foncnp)(ndimen, &uvfonc[3], &uvfonc[5], isofav, tconst, &
			nbp, ttable, &ideru, &iderv, &contr1[(ideru + 1) * 
			contr1_dim1 + 1], iercod);
		if (*iercod > 0) {
		    goto L9999;
		}
/* L600: */
	    }
	    i__1 = *iordre;
	    for (ideru = 1; ideru <= i__1; ++ideru) {
		(*foncnp)(ndimen, &uvfonc[3], &uvfonc[5], isofav, tconst, &
			nbp, &ttable[*nbroot + 1], &ideru, &iderv, &contr2[(
			ideru + 1) * contr2_dim1 + 1], iercod);
		if (*iercod > 0) {
		    goto L9999;
		}
/* L610: */
	    }
	}

/* ------------------------- Normalisation des derivees -------------
---- */
/* (La fonction est redefinie sur (-1,1)*(-1,1)) */
	bid2 = renor;
	i__1 = *iordre;
	for (ii = 1; ii <= i__1; ++ii) {
	    bid2 = bid1 * bid2;
	    i__2 = *ndimen;
	    for (nd = 1; nd <= i__2; ++nd) {
		contr1[nd + (ii + 1) * contr1_dim1] *= bid2;
		contr2[nd + (ii + 1) * contr2_dim1] *= bid2;
/* L710: */
	    }
/* L700: */
	}
    }

/* ------------------------------ The end ------------------------------- 
*/

L9999:
    if (*iercod > 0) {
	*iercod += 100;
	maermsg_("MMA1FDI", iercod, 7L);
    }
    if (ibb >= 3) {
	mgsomsg_("MMA1FDI", 7L);
    }
    return 0;
} /* mma1fdi_ */

