/* MAJLIS.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"
#include <Data_Data.h>
/* Common Block Declarations */

/*extern __Data_API struct {*/
extern struct {
    doublereal pi, deuxpi, pisur2, pis180, c180pi, zero, one, a180, a360, a90;
} mdnombr_;

#define mdnombr_1 mdnombr_

/*extern __Data_API struct {*/
extern struct {
    integer nbr[1001];
} minombr_;

#define minombr_1 minombr_

/* Table of constant values */

static integer c__30 = 30;
static integer c__500 = 500;
static integer c__100 = 100;

/* Subroutine */ int mmajlis_(ndimen, nbcrmx, ncflim, nbrpnt, nbcntr, orcont, 
	tabpnt, tbpoid, typcnt, tabcnt, tbopnt, matrj1, matrj2, matrj3, 
	vpoids, alpha, jestim, ttheta, tfthet, cblong, tabpar, nbcrbe, ncftab,
	 crbtab, tabint, tbecar, numpnt, errmax, errmoy, valcri, iercod)
integer *ndimen, *nbcrmx, *ncflim, *nbrpnt, *nbcntr, *orcont;
doublereal *tabpnt, *tbpoid;
integer *typcnt;
doublereal *tabcnt, *tbopnt, *matrj1, *matrj2, *matrj3, *vpoids, *alpha, *
	jestim, *ttheta, *tfthet, *cblong, *tabpar;
integer *nbcrbe, *ncftab;
doublereal *crbtab, *tabint, *tbecar;
integer *numpnt;
doublereal *errmax, *errmoy, *valcri;
integer *iercod;
{
    /* Initialized data */

    static integer mxiter = 2;
    static doublereal eps1 = 1e-6;

    /* System generated locals */
    integer tabpnt_dim1, tabpnt_offset, tabcnt_dim1, tabcnt_offset, 
	    ttheta_dim1, ttheta_dim2, ttheta_offset, tfthet_dim1, tfthet_dim2,
	     tfthet_offset, crbtab_dim1, crbtab_dim2, crbtab_offset, i__1;

    /* Builtin functions */
    double sqrt();

    /* Local variables */
    static integer ibid;
    static logical ldbg;
    static integer iter, ipnt;
    static doublereal cbold[500], ecart, emold, erold, tpara;
    static integer cbsiz;
    static doublereal vocri[4], tpold[100], j1cibl, vtest;
    static integer tpsiz, ii, jj, ncbold, ncfold[30];
    /* Les offset en long int pmn */ 
    static long int ioftcb, iofncf, ioftp, iofint;
    static logical lrejet;
    static logical loptim;
    static doublereal vseuil;
    static integer numint, nuold;
    extern /* Subroutine */ int macrai4_(), macrdi4_(), macrar8_(), macrdr8_()
	    , mmsrre2_();
    static integer ier, imp;
    extern integer mnfndeb_();
    extern /* Subroutine */ int maermsg_(), mgenmsg_(), msifill_();
    extern integer mnfnimp_();
    extern /* Subroutine */ int msrfill_(), mgsomsg_(), mminltt_(), mmotlis_()
	    ;



/* < */
/* **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 : */
/*     ---------- */
/*       Moteur d'optimisation du lissage de courbes par une methode */
/*       variationnelle lineaire. */

/*     MOTS CLES : */
/*     ----------- */
/*      LISSAGE, VARIATIONNELLE, JACCOBI */

/*     ARGUMENTS D'ENTREE : */
/*     -------------------- */
/*     NDIMEN : Dimension de l'espace */
/*     NBCRMX : Nombre maxi de courbes polynomiales a calculer. */
/*     NCFLIM : Nombre LIMITE de coeff des "courbes" polynomiales */
/*              d' approximation. */
/*     NBRPNT : Nombre de points a lisser  (>= 2) */
/*     NBCNTR : Nombre de point contraints (<= NBRPNT) */
/*    TABPNT : Tableau des points a lisser, TYPCNT, TABCNT, TBOPNT, DEBFIN
,*/
/*     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 */
/*     TBOPNT : Tableau d'option du lissage */
/*        TBOPNT(1) : Nombre de pas d'optimisation */
/*               1 : 1 seul pas ( => pas d'optimisation des parametres) */
/*               > 1 : plusieurs pas et donc optimisation des parametres 
*/
/*        TBOPNT(2) : Decoupe avec ou sans */
/*               0 : Avec decoupe */
/*               1 : Sans decoupe */
/*     VPOIDS : Poid respectif des criteres moindre carreet qualite */
/*        VPOIDS(1) : Poid des moindre carre */
/*        VPOIDS(2) : Poid du critere de "qualite". */
/*     TABPAR : Parametres initiaux affectes aux points. */


/*     ARGUMENTS DE SORTIE : */
/*     --------------------- */
/*     TABPAR : Tableau des parametres corespondant aux points a lisser */
/*     NBCRBE : Nombre de courbes polynomiales creees. */
/*     NCFTAB : Table des nombres de coeff. significatifs des NBCRBE */
/*              "courbes" calculees. */
/*     CRBTAB : Tableau des coeff dans la base de jacobi des "courbes" */
/*              polynomiales calculees. */
/*              Doit etre dimensionne a CRBTAB(NDIMEN,NCOFMX,NBCRMX). */
/*     TABINT : Table des NBCRBE + 1 bornes des intervalles de decoupe */
/*     VALCRI : Valeurs des criteres */
/*       VALCRI(0) : Erreur quadratique */
/*       VALCRI(1) : Energie de Tension linearise */
/*       VALCRI(2) : Energie de Flexion linearise */
/*       VALCRI(3) : "Energie du 3eme ordre" linearise */

/*       IERCOD : code d'erreur */
/*          0   : Ok */
/*         > 0 : Echec */
/*         2   : Erreur dans un sous programme */
/*         3   : Erreur d'allocation dynamique */

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


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


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


/* $    HISTORIQUE DES MODIFICATIONS : */
/*     ------------------------------ */
/*      21-1-1997: PMN/JMC;Pb d'index d'erreur max, non sauvegarder (PRO6950)*/
/*      8-10-1996: PMN; Pas de sortie en erreur pour des probleme */
/*                      de conditonement */                                    
/*      7-11-1995: PMN; Probleme d'ecrasement. */
/*      5-10-1995: PMN; ECRITURE VERSION ORIGINALE. */
/* > */
/* ***********************************************************************
 */
/*                            DECLARATIONS */
/* ***********************************************************************
 */

/*     INCLUDE MDNOMBR */
/* < */
/* **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 : */
/*     ---------- */
/*      LE COMMON DES NOMBRES REELS REMARQUABLES */

/*     MOTS CLES : */
/*     ----------- */
/*      TOUS - LECTURE SEULEMENT */

/*     DEMSCRIPTION/REMARQUES/LIMITATIONS : */
/*     ----------------------------------- */

/* $    HISTORIQUE DES MODIFICATIONS : */
/*     ------------------------------ */
/*     18-12-89 : NAK ; ENTETE STANDARD */
/*     20-10-87 : NAK; CREATION VERSION ORIGINALE */
/* > */
/* ***********************************************************************
 */

/*        PI     : 3.1415.... */
/*        DEUXPI : 2*PI */
/*        PISUR2 : PI/2 */
/*        PIS180 : PI/180 */
/*        C180PI : 180/PI */
/*        ZERO   : 0.D0 */
/*        ONE    : 1.D0 */
/*        A180   : 180 DEGRES */
/*        A360   : 360 DEGRES */
/*        A90    : 90 DEGRES */




/*     INCLUDE MINOMBR */
/* < */
/* **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 : */
/*     ---------- */
/*        Sert a fournir les constantes entieres de 0 a 1000 */

/*     MOTS CLES : */
/*     ----------- */
/*        TOUS,ENTIERS */

/*     DEMSCRIPTION/REMARQUES/LIMITATIONS : */
/*     ----------------------------------- */

/* $    HISTORIQUE DES MODIFICATIONS : */
/*     ------------------------------ */
/*     11-10-89 : DH ; Creation version originale */
/* > */
/* ***********************************************************************
 */


/* ***********************************************************************
 */







    /* 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;
    tabcnt_dim1 = *ndimen;
    tabcnt_offset = tabcnt_dim1 * 3 + 1;
    tabcnt -= tabcnt_offset;
    --ncftab;
    crbtab_dim1 = *ndimen;
    crbtab_dim2 = *ncflim;
    crbtab_offset = crbtab_dim1 * (crbtab_dim2 + 1) + 1;
    crbtab -= crbtab_offset;
    --matrj3;
    --matrj2;
    --matrj1;
    --tbecar;
    --tabpar;
    --tbpoid;
    tabpnt_dim1 = *ndimen;
    tabpnt_offset = tabpnt_dim1 + 1;
    tabpnt -= tabpnt_offset;
    typcnt -= 3;
    --tbopnt;
    --vpoids;
    --alpha;
    --jestim;

    /* Function Body */



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

    ldbg = mnfndeb_() >= 2;
    imp = mnfnimp_();
    if (ldbg) {
	mgenmsg_("MMAJLIS", 7L);
    }
    *iercod = 0;

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


/* (0.a) allocation dynamique */

    macrai4_(nbcrmx, &c__30, ncfold, &iofncf, &ier);
    if (ier > 0) {
	goto L9103;
    }
    cbsiz = *ndimen * *nbcrmx * *ncflim;
    macrar8_(&cbsiz, &c__500, cbold, &ioftcb, &ier);
    if (ier > 0) {
	goto L9103;
    }
    tpsiz = *nbrpnt + *nbcrmx + 1;
    macrar8_(&tpsiz, &c__100, tpold, &ioftp, &ier);
    iofint = ioftp + *nbrpnt + 1;
    if (ier > 0) {
	goto L9103;
    }

/* (0.b) Initialisations */

    loptim = TRUE_;
    iter = 0;


/* ============   boucle sur le moteur de lissage  ============== */

    vtest = vpoids[2] * (float).9;
    j1cibl = sqrt(valcri[0] / (*nbrpnt - *nbcntr));

    while(loptim) {

	++iter;

/*     (1) Sauvegarde de l'etat precedents */

	vocri[0] = valcri[0];
	vocri[1] = valcri[1];
	vocri[2] = valcri[2];
	vocri[3] = valcri[3];
	nuold = *numpnt;
	erold = *errmax;
	emold = *errmoy;
	ncbold = *nbcrbe;

	msifill_(nbcrbe, &ncftab[1], &ncfold[iofncf]);
	ii = *nbcrbe * *ndimen * *ncflim;
	msrfill_(&ii, &crbtab[crbtab_offset], &cbold[ioftcb]);
	msrfill_(nbrpnt, &tabpar[1], &tpold[ioftp]);
	msrfill_(nbcrbe, &tabint[1], &tpold[iofint]);


/*     (2) Augmentation du poids des moindre carre */

	if (j1cibl > vtest) {
	    vpoids[1] = j1cibl / vtest * vpoids[1];
	}

/*     (3) Augmentation du poid associe aux points a problemes */

	vseuil = vpoids[2] * (float).88;

	i__1 = *nbrpnt;
	for (ipnt = 1; ipnt <= i__1; ++ipnt) {
	    if (tbecar[ipnt] > vtest) {
		ecart = (tbecar[ipnt] - vseuil) / vpoids[2];
		tbpoid[ipnt] = (ecart * 3 + 1.) * tbpoid[ipnt];
	    }
	}

/*     (4) Decoupe force */

	if (*nbcrbe < *nbcrmx && tbopnt[2] == 0.) {
	    ii = *nbcrbe + 1;
	    mmsrre2_(&tabpar[*numpnt], &ii, tabint, &mdnombr_1.zero, &numint, 
		    &ibid, &ier);
	    if (ier == 0) {
		jj = *nbcrbe + 1;
		++(*nbcrbe);
		ii = *nbcrbe + 1;

		tpara = (tabint[numint] + tabint[numint - 1] + tabpar[*numpnt]
			 * 2) / 4;
		mminltt_(&minombr_1.nbr[1], &ii, tabint, &minombr_1.nbr[1], &
			jj, &tpara, &eps1, &ier);
		if (ier > 0) {
		    goto L9102;
		}
	    }
	}

/*     (5) Relissage */

	mmotlis_(ndimen, nbcrmx, ncflim, nbrpnt, nbcntr, orcont, &tabpnt[
		tabpnt_offset], &tbpoid[1], &typcnt[3], &tabcnt[tabcnt_offset]
		, &tbopnt[1], &matrj1[1], &matrj2[1], &matrj3[1], &vpoids[1], 
		&alpha[1], &jestim[1], &ttheta[ttheta_offset], &tfthet[
		tfthet_offset], cblong, &tabpar[1], nbcrbe, &ncftab[1], &
		crbtab[crbtab_offset], tabint, &tbecar[1], numpnt, errmax, 
		errmoy, valcri, &ier);
	if (ier > 0) {
            if (ier != 2) goto L9102;
	    lrejet = 1;
	}
	else {

/*     (6) Tests de rejet */

	j1cibl = sqrt(valcri[0] / (*nbrpnt - *nbcntr));
	vseuil = sqrt(vocri[1]) + (erold - *errmax) * 4;
	lrejet = ( *errmax > vpoids[2] && *errmax > erold * (float)1.01 )
                 || sqrt(valcri[1]) > vseuil * (float)1.05;
      }
	if (lrejet) {
	    valcri[0] = vocri[0];
	    valcri[1] = vocri[1];
	    valcri[2] = vocri[2];
	    valcri[3] = vocri[3];
            *numpnt = nuold;
	    *errmax = erold;
	    *errmoy = emold;
	    *nbcrbe = ncbold;

	    msifill_(nbcrbe, &ncfold[iofncf], &ncftab[1]);
	    ii = *nbcrbe * *ndimen * *ncflim;
	    msrfill_(&ii, &cbold[ioftcb], &crbtab[crbtab_offset]);
	    msrfill_(nbrpnt, &tpold[ioftp], &tabpar[1]);
	    msrfill_(nbcrbe, &tpold[iofint], &tabint[1]);

	    loptim = FALSE_;
	}

/*     (7) Test de convergence */

	if (( iter >= mxiter && *nbcrmx == *nbcrbe ) || *errmax < vpoids[2]) {
	    loptim = FALSE_;
	}

    }

    goto L9999;

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


L9102:
    *iercod = 2;
    if (ier == 3) {
	*iercod = 3;
    }
    goto L9999;

L9103:
    *iercod = 3;
    goto L9999;


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

L9999:


/* ___ DESALLOCATION, ... */

    macrdi4_(nbcrmx, &c__30, ncfold, &iofncf, &ier);
    if (*iercod == 0 && ier > 0) {
	*iercod = 3;
    }
    macrdr8_(&cbsiz, &c__500, cbold, &ioftcb, &ier);
    if (*iercod == 0 && ier > 0) {
	*iercod = 3;
    }
    macrdr8_(&tpsiz, &c__100, tpold, &ioftp, &ier);
    if (*iercod == 0 && ier > 0) {
	*iercod = 3;
    }

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

