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

/* Subroutine */ int mmasemg_(ndimen, npoint, nptcnt, ndecop, ncoefs, ordher, 
	dimmat, nistoc, cblong, tparam, tpospt, tdecop, typcnt, tabcnt, 
	tasemh, tasemg, aposit, tpoint, ttheta, tfthet, hdecal, matsys, 
	vecsys, iercod)
integer *ndimen, *npoint, *nptcnt, *ndecop, *ncoefs, *ordher, *dimmat, *
	nistoc;
doublereal *cblong, *tparam;
integer *tpospt;
doublereal *tdecop;
integer *typcnt;
doublereal *tabcnt;
integer *tasemh, *tasemg, *aposit;
doublereal *tpoint, *ttheta, *tfthet;
integer *hdecal;
doublereal *matsys, *vecsys;
integer *iercod;
{
    /* System generated locals */
    integer tasemh_dim1, tasemh_offset, tasemg_dim1, tasemg_offset, 
	    tabcnt_dim1, tabcnt_offset, tpoint_dim1, tpoint_offset, 
	    ttheta_dim1, ttheta_dim2, ttheta_offset, tfthet_dim1, tfthet_dim2,
	     tfthet_offset, i__1, i__2, i__3, i__4;
    doublereal d__1;

    /* Builtin functions */
    double pow__di();

    /* Local variables */
    static logical ldbg;
    static doublereal base[90];
    static integer d__, e, i__, j, k;
    static doublereal delta, mfact;
    static integer nderi, order, istoc;
    static doublereal mfact1, mfact2;
    static integer jg, dimbas;
    static doublereal ps, sparam, ctenor;
    static integer ig0, ig1, ig2, ig3, ier;
    extern integer mnfndeb_();
    extern /* Subroutine */ int maermsg_(), mgenmsg_(), mmpobas_(), mgsomsg_()
	    , mvriraz_();
    static integer aux1, aux2, aux3;



/* < */
/* **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 : */
/*     ---------- */
/*       ASSEMBLAGE DES CONTRAINTES */

/*     MOTS CLES : */
/*     ----------- */
/*      RESERVE, LISSAGE, CONTRAINTES, ASSEMBLAGE */

/*     ARGUMENTS D'ENTREE : */
/*     -------------------- */
/*       NDIMEN : Dimension de l'espace */
/*       NPOINT : NOMBRE DE POINTS */
/*       NPTCNT : NOMBRE DE POINTS CONTRAINTS */
/*       NDECOP :  NOMBRE DE DECOUPE */
/*       NCOEFS : Nombre de coeff des "courbes" polynomiales */
/*                d' approximation. */
/*       ORDHER : ORDRE D'HERMITE */
/*       DIMMAT : NOMBRE DE LIGNE DE LA MATRICE DES CONTRAINTES */
/*       NISTOC : NOMBRE DE TERMES DU PROFIL DE LA MATRICE DES */
/*                CONTRAINTES */
/*       CBLONG : LONGUEUR ESTIMEE DE LA COURBE */
/*       TPARAM : PARAMETRES DES POINTS */
/*       TPOSPT : TABLE PERMETTANT DE SITUER LES POINTS PAR RAPPORT */
/*                AUX ELEMENT DE LA DECOUPE */
/*       TDECOP : TABLE DE DECOUPE */
/*       TYPCNT(1,i) :  Indice du point contraints */
/*       TYPCNT(2,i) :  Type de la contrainte */
/*                           0 -> de passage (G0) */
/*                           1 -> de tangence (G1) */
/*                           2 -> de courbure (G2) */
/*       TABCNT(*,1,i) : Vecteur tangent a respecter */
/*       TABCNT(*,2,i) : Vecteur courbure a respecter */
/*       TASEMH: TABLE D'ASSEMBLAGE DE LA MATRICE HESSIENNE */
/*       TASEMG: TABLE  D'ASSEMBLAGE DE LA MATRICE DES CONTRAINTES */
/*       APOSIT: TABLE DE POSITIONNEMENT DE LA MATRICE DES CONTRAINTES */
/*       TPOINT : TABLE DES POINTS */
/*       TTHETA(*,1,I) : VECTEUR THETA1 SERVANT A EXPRIMER LES */
/*                       CONTRAINTES DE TANGENCE ET DE COURBURE */
/*                       AU POINT Pi */
/*       TTHETA(*,2,I) : VECTEUR THETA2 SERVANT A EXPRIMER LES */
/*                       CONTRAINTES DE TANGENCE ET DE COURBURE */
/*                       AU POINT Pi, SI NDIMEM=3 */
/*       TFTHET(*,J,I) : VECTEUR FONCTION DE THETAJ SERVANYT A EXPRIMER */
/*                       LES CONTRAINTES DE COURBURE */
/*       HDECAL : DECALLAGE PERMETTANT LE CALCUL DES INDICES GLOGAUX DE */
/*                LA MATRICE HESSIENNE */



/*     ARGUMENTS DE SORTIE : */
/*     --------------------- */
/*       MATSYS : LA MATRICE DES CONTRAINTES SOUS FORME DE PROFIL */
/*       VECSYS : LE VECTEUR DU SECOND MEMBRE ASSOCIE */
/*       IERCOD : CODE D'ERREUR */
/*     COMMONS UTILISES : */
/*     ------------------ */


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


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


/* $    HISTORIQUE DES MODIFICATIONS : */
/*     ------------------------------ */
/*      9-10-95 : PMN; On remplace les contraintes G1 par des contraintes 
*/
/*                     C1 */
/*     21-09-95 : KHN; ECRITURE VERSION ORIGINALE. */
/* > */
/* ***********************************************************************
 */
/*                            DECLARATIONS */
/* ***********************************************************************
 */




/* ***********************************************************************
 */
/*                      INITIALISATIONS */
/* ***********************************************************************
 */

    /* Parameter adjustments */
    tfthet_dim1 = *ndimen;
    tfthet_dim2 = *ndimen - 1;
    tfthet_offset = tfthet_dim1 * (tfthet_dim2 + 1) + 1;
    tfthet -= tfthet_offset;
    ttheta_dim1 = *ndimen;
    ttheta_dim2 = *ndimen - 1;
    ttheta_offset = ttheta_dim1 * (ttheta_dim2 + 1) + 1;
    ttheta -= ttheta_offset;
    tasemg_dim1 = *ndimen;
    tasemg_offset = (tasemg_dim1 << 2) + 1;
    tasemg -= tasemg_offset;
    tabcnt_dim1 = *ndimen;
    tabcnt_offset = tabcnt_dim1 * 3 + 1;
    tabcnt -= tabcnt_offset;
    tpoint_dim1 = *ndimen;
    tpoint_offset = tpoint_dim1 + 1;
    tpoint -= tpoint_offset;
    --tpospt;
    --tparam;
    tasemh_dim1 = *ndecop;
    tasemh_offset = tasemh_dim1 + 1;
    tasemh -= tasemh_offset;
    --vecsys;
    aposit -= 4;
    --matsys;
    typcnt -= 3;

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

/* ***********************************************************************
 */
/*                     TRAITEMENT */
/* ***********************************************************************
 */

    if (*ndimen <= 1 || *ndimen > 3) {
	goto L9101;
    }

    dimbas = *ncoefs * 3;
    if (dimbas > 90) {
	goto L9101;
    }

    mvriraz_(nistoc, &matsys[1]);
    mvriraz_(dimmat, &vecsys[1]);

    aux1 = *ordher + 1;
    aux3 = aux1 + 1;
    aux2 = aux1 << 1;

/*    I */

/*   ASSEMBLAGE DES CONTRAINTES DE PASSAGE ET C1 */
/*               ET LA PARTIE DU VECTEUR DU SECOND MEMBRE ASSOCIEE */

    i__1 = *nptcnt;
    for (i__ = 1; i__ <= i__1; ++i__) {

	e = tpospt[typcnt[(i__ << 1) + 1]];

/*        CALCUL LES ELEMENT DE LA BASE HERMITE JACOBI */

	nderi = typcnt[(i__ << 1) + 2];
	sparam = tparam[typcnt[(i__ << 1) + 1]] * 2 - tdecop[e - 1] - tdecop[
		e];
	sparam /= tdecop[e] - tdecop[e - 1];

	mmpobas_(&sparam, ordher, ncoefs, &nderi, base, &ier);
	if (ier > 0) {
	    goto L9101;
	}

/*        CTE DE NORMALISATION */

	ctenor = (tdecop[e] - tdecop[e - 1]) / 2;

/*        ASSEMBLER LES CONTRAINTES DE PASSAGE ET C1 */

	i__2 = *ndimen;
	for (d__ = 1; d__ <= i__2; ++d__) {
	    ig0 = tasemg[d__ + (i__ << 2) * tasemg_dim1];
	    ig3 = tasemg[d__ + ((i__ << 2) + 3) * tasemg_dim1];
	    i__3 = *ncoefs;
	    for (j = 1; j <= i__3; ++j) {
		jg = tasemh[e + j * tasemh_dim1] + (d__ - 1) * *hdecal;



/*        CALCUL LE MFACTEUR DES HERMITES */

		if (j <= aux1) {
		    order = j - 1;
		} else {
		    if (j <= aux2) {
			order = j - aux3;
		    } else {
			order = 0;
		    }
		}
		mfact = pow__di(&ctenor, &order);

/*        CALCUL L'INDICE DE STOCKAGE DE LA CONTRAINTE DE PASS
AGE */
/*        PUIS STOCKER DANS MATSYS */

		istoc = aposit[ig0 * 3 + 2] - aposit[ig0 * 3 + 1] + jg - 
			aposit[ig0 * 3 + 3] + 1;
		matsys[istoc] += base[j - 1] * mfact;

/*        CAS DES CONTRAINTES  C1 */

		if (ig3 > 0) {
		    mfact /= ctenor;
		    istoc = aposit[ig3 * 3 + 2] - aposit[ig3 * 3 + 1] + jg - 
			    aposit[ig3 * 3 + 3] + 1;
		    matsys[istoc] += base[j + *ncoefs - 1] * mfact;
		}



	    }

/*       ASSEMBLER LE VECTEUR DU SECOND MEMBRE POUR LA PARTIE */
/*       LIEE A DES CONTRAINTES DE PASSAGE */
/*       PUIS POUR LA PARTIE LIEE A DES CONTRAINTES C1 */

	    vecsys[ig0] += tpoint[d__ + typcnt[(i__ << 1) + 1] * tpoint_dim1];
	    if (ig3 > 0) {
		delta = *cblong;
		vecsys[ig3] += delta * tabcnt[d__ + ((i__ << 1) + 1) * 
			tabcnt_dim1];
	    }
	}



/*      II */

/*       ASEMBLAGE DES CONTRAINTES DE TANGENCE ET DE COURBURE */
/*       ET LA PARTIE DU VECTEUR DU SECOND MEMBRE CORRESPONDANTE */


/*      D EST L'INDICE DE THETA 1 OU 2 */

	i__2 = *ndimen - 1;
	for (d__ = 1; d__ <= i__2; ++d__) {
	    ig1 = tasemg[d__ + ((i__ << 2) + 1) * tasemg_dim1];
	    ig2 = tasemg[d__ + ((i__ << 2) + 2) * tasemg_dim1];
	    if (ig1 > 0 || ig2 > 0) {
		i__3 = *ndimen;
		for (k = 1; k <= i__3; ++k) {
		    i__4 = *ncoefs;
		    for (j = 1; j <= i__4; ++j) {
			jg = tasemh[e + j * tasemh_dim1] + *hdecal * (k - 1);

/*       MFACTEURS DE NORMALISATION MFACT1 POUR TANGEN
CE */
/*                               MFACT2 POUR COURBURE 
*/

			if (j <= aux1) {
			    order = j - 1;
			} else {
			    if (j <= aux2) {
				order = j - aux3;
			    } else {
				order = 0;
			    }
			}
			--order;
			mfact1 = pow__di(&ctenor, &order);
			mfact2 = mfact1 / ctenor;


/*       CALCUL L'INDICE DE STOCKAGE POUR LA CONTRAINT
E DE TANGENCE */
/*       PUIS  STOCKER */

			if (ig1 > 0) {
			    istoc = aposit[ig1 * 3 + 2] - aposit[ig1 * 3 + 1] 
				    + jg - aposit[ig1 * 3 + 3] + 1;
			    matsys[istoc] += base[j + *ncoefs - 1] * mfact1 * 
				    ttheta[k + (d__ + i__ * ttheta_dim2) * 
				    ttheta_dim1];
			}

/*       CAS DES CONTRAINTES DE COURBURE */

			if (ig2 > 0) {
			    istoc = aposit[ig2 * 3 + 2] - aposit[ig2 * 3 + 1] 
				    + jg - aposit[ig2 * 3 + 3] + 1;
			    matsys[istoc] += base[j + (*ncoefs << 1) - 1] * 
				    mfact2 * tfthet[k + (d__ + i__ * 
				    tfthet_dim2) * tfthet_dim1];
			}
		    }

		}

/*       STOCKAGE DU VECTEUR DU SECOND MEMBRE : */
/*       PARTIE LIEE A DES CONTRAINTES DE COURBURE */
/*        LA PARTIE LIEE A DES CONTRAINTES DE TANGENCE ETANT N
ULLE */

		if (ig2 > 0) {
		    delta = *cblong;
		    ps = 0.;
		    i__3 = *ndimen;
		    for (k = 1; k <= i__3; ++k) {
			ps += tabcnt[k + ((i__ << 1) + 2) * tabcnt_dim1] * 
				ttheta[k + (d__ + i__ * ttheta_dim2) * 
				ttheta_dim1];
		    }
/* Computing 2nd power */
		    d__1 = delta;
		    vecsys[ig2] += d__1 * d__1 * ps;
		}
	    }
	}
    }



    goto L9999;

/* ***********************************************************************
 */
/*                   TRAITEMENT DES ERREURS */
/* ***********************************************************************
 */


L9101:
    *iercod = 1;
    goto L9999;

/* ***********************************************************************
 */
/*                   RETOUR PROGRAMME APPELANT */
/* ***********************************************************************
 */

L9999:

    maermsg_("MMASEMG", iercod, 7L);
    if (ldbg) {
	mgsomsg_("MMASEMG", 7L);
    }
 return 0 ;
} /* mmasemg_ */

