/* MA2AC1.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"
#ifdef WNT
#include <ApproxF2var.h>
#endif
/* Subroutine */ int mma2ac1_(ndimen, mxujac, mxvjac, iordru, iordrv, contr1, 
	contr2, contr3, contr4, uhermt, vhermt, patjac)
integer const *ndimen, *mxujac, *mxvjac, *iordru, *iordrv;
doublereal const *contr1, *contr2, *contr3, *contr4, *uhermt, *vhermt;
doublereal *patjac;
{
    /* 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, patjac_dim1, 
	    patjac_dim2, patjac_offset, i__1, i__2, i__3, i__4, i__5;

    /* Local variables */
    static logical ldbg;
    static integer ndgu, ndgv;
    static doublereal bidu1, bidu2, bidv1, bidv2;
    static integer ioru1, iorv1, ii, nd, jj, ku, kv;
    extern integer mnfndeb_();
    extern /* Subroutine */ int mgenmsg_(), mgsomsg_();
    static doublereal cnt1, cnt2, cnt3, cnt4;




/* < */
/* **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 : */
/*     ---------- */
/*     Ajout des polynomes de contraintes des coins. */

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

/*     ARGUMENTS D'ENTREE : */
/*     ------------------ */
/*   NDIMEN: Dimension de l'espace. */
/*   MXUJAC: Degre maxi du polynome d' approximation en U. La */
/*           representation dans la base orthogonale part du degre */
/*           0 au degre MXUJAC-2*(IORDRU+1). La base polynomiale est */
/*           la base de Jacobi d' ordre -1 (Legendre), 0, 1 ou 2 */
/*   MXVJAC: Degre maxi du polynome d' approximation en V. La */
/*           representation dans la base orthogonale part du degre */
/*           0 au degre MXVJAC-2*(IORDRV+1). La base polynomiale est */
/*           la base de Jacobi d' ordre -1 (Legendre), 0, 1 ou 2 */
/*   IORDRU: Ordre de la base de Jacobi (-1,0,1 ou 2) en U. Correspond */
/*           a pas de contraintes, contraintes C0, C1 ou C2. */
/*   IORDRV: Ordre de la base de Jacobi (-1,0,1 ou 2) en V. Correspond */
/*           a pas de contraintes, contraintes C0, C1 ou C2. */
/*   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. */
/*   UHERMT: Coeff. des polynomes d'Hermite d'ordre IORDRU. */
/*   VHERMT: Coeff. des polynomes d'Hermite d'ordre IORDRV. */
/*   PATJAC: Table des coefficients du polynome P(u,v) d' approximation */
/*           de F(u,v) SANS prise en compte des contraintes. */

/*     ARGUMENTS DE SORTIE : */
/*     ------------------- */
/*   PATJAC: Table des coefficients du polynome P(u,v) d' approximation */
/*           de F(u,v) AVEC prise en compte des contraintes. */

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

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

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

/* $    HISTORIQUE DES MODIFICATIONS   : */
/*     -------------------------------- */
/*     06-02-1992: RBD; Creation d'apres MA2CA1. */
/* > */
/* ********************************************************************** 
*/
/*   Le nom de la routine */

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

    /* Parameter adjustments */
    patjac_dim1 = *mxujac + 1;
    patjac_dim2 = *mxvjac + 1;
    patjac_offset = patjac_dim1 * patjac_dim2;
    patjac -= patjac_offset;
    uhermt_dim1 = (*iordru << 1) + 2;
    uhermt_offset = uhermt_dim1;
    uhermt -= uhermt_offset;
    vhermt_dim1 = (*iordrv << 1) + 2;
    vhermt_offset = vhermt_dim1;
    vhermt -= vhermt_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 */
    ldbg = mnfndeb_() >= 3;
    if (ldbg) {
	mgenmsg_("MMA2AC1", 7L);
    }

/* ------------ SOUSTRACTION des CONTRAINTES DE COINS ------------------- 
*/

    ioru1 = *iordru + 1;
    iorv1 = *iordrv + 1;
    ndgu = (*iordru << 1) + 1;
    ndgv = (*iordrv << 1) + 1;

    i__1 = iorv1;
    for (jj = 1; jj <= i__1; ++jj) {
	i__2 = ioru1;
	for (ii = 1; ii <= i__2; ++ii) {
	    i__3 = *ndimen;
	    for (nd = 1; nd <= i__3; ++nd) {
		cnt1 = contr1[nd + (ii + jj * contr1_dim2) * contr1_dim1];
		cnt2 = contr2[nd + (ii + jj * contr2_dim2) * contr2_dim1];
		cnt3 = contr3[nd + (ii + jj * contr3_dim2) * contr3_dim1];
		cnt4 = contr4[nd + (ii + jj * contr4_dim2) * contr4_dim1];
		i__4 = ndgv;
		for (kv = 0; kv <= i__4; ++kv) {
		    bidv1 = vhermt[kv + ((jj << 1) - 1) * vhermt_dim1];
		    bidv2 = vhermt[kv + (jj << 1) * vhermt_dim1];
		    i__5 = ndgu;
		    for (ku = 0; ku <= i__5; ++ku) {
			bidu1 = uhermt[ku + ((ii << 1) - 1) * uhermt_dim1];
			bidu2 = uhermt[ku + (ii << 1) * uhermt_dim1];
			patjac[ku + (kv + nd * patjac_dim2) * patjac_dim1] = 
				patjac[ku + (kv + nd * patjac_dim2) * 
				patjac_dim1] - bidu1 * bidv1 * cnt1 - bidu2 * 
				bidv1 * cnt2 - bidu1 * bidv2 * cnt3 - bidu2 * 
				bidv2 * cnt4;
/* L500: */
		    }
/* L400: */
		}
/* L300: */
	    }
/* L200: */
	}
/* L100: */
    }

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

    if (ldbg) {
	mgsomsg_("MMA2AC1", 7L);
    }
    return 0;
} /* mma2ac1_ */

