/* MA2CD2.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 mma2cd2_(ndimen, nbpntu, nbpntv, vrootl, iordrv, sotbv1, 
	sotbv2, ditbv1, ditbv2, fpntab, vhermt, sosotb, soditb, disotb, 
	diditb)
integer *ndimen, *nbpntu, *nbpntv;
doublereal *vrootl;
integer *iordrv;
doublereal *sotbv1, *sotbv2, *ditbv1, *ditbv2, *fpntab, *vhermt, *sosotb, *
	soditb, *disotb, *diditb;
{
    /* System generated locals */
    integer sotbv1_dim1, sotbv1_dim2, sotbv1_offset, sotbv2_dim1, sotbv2_dim2,
	     sotbv2_offset, ditbv1_dim1, ditbv1_dim2, ditbv1_offset, 
	    ditbv2_dim1, ditbv2_dim2, ditbv2_offset, fpntab_dim1, 
	    fpntab_offset, vhermt_dim1, vhermt_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 ncfhv, nuroo, nvroo, ii, nd, jj, kk, ibb, jjm, jjp;
    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-V a l'ordre IORDRV. */

/*     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. */
/*     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. 
*/
/*     IORDRV: Ordre de derivation de l'iso-V */
/*             = 0, on calcule l'iso-V. */
/*             = 1, on calcule, en plus, la derivee 1ere dans le sens */
/*                  transverse a l'iso-V (donc en V). */
/*             = 2, on calcule, en plus, la derivee 2nde dans le sens */
/*                  transverse a l'iso-V (donc en V). */
/*     SOTBV1: Tableau des NBPNTV/2 sommes des 2 points d'indices */
/*             NBPNTV-II+1 et II, pour II = 1, NBPNTV/2 sur l'iso-V0. */
/*     SOTBV2: Tableau des NBPNTV/2 sommes des 2 points d'indices */
/*             NBPNTV-II+1 et II, pour II = 1, NBPNTV/2 sur l'iso-V1. */
/*     DITBV1: Tableau des NBPNTV/2 differences des 2 points d'indices */
/*             NBPNTV-II+1 et II, pour II = 1, NBPNTV/2 sur l'iso-V0. */
/*     DITBV2: Tableau des NBPNTV/2 differences des 2 points d'indices */
/*             NBPNTV-II+1 et II, pour II = 1, NBPNTV/2 sur l'iso-V1. */
/*     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. */
/*     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   : */
/*     -------------------------------- */
/*     08-08-1991: RBD; Creation. */
/* > */
/* ********************************************************************** 
*/

/*   Le nom de la routine */


    /* Parameter adjustments */
    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;
    vhermt_dim1 = (*iordrv << 1) + 2;
    vhermt_offset = vhermt_dim1;
    vhermt -= vhermt_offset;
    fpntab_dim1 = *nbpntv;
    fpntab_offset = fpntab_dim1 + 1;
    fpntab -= fpntab_offset;
    ditbv2_dim1 = *nbpntu / 2 + 1;
    ditbv2_dim2 = *ndimen;
    ditbv2_offset = ditbv2_dim1 * (ditbv2_dim2 + 1);
    ditbv2 -= ditbv2_offset;
    ditbv1_dim1 = *nbpntu / 2 + 1;
    ditbv1_dim2 = *ndimen;
    ditbv1_offset = ditbv1_dim1 * (ditbv1_dim2 + 1);
    ditbv1 -= ditbv1_offset;
    sotbv2_dim1 = *nbpntu / 2 + 1;
    sotbv2_dim2 = *ndimen;
    sotbv2_offset = sotbv2_dim1 * (sotbv2_dim2 + 1);
    sotbv2 -= sotbv2_offset;
    sotbv1_dim1 = *nbpntu / 2 + 1;
    sotbv1_dim2 = *ndimen;
    sotbv1_offset = sotbv1_dim1 * (sotbv1_dim2 + 1);
    sotbv1 -= sotbv1_offset;

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

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

    ncfhv = (*iordrv + 1) << 1;
    i__1 = ncfhv;
    for (ii = 1; ii <= i__1; ++ii) {
	i__2 = *nbpntv;
	for (jj = 1; jj <= i__2; ++jj) {
	    mmmpocur_(&ncfhv, &c__1, &ncfhv, &vhermt[ii * vhermt_dim1], &
		    vrootl[jj], &fpntab[jj + ii * fpntab_dim1]);
/* L60: */
	}
/* L50: */
    }

/* ---- 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 (ii = 1; ii <= i__2; ++ii) {

	    i__3 = nuroo;
	    for (kk = 1; kk <= i__3; ++kk) {
		bid1 = sotbv1[kk + (nd + ii * sotbv1_dim2) * sotbv1_dim1];
		bid2 = sotbv2[kk + (nd + ii * sotbv2_dim2) * sotbv2_dim1];
		bid3 = ditbv1[kk + (nd + ii * ditbv1_dim2) * ditbv1_dim1];
		bid4 = ditbv2[kk + (nd + ii * ditbv2_dim2) * ditbv2_dim1];
		i__4 = nvroo;
		for (jj = 1; jj <= i__4; ++jj) {
		    jjp = (*nbpntv + 1) / 2 + jj;
		    jjm = nvroo - jj + 1;
		    sosotb[kk + (jj + nd * sosotb_dim2) * sosotb_dim1] = 
			    sosotb[kk + (jj + nd * sosotb_dim2) * sosotb_dim1]
			     - bid1 * (fpntab[jjp + ((ii << 1) - 1) * 
			    fpntab_dim1] + fpntab[jjm + ((ii << 1) - 1) * 
			    fpntab_dim1]) - bid2 * (fpntab[jjp + (ii << 1) * 
			    fpntab_dim1] + fpntab[jjm + (ii << 1) * 
			    fpntab_dim1]);
		    disotb[kk + (jj + nd * disotb_dim2) * disotb_dim1] = 
			    disotb[kk + (jj + nd * disotb_dim2) * disotb_dim1]
			     - bid3 * (fpntab[jjp + ((ii << 1) - 1) * 
			    fpntab_dim1] + fpntab[jjm + ((ii << 1) - 1) * 
			    fpntab_dim1]) - bid4 * (fpntab[jjp + (ii << 1) * 
			    fpntab_dim1] + fpntab[jjm + (ii << 1) * 
			    fpntab_dim1]);
		    soditb[kk + (jj + nd * soditb_dim2) * soditb_dim1] = 
			    soditb[kk + (jj + nd * soditb_dim2) * soditb_dim1]
			     - bid1 * (fpntab[jjp + ((ii << 1) - 1) * 
			    fpntab_dim1] - fpntab[jjm + ((ii << 1) - 1) * 
			    fpntab_dim1]) - bid2 * (fpntab[jjp + (ii << 1) * 
			    fpntab_dim1] - fpntab[jjm + (ii << 1) * 
			    fpntab_dim1]);
		    diditb[kk + (jj + nd * diditb_dim2) * diditb_dim1] = 
			    diditb[kk + (jj + nd * diditb_dim2) * diditb_dim1]
			     - bid3 * (fpntab[jjp + ((ii << 1) - 1) * 
			    fpntab_dim1] - fpntab[jjm + ((ii << 1) - 1) * 
			    fpntab_dim1]) - bid4 * (fpntab[jjp + (ii << 1) * 
			    fpntab_dim1] - fpntab[jjm + (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 (*nbpntv % 2 == 1) {
	    i__2 = *iordrv + 1;
	    for (ii = 1; ii <= i__2; ++ii) {
		i__3 = nuroo;
		for (kk = 1; kk <= i__3; ++kk) {
		    bid1 = sotbv1[kk + (nd + ii * sotbv1_dim2) * sotbv1_dim1] 
			    * fpntab[nvroo + 1 + ((ii << 1) - 1) * 
			    fpntab_dim1] + sotbv2[kk + (nd + ii * sotbv2_dim2)
			     * sotbv2_dim1] * fpntab[nvroo + 1 + (ii << 1) * 
			    fpntab_dim1];
		    sosotb[kk + nd * sosotb_dim2 * sosotb_dim1] -= bid1;
		    bid2 = ditbv1[kk + (nd + ii * ditbv1_dim2) * ditbv1_dim1] 
			    * fpntab[nvroo + 1 + ((ii << 1) - 1) * 
			    fpntab_dim1] + ditbv2[kk + (nd + ii * ditbv2_dim2)
			     * ditbv2_dim1] * fpntab[nvroo + 1 + (ii << 1) * 
			    fpntab_dim1];
		    diditb[kk + nd * diditb_dim2 * diditb_dim1] -= bid2;
/* L550: */
		}
/* L500: */
	    }
	}

	if (*nbpntu % 2 == 1) {
	    i__2 = *iordrv + 1;
	    for (ii = 1; ii <= i__2; ++ii) {
		i__3 = nvroo;
		for (jj = 1; jj <= i__3; ++jj) {
		    jjp = (*nbpntv + 1) / 2 + jj;
		    jjm = nvroo - jj + 1;
		    bid1 = sotbv1[(nd + ii * sotbv1_dim2) * sotbv1_dim1] * (
			    fpntab[jjp + ((ii << 1) - 1) * fpntab_dim1] + 
			    fpntab[jjm + ((ii << 1) - 1) * fpntab_dim1]) + 
			    sotbv2[(nd + ii * sotbv2_dim2) * sotbv2_dim1] * (
			    fpntab[jjp + (ii << 1) * fpntab_dim1] + fpntab[
			    jjm + (ii << 1) * fpntab_dim1]);
		    sosotb[(jj + nd * sosotb_dim2) * sosotb_dim1] -= bid1;
		    bid2 = sotbv1[(nd + ii * sotbv1_dim2) * sotbv1_dim1] * (
			    fpntab[jjp + ((ii << 1) - 1) * fpntab_dim1] - 
			    fpntab[jjm + ((ii << 1) - 1) * fpntab_dim1]) + 
			    sotbv2[(nd + ii * sotbv2_dim2) * sotbv2_dim1] * (
			    fpntab[jjp + (ii << 1) * fpntab_dim1] - fpntab[
			    jjm + (ii << 1) * fpntab_dim1]);
		    diditb[jj + nd * diditb_dim2 * diditb_dim1] -= bid2;
/* L650: */
		}
/* L600: */
	    }
	}

	if (*nbpntu % 2 == 1 && *nbpntv % 2 == 1) {
	    i__2 = *iordrv + 1;
	    for (ii = 1; ii <= i__2; ++ii) {
		bid1 = sotbv1[(nd + ii * sotbv1_dim2) * sotbv1_dim1] * fpntab[
			nvroo + 1 + ((ii << 1) - 1) * fpntab_dim1] + sotbv2[(
			nd + ii * sotbv2_dim2) * sotbv2_dim1] * fpntab[nvroo 
			+ 1 + (ii << 1) * fpntab_dim1];
		sosotb[nd * sosotb_dim2 * sosotb_dim1] -= bid1;
/* L700: */
	    }
	}

/* L100: */
    }
    goto L9999;

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

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

