/* MA2DS2.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"

/* Table of constant values */

static integer c__0 = 0;

/* Subroutine */ int mma2ds2_(ndimen, uintfn, vintfn, foncnp, nbpntu, nbpntv, 
	urootb, vrootb, iiuouv, sosotb, disotb, soditb, diditb, fpntab, 
	ttable, iercod)
integer *ndimen;
doublereal *uintfn, *vintfn;
/* Subroutine */ int (*foncnp) ();
integer *nbpntu, *nbpntv;
doublereal *urootb, *vrootb;
integer *iiuouv;
doublereal *sosotb, *disotb, *soditb, *diditb, *fpntab, *ttable;
integer *iercod;
{
    /* System generated locals */
    integer sosotb_dim1, sosotb_dim2, sosotb_offset, disotb_dim1, disotb_dim2,
	     disotb_offset, soditb_dim1, soditb_dim2, soditb_offset, 
	    diditb_dim1, diditb_dim2, diditb_offset, fpntab_dim1, 
	    fpntab_offset, i__1, i__2, i__3;

    /* Local variables */
    static integer jdec;
    static logical ldbg;
    static doublereal alinu, blinu, alinv, blinv, tcons;
    static doublereal dbfn1[2], dbfn2[2];
    static integer nuroo, nvroo, id, iu, iv;
    static doublereal um, up;
    extern integer mnfndeb_();
    extern /* Subroutine */ int maermsg_(), mgenmsg_(), 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 F(u,v) sur les racines des polynomes 
*/
/*     de Legendre. */

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

/*     ARGUMENTS D'ENTREE : */
/*     ------------------ */
/*   NDIMEN: Dimension de l' espace. */
/*   UINTFN: Bornes de l' intervalle de definition en u de la fonction */
/*           a approcher: (UINTFN(1),UINTFN(2)). */
/*   VINTFN: Bornes de l' intervalle de definition en v de la fonction */
/*           a approcher: (VINTFN(1),VINTFN(2)). */
/*   FONCNP: Le NOM de la fonction non polynomiale a approcher. */
/*   NBPNTU: Le degre du polynome de Legendre sur les racines duquel */
/*           on discretise FONCNP en u. */
/*   NBPNTV: Le degre du polynome de Legendre sur les racines duquel */
/*           on discretise FONCNP en v. */
/*   UROOTB: Tableau des racines STRICTEMENTS POSITIVES du polynome */
/*           de Legendre de degre NBPNTU defini sur (-1,1). */
/*   VROOTB: Tableau des racines STRICTEMENTS POSITIVES du polynome */
/*           de Legendre de degre NBPNTV defini sur (-1,1). */
/*   IIUOUV: Indique le type d'iso de F(u,v) a extraire pour ameliorer */
/*           la rapidite de calcul (n'a aucune influence sur la forme */
/*           du resultat) */
/*           = 1, indique que l'on doit calculer les points de F(u,v) */
/*           avec u fixe (donc avec NBPNTV valeurs differentes de v). */
/*           = 2, indique que l'on doit calculer les points de F(u,v) */
/*           avec v fixe (donc avec NBPNTU valeurs differentes de u). */
/*   SOSOTB: Tableau deja initialise (argument d'entree/sortie). */
/*   DISOTB: Tableau deja initialise (argument d'entree/sortie). */
/*   SODITB: Tableau deja initialise (argument d'entree/sortie). */
/*   DIDITB: Tableau deja initialise (argument d'entree/sortie). */

/*     ARGUMENTS DE SORTIE : */
/*     ------------------- */
/*   SOSOTB: Tableau ou l'on ajoute les termes */
/*           F(ui,vj) + F(ui,-vj) + F(-ui,vj) + F(-ui,-vj) */
/*           avec ui et vj racines positives du polynome de Legendre */
/*           de degre NBPNTU et NBPNTV respectivement. */
/*   DISOTB: Tableau ou l'on ajoute les termes */
/*           F(ui,vj) + F(ui,-vj) - F(-ui,vj) - F(-ui,-vj) */
/*           avec ui et vj racines positives du polynome de Legendre */
/*           de degre NBPNTU et NBPNTV respectivement. */
/*   SODITB: Tableau ou l'on ajoute les termes */
/*           F(ui,vj) - F(ui,-vj) + F(-ui,vj) - F(-ui,-vj) */
/*           avec ui et vj racines positives du polynome de Legendre */
/*           de degre NBPNTU et NBPNTV respectivement. */
/*   DIDITB: Tableau ou l'on ajoute les termes */
/*           F(ui,vj) - F(ui,-vj) - F(-ui,vj) + F(-ui,-vj) */
/*           avec ui et vj racines positives du polynome de Legendre */
/*           de degre NBPNTU et NBPNTV respectivement. */
/*   FPNTAB: Tableau auxiliaire. */
/*   TTABLE: Tableau auxiliaire. */
/*   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 : */
/*     ----------------------------------- */
/* -->La fonction externe creee par l' appelant de MA2F1K, MA2FDK */
/*   ou de MA2FXK doit etre de la forme : */
/*    SUBROUTINE FONCNP(NDIMEN,UINTFN,VINTFN,IIIUOUV,TCONST,NBPTAB */
/*                     ,TTABLE,IDERIU,IDERIV,PPNTAB,IERCOD) */
/*    ou les arguments d' entree sont : */
/*      - NDIMEN est un entier defini comme la somme des dimensions des */
/*               sous-espaces (i.e. dimension totale du probleme). */
/*      - UINTFN(2) est un tableau de 2 reels contenant l' intervalle */
/*                  en u ou est definie la fonction a approximer */
/*                  (donc ici egal a UIFONC). */
/*      - VINTFN(2) est un tableau de 2 reels contenant l' intervalle */
/*                  en v ou est definie la fonction a approximer */
/*                  (donc ici egal a VIFONC). */
/*      - IIIUOUV, vaut 1 si l'on veut calculer des points a u constant, 
*/
/*                vaut 2 si l'on calcule les points a v constant. Tout */
/*                autre valeur est une erreur. */
/*      - TCONST, un reel, valeur du parametre fixe. Prend ses valeurs */
/*                dans (UIFONC(1),UIFONC(2)) si IIUOUV = 1 ou dans */
/*                dans (VIFONC(1),VIFONC(2)) si IIUOUV = 2. */
/*      - NBPTAB, un entier. Indique le nombre de points a calculer. */
/*      - TTABLE, un tableau de NBPTAB reels. Ce sont les valeurs du */
/*                parametre 'libre' de discretisation (v si IIIUOUV=1, */
/*                u si IIIUOUV=2). */
/*      - IDERIU, un entier, prend ses valeurs entre 0 (positionnement) */
/*                et IORDRE(1) (derivee partielle de la fonction en u a */
/*                l' ordre IORDRE(1) si IORDRE(1) > 0). */
/*      - IDERIV, un entier, prend ses valeurs entre 0 (positionnement) */
/*                et IORDRE(2) (derivee partielle de la fonction en v a */
/*                l' ordre IORDRE(2) si IORDRE(2) > 0). */
/*                Si IDERIU=i et IDERIV=j, FONCNP devra calculer des */
/*                points de la derivee: */
/*                            i+j */
/*                           d     F(u,v) */
/*                        -------- */
/*                           i  j */
/*                         du dv */

/*     et les arguments de sortie sont : */
/*        - FPNTAB(NDIMEN,NBPTAB) contient, en sortie, le tableau des */
/*                                NBPTAB points calcules dans FONCNP. */
/*        - IERCOD est, en sortie, le code d' erreur de FONCNP. Ce code */
/*                 (entier) doit etre strictement positif s' il y a eu */
/*                 un probleme. */

/*     Les arguments d' entree NE DOIVENT PAS etre modifies sous FONCNP. 
*/

/* -->Comme FONCNP n' est pas forcement definie dans (-1,1)*(-1,1), on */
/* modifie les valeurs de UROOTB et VROOTB en consequence. */

/* -->Les resultats de la discretisation sont ranges dans 4 tableaux */
/* SOSOTB, DISOTB, SODITB et DIDITB pour gagner du temps par la suite */
/* lors du calcul des coefficients du polynome d' approximation. */

/*     Lorsque NBPNTU est impair: */
/*        le tableau SOSOTB(0,j) contient F(0,vj) + F(0,-vj), */
/*        le tableau DIDITB(0,j) contient F(0,vj) - F(0,-vj), */
/*     Lorsque NBPNTV est impair: */
/*        le tableau SOSOTB(i,0) contient F(ui,0) + F(-ui,0), */
/*        le tableau DIDITB(i,0) contient F(ui,0) - F(-ui,0), */
/*     Lorsque NBPNTU et NBPNTV sont impairs: */
/*        le terme SOSOTB(0,0) contient F(0,0). */

/*   ATTENTION: On remplit toujours ces 4 tableaux en faisant varier */
/*   le 1er indice d'abord. C'est a dire que les discretisations */
/*   de F(...,t) (pour IIUOUV = 2) ou de F(t,...) (IIUOUV = 1) */
/*   sont stockees dans SOSOTB(...,t), SODITB(...,t), etc... */
/*   (ceci permet un gain de temps non negligeable). */
/*   Il faut donc que l'appelant, dans le cas ou IIUOUV=1, */
/*   intervertisse les roles de u et v, de SODITB et DISOTB AVANT le */
/*   calcul puis, APRES le calcul prenne la transposee des 4 tableau. */

/* $    HISTORIQUE DES MODIFICATIONS   : */
/*     -------------------------------- */
/*     26-09-1996: JCT; TCONS toujours defini sur VINTFN, d'ou init. */
/*                      de DBFN1, DBFN2 en fonction de IIUOUV. */
/*     06-06-1991: RBD; Finalisation du developpement. */
/*     31-07-1989: RBD; Creation. */
/* > */
/* ********************************************************************** 
*/

/*   Le nom de la routine */

/* --> Indices de boucles. */

/* --------------------------- Initialisations -------------------------- 
*/

    /* Parameter adjustments */
    --uintfn;
    --vintfn;
    --ttable;
    fpntab_dim1 = *ndimen;
    fpntab_offset = fpntab_dim1 + 1;
    fpntab -= fpntab_offset;
    --urootb;
    diditb_dim1 = *nbpntu / 2 + 1;
    diditb_dim2 = *nbpntv / 2 + 1;
    diditb_offset = diditb_dim1 * diditb_dim2;
    diditb -= diditb_offset;
    soditb_dim1 = *nbpntu / 2;
    soditb_dim2 = *nbpntv / 2;
    soditb_offset = soditb_dim1 * (soditb_dim2 + 1) + 1;
    soditb -= soditb_offset;
    disotb_dim1 = *nbpntu / 2;
    disotb_dim2 = *nbpntv / 2;
    disotb_offset = disotb_dim1 * (disotb_dim2 + 1) + 1;
    disotb -= disotb_offset;
    sosotb_dim1 = *nbpntu / 2 + 1;
    sosotb_dim2 = *nbpntv / 2 + 1;
    sosotb_offset = sosotb_dim1 * sosotb_dim2;
    sosotb -= sosotb_offset;
    --vrootb;

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

    alinu = (uintfn[2] - uintfn[1]) / 2.;
    blinu = (uintfn[2] + uintfn[1]) / 2.;
    alinv = (vintfn[2] - vintfn[1]) / 2.;
    blinv = (vintfn[2] + vintfn[1]) / 2.;

    if (*iiuouv == 1) {
     dbfn1[0] = vintfn[1];
     dbfn1[1] = vintfn[2];
     dbfn2[0] = uintfn[1];
     dbfn2[1] = uintfn[2];
    } else {
     dbfn1[0] = uintfn[1];
     dbfn1[1] = uintfn[2];
     dbfn2[0] = vintfn[1];
     dbfn2[1] = vintfn[2];
    }

/* ********************************************************************** 
*/
/* -------- Discretisation en U sur les racines du polynome de ---------- 
*/
/* ---------------- Legendre de degre NBPNTU, a Vj fixe  ---------------- 
*/
/* ********************************************************************** 
*/

    nuroo = *nbpntu / 2;
    nvroo = *nbpntv / 2;
    jdec = (*nbpntu + 1) / 2;

/* ----------- Chargement des parametres de discretisation en U --------- 
*/

    i__1 = *nbpntu;
    for (iu = 1; iu <= i__1; ++iu) {
	ttable[iu] = blinu + alinu * urootb[iu];
/* L100: */
    }

/* -------------- Pour Vj fixe, racine de Legendre negative ------------- 
*/

    i__1 = nvroo;
    for (iv = 1; iv <= i__1; ++iv) {
	tcons = blinv + alinv * vrootb[iv];
	(*foncnp)(ndimen, dbfn1, dbfn2, iiuouv, &tcons, nbpntu, &
		ttable[1], &c__0, &c__0, &fpntab[fpntab_offset], iercod);
	if (*iercod > 0) {
	    goto L9999;
	}
	i__2 = *ndimen;
	for (id = 1; id <= i__2; ++id) {
	    i__3 = nuroo;
	    for (iu = 1; iu <= i__3; ++iu) {
		up = fpntab[id + (iu + jdec) * fpntab_dim1];
		um = fpntab[id + (nuroo - iu + 1) * fpntab_dim1];
		sosotb[iu + (nvroo - iv + 1 + id * sosotb_dim2) * sosotb_dim1]
			 = sosotb[iu + (nvroo - iv + 1 + id * sosotb_dim2) * 
			sosotb_dim1] + up + um;
		disotb[iu + (nvroo - iv + 1 + id * disotb_dim2) * disotb_dim1]
			 = disotb[iu + (nvroo - iv + 1 + id * disotb_dim2) * 
			disotb_dim1] + up - um;
		soditb[iu + (nvroo - iv + 1 + id * soditb_dim2) * soditb_dim1]
			 = soditb[iu + (nvroo - iv + 1 + id * soditb_dim2) * 
			soditb_dim1] - up - um;
		diditb[iu + (nvroo - iv + 1 + id * diditb_dim2) * diditb_dim1]
			 = diditb[iu + (nvroo - iv + 1 + id * diditb_dim2) * 
			diditb_dim1] - up + um;
/* L220: */
	    }
	    if (*nbpntu % 2 != 0) {
		up = fpntab[id + jdec * fpntab_dim1];
		sosotb[(nvroo - iv + 1 + id * sosotb_dim2) * sosotb_dim1] += 
			up;
		diditb[(nvroo - iv + 1 + id * diditb_dim2) * diditb_dim1] -= 
			up;
	    }
/* L210: */
	}
/* L200: */
    }

/* --------- Pour Vj = 0 (NBPNTV impair), discretisation en U ----------- 
*/

    if (*nbpntv % 2 != 0) {
	tcons = blinv;
	(*foncnp)(ndimen, dbfn1, dbfn2, iiuouv, &tcons, nbpntu, &
		ttable[1], &c__0, &c__0, &fpntab[fpntab_offset], iercod);
	if (*iercod > 0) {
	    goto L9999;
	}
	i__1 = *ndimen;
	for (id = 1; id <= i__1; ++id) {
	    i__2 = nuroo;
	    for (iu = 1; iu <= i__2; ++iu) {
		up = fpntab[id + (jdec + iu) * fpntab_dim1];
		um = fpntab[id + (nuroo - iu + 1) * fpntab_dim1];
		sosotb[iu + id * sosotb_dim2 * sosotb_dim1] = sosotb[iu + id *
			 sosotb_dim2 * sosotb_dim1] + up + um;
		diditb[iu + id * diditb_dim2 * diditb_dim1] = diditb[iu + id *
			 diditb_dim2 * diditb_dim1] + up - um;
/* L310: */
	    }
	    if (*nbpntu % 2 != 0) {
		up = fpntab[id + jdec * fpntab_dim1];
		sosotb[id * sosotb_dim2 * sosotb_dim1] += up;
	    }
/* L300: */
	}
    }

/* -------------- Pour Vj fixe, racine de Legendre positive ------------- 
*/

    i__1 = nvroo;
    for (iv = 1; iv <= i__1; ++iv) {
	tcons = alinv * vrootb[(*nbpntv + 1) / 2 + iv] + blinv;
	(*foncnp)(ndimen, dbfn1, dbfn2, iiuouv, &tcons, nbpntu, &
		ttable[1], &c__0, &c__0, &fpntab[fpntab_offset], iercod);
	if (*iercod > 0) {
	    goto L9999;
	}
	i__2 = *ndimen;
	for (id = 1; id <= i__2; ++id) {
	    i__3 = nuroo;
	    for (iu = 1; iu <= i__3; ++iu) {
		up = fpntab[id + (iu + jdec) * fpntab_dim1];
		um = fpntab[id + (nuroo - iu + 1) * fpntab_dim1];
		sosotb[iu + (iv + id * sosotb_dim2) * sosotb_dim1] = sosotb[
			iu + (iv + id * sosotb_dim2) * sosotb_dim1] + up + um;
		disotb[iu + (iv + id * disotb_dim2) * disotb_dim1] = disotb[
			iu + (iv + id * disotb_dim2) * disotb_dim1] + up - um;
		soditb[iu + (iv + id * soditb_dim2) * soditb_dim1] = soditb[
			iu + (iv + id * soditb_dim2) * soditb_dim1] + up + um;
		diditb[iu + (iv + id * diditb_dim2) * diditb_dim1] = diditb[
			iu + (iv + id * diditb_dim2) * diditb_dim1] + up - um;
/* L420: */
	    }
	    if (*nbpntu % 2 != 0) {
		up = fpntab[id + jdec * fpntab_dim1];
		sosotb[(iv + id * sosotb_dim2) * sosotb_dim1] += up;
		diditb[(iv + id * diditb_dim2) * diditb_dim1] += up;
	    }
/* L410: */
	}
/* L400: */
    }

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

L9999:
    if (*iercod > 0) {
	*iercod += 100;
	maermsg_("MMA2DS2", iercod, 7L);
    }
    if (ldbg) {
	mgsomsg_("MMA2DS2", 7L);
    }
    return 0;
} /* mma2ds2_ */

