/* MA2CD1.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__1 = 1;

/* Subroutine */ int mma2cd1_(ndimen, nbpntu, urootl, nbpntv, vrootl, iordru, 
	iordrv, contr1, contr2, contr3, contr4, fpntbu, fpntbv, uhermt, 
	vhermt, sosotb, soditb, disotb, diditb)
integer *ndimen, *nbpntu;
doublereal *urootl;
integer *nbpntv;
doublereal *vrootl;
integer *iordru, *iordrv;
doublereal *contr1, *contr2, *contr3, *contr4, *fpntbu, *fpntbv, *uhermt, *
	vhermt, *sosotb, *soditb, *disotb, *diditb;
{
    /* System generated locals */
    integer contr1_dim1, contr1_dim2, contr1_offset, contr2_dim1, contr2_dim2,
	     contr2_offset, contr3_dim1, contr3_dim2, contr3_offset, 
	    contr4_dim1, contr4_dim2, contr4_offset, uhermt_dim1, 
	    uhermt_offset, vhermt_dim1, vhermt_offset, fpntbu_dim1, 
	    fpntbu_offset, fpntbv_dim1, fpntbv_offset, sosotb_dim1, 
	    sosotb_dim2, sosotb_offset, diditb_dim1, diditb_dim2, 
	    diditb_offset, soditb_dim1, soditb_dim2, soditb_offset, 
	    disotb_dim1, disotb_dim2, disotb_offset, i__1, i__2, i__3, i__4, 
	    i__5;

    /* Local variables */
    extern /* Subroutine */ int mmmpocur_();
    static integer ncfhu, ncfhv, nuroo, nvroo, nd, ii, jj, kk, ll, ibb, kkm, 
	    llm, kkp, llp;
    extern integer mnfndeb_();
    extern /* Subroutine */ int mgenmsg_();
    static doublereal bid1, bid2, bid3, bid4;
    extern /* Subroutine */ int mgsomsg_();
    static doublereal diu1, diu2, div1, div2, sou1, sou2, sov1, sov2;




/* < */
/* **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 sur les parametres des polynomes d'interpolation */
/*     des contraintes aux coins a l'ordre IORDRE. */

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

/*     ARGUMENTS D'ENTREE : */
/*     ------------------ */
/*     NDIMEN: Dimension de l' espace. */
/*     NBPNTU: Nbre de parametres INTERNES de discretisation EN U. */
/*             C'est aussi le nbre de racine du polynome de Legendre ou */
/*             on discretise. */
/*     UROOTL: Tableau des parametres de discretisation SUR (-1,1) EN U. 
*/
/*     NBPNTV: Nbre de parametres INTERNES de discretisation EN V. */
/*             C'est aussi le nbre de racine du polynome de Legendre ou */
/*             on discretise. */
/*     VROOTL: Tableau des parametres de discretisation SUR (-1,1) EN V. 
*/
/*     IORDRU: Ordre de contrainte impose aux extremites de l'iso-V */
/*             = 0, on calcule les extremites de l'iso-V */
/*             = 1, on calcule, en plus, la derivee 1ere dans le sens */
/*                  de l'iso-V */
/*             = 2, on calcule, en plus, la derivee 2nde dans le sens */
/*                  de l'iso-V */
/*     IORDRV: Ordre de contrainte impose aux extremites de l'iso-U */
/*             = 0, on calcule les extremites de l'iso-U. */
/*             = 1, on calcule, en plus, la derivee 1ere dans le sens */
/*                  de l'iso-U */
/*             = 2, on calcule, en plus, la derivee 2nde dans le sens */
/*                  de l'iso-U */
/*     CONTR1: Contient, si IORDRU et IORDRV>=0, les valeurs aux */
/*             extremitees de F(U0,V0)et de ses derivees. */
/*     CONTR2: Contient, si IORDRU et IORDRV>=0, les valeurs aux */
/*             extremitees de F(U1,V0)et de ses derivees. */
/*     CONTR3: Contient, si IORDRU et IORDRV>=0, les valeurs aux */
/*             extremitees de F(U0,V1)et de ses derivees. */
/*     CONTR4: Contient, si IORDRU et IORDRV>=0, les valeurs aux */
/*             extremitees de F(U1,V1)et de ses derivees. */
/*     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 : */
/*     ------------------- */
/*     FPNTBU: Tableau auxiliaire. */
/*     FPNTBV: Tableau auxiliaire. */
/*     UHERMT: Table des 2*(IORDRU+1) coeff. des 2*(IORDRU+1) polynomes */
/*             d'Hermite. */
/*     VHERMT: Table des 2*(IORDRV+1) coeff. des 2*(IORDRV+1) polynomes */
/*             d'Hermite. */
/*   SOSOTB: Tableau ou l'on ajoute les termes de contraintes */
/*           C(ui,vj) + C(ui,-vj) + C(-ui,vj) + C(-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 de contraintes */
/*           C(ui,vj) + C(ui,-vj) - C(-ui,vj) - C(-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 de contraintes */
/*           C(ui,vj) - C(ui,-vj) + C(-ui,vj) - C(-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 de contraintes */
/*           C(ui,vj) - C(ui,-vj) - C(-ui,vj) + C(-ui,-vj) */
/*           avec ui et vj racines positives du polynome de Legendre */
/*           de degre NBPNTU et NBPNTV respectivement. */

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

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

/*     DESCRIPTION/REMARQUES/LIMITATIONS : */
/*     ----------------------------------- */

/* $    HISTORIQUE DES MODIFICATIONS   : */
/*     -------------------------------- */
/*     09-08-1991: RBD; Creation. */
/* > */
/* ********************************************************************** 
*/

/*   Le nom de la routine */


    /* Parameter adjustments */
    --urootl;
    diditb_dim1 = *nbpntu / 2 + 1;
    diditb_dim2 = *nbpntv / 2 + 1;
    diditb_offset = diditb_dim1 * diditb_dim2;
    diditb -= diditb_offset;
    disotb_dim1 = *nbpntu / 2;
    disotb_dim2 = *nbpntv / 2;
    disotb_offset = disotb_dim1 * (disotb_dim2 + 1) + 1;
    disotb -= disotb_offset;
    soditb_dim1 = *nbpntu / 2;
    soditb_dim2 = *nbpntv / 2;
    soditb_offset = soditb_dim1 * (soditb_dim2 + 1) + 1;
    soditb -= soditb_offset;
    sosotb_dim1 = *nbpntu / 2 + 1;
    sosotb_dim2 = *nbpntv / 2 + 1;
    sosotb_offset = sosotb_dim1 * sosotb_dim2;
    sosotb -= sosotb_offset;
    --vrootl;
    uhermt_dim1 = (*iordru << 1) + 2;
    uhermt_offset = uhermt_dim1;
    uhermt -= uhermt_offset;
    fpntbu_dim1 = *nbpntu;
    fpntbu_offset = fpntbu_dim1 + 1;
    fpntbu -= fpntbu_offset;
    vhermt_dim1 = (*iordrv << 1) + 2;
    vhermt_offset = vhermt_dim1;
    vhermt -= vhermt_offset;
    fpntbv_dim1 = *nbpntv;
    fpntbv_offset = fpntbv_dim1 + 1;
    fpntbv -= fpntbv_offset;
    contr4_dim1 = *ndimen;
    contr4_dim2 = *iordru + 2;
    contr4_offset = contr4_dim1 * (contr4_dim2 + 1) + 1;
    contr4 -= contr4_offset;
    contr3_dim1 = *ndimen;
    contr3_dim2 = *iordru + 2;
    contr3_offset = contr3_dim1 * (contr3_dim2 + 1) + 1;
    contr3 -= contr3_offset;
    contr2_dim1 = *ndimen;
    contr2_dim2 = *iordru + 2;
    contr2_offset = contr2_dim1 * (contr2_dim2 + 1) + 1;
    contr2 -= contr2_offset;
    contr1_dim1 = *ndimen;
    contr1_dim2 = *iordru + 2;
    contr1_offset = contr1_dim1 * (contr1_dim2 + 1) + 1;
    contr1 -= contr1_offset;

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

/* ------------------- Discretisation des polynomes d'Hermite ----------- 
*/

    ncfhu = (*iordru + 1) << 1;
    i__1 = ncfhu;
    for (ii = 1; ii <= i__1; ++ii) {
	i__2 = *nbpntu;
	for (ll = 1; ll <= i__2; ++ll) {
	    mmmpocur_(&ncfhu, &c__1, &ncfhu, &uhermt[ii * uhermt_dim1], &
		    urootl[ll], &fpntbu[ll + ii * fpntbu_dim1]);
/* L20: */
	}
/* L10: */
    }
    ncfhv = (*iordrv + 1) << 1;
    i__1 = ncfhv;
    for (jj = 1; jj <= i__1; ++jj) {
	i__2 = *nbpntv;
	for (kk = 1; kk <= i__2; ++kk) {
	    mmmpocur_(&ncfhv, &c__1, &ncfhv, &vhermt[jj * vhermt_dim1], &
		    vrootl[kk], &fpntbv[kk + jj * fpntbv_dim1]);
/* L40: */
	}
/* L30: */
    }

/* ---- On retranche les discretisations des polynomes de contrainte ---- 
*/

    nuroo = *nbpntu / 2;
    nvroo = *nbpntv / 2;
    i__1 = *ndimen;
    for (nd = 1; nd <= i__1; ++nd) {

	i__2 = *iordrv + 1;
	for (jj = 1; jj <= i__2; ++jj) {
	    i__3 = *iordru + 1;
	    for (ii = 1; ii <= i__3; ++ii) {
		bid1 = contr1[nd + (ii + jj * contr1_dim2) * contr1_dim1];
		bid2 = contr2[nd + (ii + jj * contr2_dim2) * contr2_dim1];
		bid3 = contr3[nd + (ii + jj * contr3_dim2) * contr3_dim1];
		bid4 = contr4[nd + (ii + jj * contr4_dim2) * contr4_dim1];

		i__4 = nvroo;
		for (kk = 1; kk <= i__4; ++kk) {
		    kkp = (*nbpntv + 1) / 2 + kk;
		    kkm = nvroo - kk + 1;
		    sov1 = fpntbv[kkp + ((jj << 1) - 1) * fpntbv_dim1] + 
			    fpntbv[kkm + ((jj << 1) - 1) * fpntbv_dim1];
		    div1 = fpntbv[kkp + ((jj << 1) - 1) * fpntbv_dim1] - 
			    fpntbv[kkm + ((jj << 1) - 1) * fpntbv_dim1];
		    sov2 = fpntbv[kkp + (jj << 1) * fpntbv_dim1] + fpntbv[kkm 
			    + (jj << 1) * fpntbv_dim1];
		    div2 = fpntbv[kkp + (jj << 1) * fpntbv_dim1] - fpntbv[kkm 
			    + (jj << 1) * fpntbv_dim1];
		    i__5 = nuroo;
		    for (ll = 1; ll <= i__5; ++ll) {
			llp = (*nbpntu + 1) / 2 + ll;
			llm = nuroo - ll + 1;
			sou1 = fpntbu[llp + ((ii << 1) - 1) * fpntbu_dim1] + 
				fpntbu[llm + ((ii << 1) - 1) * fpntbu_dim1];
			diu1 = fpntbu[llp + ((ii << 1) - 1) * fpntbu_dim1] - 
				fpntbu[llm + ((ii << 1) - 1) * fpntbu_dim1];
			sou2 = fpntbu[llp + (ii << 1) * fpntbu_dim1] + fpntbu[
				llm + (ii << 1) * fpntbu_dim1];
			diu2 = fpntbu[llp + (ii << 1) * fpntbu_dim1] - fpntbu[
				llm + (ii << 1) * fpntbu_dim1];
			sosotb[ll + (kk + nd * sosotb_dim2) * sosotb_dim1] = 
				sosotb[ll + (kk + nd * sosotb_dim2) * 
				sosotb_dim1] - bid1 * sou1 * sov1 - bid2 * 
				sou2 * sov1 - bid3 * sou1 * sov2 - bid4 * 
				sou2 * sov2;
			soditb[ll + (kk + nd * soditb_dim2) * soditb_dim1] = 
				soditb[ll + (kk + nd * soditb_dim2) * 
				soditb_dim1] - bid1 * sou1 * div1 - bid2 * 
				sou2 * div1 - bid3 * sou1 * div2 - bid4 * 
				sou2 * div2;
			disotb[ll + (kk + nd * disotb_dim2) * disotb_dim1] = 
				disotb[ll + (kk + nd * disotb_dim2) * 
				disotb_dim1] - bid1 * diu1 * sov1 - bid2 * 
				diu2 * sov1 - bid3 * diu1 * sov2 - bid4 * 
				diu2 * sov2;
			diditb[ll + (kk + nd * diditb_dim2) * diditb_dim1] = 
				diditb[ll + (kk + nd * diditb_dim2) * 
				diditb_dim1] - bid1 * diu1 * div1 - bid2 * 
				diu2 * div1 - bid3 * diu1 * div2 - bid4 * 
				diu2 * div2;
/* L450: */
		    }
/* L400: */
		}

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

		if (*nbpntu % 2 == 1) {
		    sou1 = fpntbu[nuroo + 1 + ((ii << 1) - 1) * fpntbu_dim1];
		    sou2 = fpntbu[nuroo + 1 + (ii << 1) * fpntbu_dim1];
		    i__4 = nvroo;
		    for (kk = 1; kk <= i__4; ++kk) {
			kkp = (*nbpntv + 1) / 2 + kk;
			kkm = nvroo - kk + 1;
			sov1 = fpntbv[kkp + ((jj << 1) - 1) * fpntbv_dim1] + 
				fpntbv[kkm + ((jj << 1) - 1) * fpntbv_dim1];
			div1 = fpntbv[kkp + ((jj << 1) - 1) * fpntbv_dim1] - 
				fpntbv[kkm + ((jj << 1) - 1) * fpntbv_dim1];
			sov2 = fpntbv[kkp + (jj << 1) * fpntbv_dim1] + fpntbv[
				kkm + (jj << 1) * fpntbv_dim1];
			div2 = fpntbv[kkp + (jj << 1) * fpntbv_dim1] - fpntbv[
				kkm + (jj << 1) * fpntbv_dim1];
			sosotb[(kk + nd * sosotb_dim2) * sosotb_dim1] = 
				sosotb[(kk + nd * sosotb_dim2) * sosotb_dim1] 
				- bid1 * sou1 * sov1 - bid2 * sou2 * sov1 - 
				bid3 * sou1 * sov2 - bid4 * sou2 * sov2;
			diditb[(kk + nd * diditb_dim2) * diditb_dim1] = 
				diditb[(kk + nd * diditb_dim2) * diditb_dim1] 
				- bid1 * sou1 * div1 - bid2 * sou2 * div1 - 
				bid3 * sou1 * div2 - bid4 * sou2 * div2;
/* L500: */
		    }
		}

		if (*nbpntv % 2 == 1) {
		    sov1 = fpntbv[nvroo + 1 + ((jj << 1) - 1) * fpntbv_dim1];
		    sov2 = fpntbv[nvroo + 1 + (jj << 1) * fpntbv_dim1];
		    i__4 = nuroo;
		    for (ll = 1; ll <= i__4; ++ll) {
			llp = (*nbpntu + 1) / 2 + ll;
			llm = nuroo - ll + 1;
			sou1 = fpntbu[llp + ((ii << 1) - 1) * fpntbu_dim1] + 
				fpntbu[llm + ((ii << 1) - 1) * fpntbu_dim1];
			diu1 = fpntbu[llp + ((ii << 1) - 1) * fpntbu_dim1] - 
				fpntbu[llm + ((ii << 1) - 1) * fpntbu_dim1];
			sou2 = fpntbu[llp + (ii << 1) * fpntbu_dim1] + fpntbu[
				llm + (ii << 1) * fpntbu_dim1];
			diu2 = fpntbu[llp + (ii << 1) * fpntbu_dim1] - fpntbu[
				llm + (ii << 1) * fpntbu_dim1];
			sosotb[ll + nd * sosotb_dim2 * sosotb_dim1] = sosotb[
				ll + nd * sosotb_dim2 * sosotb_dim1] - bid1 * 
				sou1 * sov1 - bid2 * sou2 * sov1 - bid3 * 
				sou1 * sov2 - bid4 * sou2 * sov2;
			diditb[ll + nd * diditb_dim2 * diditb_dim1] = diditb[
				ll + nd * diditb_dim2 * diditb_dim1] - bid1 * 
				diu1 * sov1 - bid2 * diu2 * sov1 - bid3 * 
				diu1 * sov2 - bid4 * diu2 * sov2;
/* L600: */
		    }
		}

		if (*nbpntu % 2 == 1 && *nbpntv % 2 == 1) {
		    sou1 = fpntbu[nuroo + 1 + ((ii << 1) - 1) * fpntbu_dim1];
		    sou2 = fpntbu[nuroo + 1 + (ii << 1) * fpntbu_dim1];
		    sov1 = fpntbv[nvroo + 1 + ((jj << 1) - 1) * fpntbv_dim1];
		    sov2 = fpntbv[nvroo + 1 + (jj << 1) * fpntbv_dim1];
		    sosotb[nd * sosotb_dim2 * sosotb_dim1] = sosotb[nd * 
			    sosotb_dim2 * sosotb_dim1] - bid1 * sou1 * sov1 - 
			    bid2 * sou2 * sov1 - bid3 * sou1 * sov2 - bid4 * 
			    sou2 * sov2;
		    diditb[nd * diditb_dim2 * diditb_dim1] = diditb[nd * 
			    diditb_dim2 * diditb_dim1] - bid1 * sou1 * sov1 - 
			    bid2 * sou2 * sov1 - bid3 * sou1 * sov2 - bid4 * 
			    sou2 * sov2;
		}

/* L300: */
	    }
/* L200: */
	}
/* L100: */
    }
    goto L9999;

/* ------------------------------ The End ------------------------------- 
*/

L9999:
    if (ibb >= 3) {
	mgsomsg_("MMA2CD1", 7L);
    }
    return 0;
} /* mma2cd1_ */

