/* MA2CD3.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 mma2cd3_(ndimen, nbpntu, urootl, nbpntv, iordru, sotbu1, 
	sotbu2, ditbu1, ditbu2, fpntab, uhermt, sosotb, soditb, disotb, 
	diditb)
integer *ndimen, *nbpntu;
doublereal *urootl;
integer *nbpntv, *iordru;
doublereal *sotbu1, *sotbu2, *ditbu1, *ditbu2, *fpntab, *uhermt, *sosotb, *
	soditb, *disotb, *diditb;
{
    /* System generated locals */
    integer sotbu1_dim1, sotbu1_dim2, sotbu1_offset, sotbu2_dim1, sotbu2_dim2,
	     sotbu2_offset, ditbu1_dim1, ditbu1_dim2, ditbu1_offset, 
	    ditbu2_dim1, ditbu2_dim2, ditbu2_offset, fpntab_dim1, 
	    fpntab_offset, uhermt_dim1, uhermt_offset, sosotb_dim1, 
	    sosotb_dim2, sosotb_offset, diditb_dim1, diditb_dim2, 
	    diditb_offset, soditb_dim1, soditb_dim2, soditb_offset, 
	    disotb_dim1, disotb_dim2, disotb_offset, i__1, i__2, i__3, i__4;

    /* Local variables */
    extern /* Subroutine */ int mmmpocur_();
    static integer ncfhu, nuroo, nvroo, ii, nd, jj, kk, ibb, kkm, kkp;
    extern integer mnfndeb_();
    extern /* Subroutine */ int mgenmsg_();
    static doublereal bid1, bid2, bid3, bid4;
    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 sur les parametres des polynomes d'interpolation */
/*     des contraintes sur les 2 bords iso-U a l'ordre IORDRU. */

/*     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. */
/*     IORDRU: Ordre de derivation de l'iso-U */
/*             = 0, on calcule l'iso-U. */
/*             = 1, on calcule, en plus, la derivee 1ere dans le sens */
/*                  transverse a l'iso-U (donc en U). */
/*             = 2, on calcule, en plus, la derivee 2nde dans le sens */
/*                  transverse a l'iso-U (donc en U). */
/*     SOTBU1: Tableau des NBPNTU/2 sommes des 2 points d'indices */
/*             NBPNTU-II+1 et II, pour II = 1, NBPNTU/2 sur l'iso-U0. */
/*     SOTBU2: Tableau des NBPNTU/2 sommes des 2 points d'indices */
/*             NBPNTU-II+1 et II, pour II = 1, NBPNTU/2 sur l'iso-U1. */
/*     DITBU1: Tableau des NBPNTU/2 differences des 2 points d'indices */
/*             NBPNTU-II+1 et II, pour II = 1, NBPNTU/2 sur l'iso-U0. */
/*     DITBU2: Tableau des NBPNTU/2 differences des 2 points d'indices */
/*             NBPNTU-II+1 et II, pour II = 1, NBPNTU/2 sur l'iso-U1. */
/*     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 : */
/*     ------------------- */
/*     FPNTAB: Tableau auxiliaire. */
/*     UHERMT: Table des 2*(IORDRU+1) coeff. des 2*(IORDRU+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   : */
/*     -------------------------------- */
/*     08-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;
    uhermt_dim1 = (*iordru << 1) + 2;
    uhermt_offset = uhermt_dim1;
    uhermt -= uhermt_offset;
    fpntab_dim1 = *nbpntu;
    fpntab_offset = fpntab_dim1 + 1;
    fpntab -= fpntab_offset;
    ditbu2_dim1 = *nbpntv / 2 + 1;
    ditbu2_dim2 = *ndimen;
    ditbu2_offset = ditbu2_dim1 * (ditbu2_dim2 + 1);
    ditbu2 -= ditbu2_offset;
    ditbu1_dim1 = *nbpntv / 2 + 1;
    ditbu1_dim2 = *ndimen;
    ditbu1_offset = ditbu1_dim1 * (ditbu1_dim2 + 1);
    ditbu1 -= ditbu1_offset;
    sotbu2_dim1 = *nbpntv / 2 + 1;
    sotbu2_dim2 = *ndimen;
    sotbu2_offset = sotbu2_dim1 * (sotbu2_dim2 + 1);
    sotbu2 -= sotbu2_offset;
    sotbu1_dim1 = *nbpntv / 2 + 1;
    sotbu1_dim2 = *ndimen;
    sotbu1_offset = sotbu1_dim1 * (sotbu1_dim2 + 1);
    sotbu1 -= sotbu1_offset;

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

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

    ncfhu = (*iordru + 1) << 1;
    i__1 = ncfhu;
    for (ii = 1; ii <= i__1; ++ii) {
	i__2 = *nbpntu;
	for (kk = 1; kk <= i__2; ++kk) {
	    mmmpocur_(&ncfhu, &c__1, &ncfhu, &uhermt[ii * uhermt_dim1], &
		    urootl[kk], &fpntab[kk + ii * fpntab_dim1]);
/* L60: */
	}
/* L50: */
    }

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

    nvroo = *nbpntv / 2;
    nuroo = *nbpntu / 2;

    i__1 = *ndimen;
    for (nd = 1; nd <= i__1; ++nd) {
	i__2 = *iordru + 1;
	for (ii = 1; ii <= i__2; ++ii) {

	    i__3 = nvroo;
	    for (jj = 1; jj <= i__3; ++jj) {
		bid1 = sotbu1[jj + (nd + ii * sotbu1_dim2) * sotbu1_dim1];
		bid2 = sotbu2[jj + (nd + ii * sotbu2_dim2) * sotbu2_dim1];
		bid3 = ditbu1[jj + (nd + ii * ditbu1_dim2) * ditbu1_dim1];
		bid4 = ditbu2[jj + (nd + ii * ditbu2_dim2) * ditbu2_dim1];
		i__4 = nuroo;
		for (kk = 1; kk <= i__4; ++kk) {
		    kkp = (*nbpntu + 1) / 2 + kk;
		    kkm = nuroo - kk + 1;
		    sosotb[kk + (jj + nd * sosotb_dim2) * sosotb_dim1] = 
			    sosotb[kk + (jj + nd * sosotb_dim2) * sosotb_dim1]
			     - bid1 * (fpntab[kkp + ((ii << 1) - 1) * 
			    fpntab_dim1] + fpntab[kkm + ((ii << 1) - 1) * 
			    fpntab_dim1]) - bid2 * (fpntab[kkp + (ii << 1) * 
			    fpntab_dim1] + fpntab[kkm + (ii << 1) * 
			    fpntab_dim1]);
		    disotb[kk + (jj + nd * disotb_dim2) * disotb_dim1] = 
			    disotb[kk + (jj + nd * disotb_dim2) * disotb_dim1]
			     - bid1 * (fpntab[kkp + ((ii << 1) - 1) * 
			    fpntab_dim1] - fpntab[kkm + ((ii << 1) - 1) * 
			    fpntab_dim1]) - bid2 * (fpntab[kkp + (ii << 1) * 
			    fpntab_dim1] - fpntab[kkm + (ii << 1) * 
			    fpntab_dim1]);
		    soditb[kk + (jj + nd * soditb_dim2) * soditb_dim1] = 
			    soditb[kk + (jj + nd * soditb_dim2) * soditb_dim1]
			     - bid3 * (fpntab[kkp + ((ii << 1) - 1) * 
			    fpntab_dim1] + fpntab[kkm + ((ii << 1) - 1) * 
			    fpntab_dim1]) - bid4 * (fpntab[kkp + (ii << 1) * 
			    fpntab_dim1] + fpntab[kkm + (ii << 1) * 
			    fpntab_dim1]);
		    diditb[kk + (jj + nd * diditb_dim2) * diditb_dim1] = 
			    diditb[kk + (jj + nd * diditb_dim2) * diditb_dim1]
			     - bid3 * (fpntab[kkp + ((ii << 1) - 1) * 
			    fpntab_dim1] - fpntab[kkm + ((ii << 1) - 1) * 
			    fpntab_dim1]) - bid4 * (fpntab[kkp + (ii << 1) * 
			    fpntab_dim1] - fpntab[kkm + (ii << 1) * 
			    fpntab_dim1]);
/* L400: */
		}
/* L300: */
	    }
/* L200: */
	}

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

	if (*nbpntu % 2 == 1) {
	    i__2 = *iordru + 1;
	    for (ii = 1; ii <= i__2; ++ii) {
		i__3 = nvroo;
		for (jj = 1; jj <= i__3; ++jj) {
		    bid1 = sotbu1[jj + (nd + ii * sotbu1_dim2) * sotbu1_dim1] 
			    * fpntab[nuroo + 1 + ((ii << 1) - 1) * 
			    fpntab_dim1] + sotbu2[jj + (nd + ii * sotbu2_dim2)
			     * sotbu2_dim1] * fpntab[nuroo + 1 + (ii << 1) * 
			    fpntab_dim1];
		    sosotb[(jj + nd * sosotb_dim2) * sosotb_dim1] -= bid1;
		    bid2 = ditbu1[jj + (nd + ii * ditbu1_dim2) * ditbu1_dim1] 
			    * fpntab[nuroo + 1 + ((ii << 1) - 1) * 
			    fpntab_dim1] + ditbu2[jj + (nd + ii * ditbu2_dim2)
			     * ditbu2_dim1] * fpntab[nuroo + 1 + (ii << 1) * 
			    fpntab_dim1];
		    diditb[(jj + nd * diditb_dim2) * diditb_dim1] -= bid2;
/* L550: */
		}
/* L500: */
	    }
	}

	if (*nbpntv % 2 == 1) {
	    i__2 = *iordru + 1;
	    for (ii = 1; ii <= i__2; ++ii) {
		i__3 = nuroo;
		for (kk = 1; kk <= i__3; ++kk) {
		    kkp = (*nbpntu + 1) / 2 + kk;
		    kkm = nuroo - kk + 1;
		    bid1 = sotbu1[(nd + ii * sotbu1_dim2) * sotbu1_dim1] * (
			    fpntab[kkp + ((ii << 1) - 1) * fpntab_dim1] + 
			    fpntab[kkm + ((ii << 1) - 1) * fpntab_dim1]) + 
			    sotbu2[(nd + ii * sotbu2_dim2) * sotbu2_dim1] * (
			    fpntab[kkp + (ii << 1) * fpntab_dim1] + fpntab[
			    kkm + (ii << 1) * fpntab_dim1]);
		    sosotb[kk + nd * sosotb_dim2 * sosotb_dim1] -= bid1;
		    bid2 = sotbu1[(nd + ii * sotbu1_dim2) * sotbu1_dim1] * (
			    fpntab[kkp + ((ii << 1) - 1) * fpntab_dim1] - 
			    fpntab[kkm + ((ii << 1) - 1) * fpntab_dim1]) + 
			    sotbu2[(nd + ii * sotbu2_dim2) * sotbu2_dim1] * (
			    fpntab[kkp + (ii << 1) * fpntab_dim1] - fpntab[
			    kkm + (ii << 1) * fpntab_dim1]);
		    diditb[kk + nd * diditb_dim2 * diditb_dim1] -= bid2;
/* L650: */
		}
/* L600: */
	    }
	}

	if (*nbpntu % 2 == 1 && *nbpntv % 2 == 1) {
	    i__2 = *iordru + 1;
	    for (ii = 1; ii <= i__2; ++ii) {
		bid1 = sotbu1[(nd + ii * sotbu1_dim2) * sotbu1_dim1] * fpntab[
			nuroo + 1 + ((ii << 1) - 1) * fpntab_dim1] + sotbu2[(
			nd + ii * sotbu2_dim2) * sotbu2_dim1] * fpntab[nuroo 
			+ 1 + (ii << 1) * fpntab_dim1];
		sosotb[nd * sosotb_dim2 * sosotb_dim1] -= bid1;
/* L700: */
	    }
	}

/* L100: */
    }
    goto L9999;

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

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

