/* MPOBAS.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 <MathBase.h>
#else 
#define  __MathBase_API
#endif
/* Table of constant values */

static integer c__2 = 2;
static integer c__1 = 1;

/* Subroutine */ __MathBase_API int mmpobas_(tparam, iordre, ncoeff, nderiv, valbas, iercod)
doublereal *tparam;
integer *iordre, *ncoeff, *nderiv;
doublereal *valbas;
integer *iercod;
{
    /* Initialized data */

    static doublereal moin11[2] = { -1.,1. };

    /* System generated locals */
    integer valbas_dim1, i__1;

    /* Local variables */
    static doublereal vjac[80], herm[24];
    static integer iord[2];
    static doublereal wval[4];
    static integer nwcof, iunit;
    static doublereal wpoly[7];
    static integer ii, jj, iorjac;
    static doublereal hermit[36]	/* was [6][3][2] */;
    static integer kk1, kk2, kk3;
    extern /* Subroutine */ int mmherm1_();
    static integer khe, ier;
    extern /* Subroutine */ int mmpojac_(), mmdrvcb_(), maermsg_(), mmpocrb_()
	    , mvriraz_();



/* < */
/* **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 : */
/*     ---------- */
/*       Positionnement sur les polynomes de la base hermite-Jacobi */
/*       et leurs derives succesives */

/*     MOTS CLES : */
/*     ----------- */
/*      PUBLIC, POSITIONEMENT, HERMITE, JACOBI */

/*     ARGUMENTS D'ENTREE : */
/*     -------------------- */
/*       TPARAM : Parametre pour lequel on se positionne. */
/*       IORDRE : Ordre d'hermite-Jacobi (-1,0,1, ou 2) */
/*       NCOEFF : Nombre de coeeficients des polynomes (Nb de valeur a */
/*                calculer) */
/*       NDERIV : Nombre de derive a calculer (0<= N <=3) */
/*              0 -> Positionement simple sur les fonctions de base */
/*              N -> Positionement sur les fonctions de base et lerive */
/*              d'ordre 1 a N */

/*     ARGUMENTS DE SORTIE : */
/*     --------------------- */
/*     VALBAS (NCOEFF, 0:NDERIV) : les valeur calculee */
/*           i */
/*          d    vj(t)  = VALBAS(J, I) */
/*          -- i */
/*          dt */

/*    IERCOD : Code d'erreur */
/*      0 : Ok */
/*      1 : Incoherance des arguments d'entre */

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


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


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


/* $    HISTORIQUE DES MODIFICATIONS : */
/*     ------------------------------ */
/*     19-07-1995: PMN; ECRITURE VERSION ORIGINALE. */
/* > */
/* ***********************************************************************
 */
/*                            DECLARATIONS */
/* ***********************************************************************
 */



    /* Parameter adjustments */
    valbas_dim1 = *ncoeff;
    --valbas;

    /* Function Body */

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

    *iercod = 0;

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

    if (*nderiv > 3) {
	goto L9101;
    }
    if (*ncoeff > 20) {
	goto L9101;
    }
    if (*iordre > 2) {
	goto L9101;
    }

    iord[0] = *iordre;
    iord[1] = *iordre;
    iorjac = (*iordre + 1) << 1;

/*  (1) Calculs generiques .... */

/*  (1.a) Calcul des polynomes d'hermite */

    if (*iordre >= 0) {
	mmherm1_(moin11, &c__2, iord, hermit, &ier);
	if (ier > 0) {
	    goto L9102;
	}
    }

/*  (1.b) Evaluation des polynomes d'hermite */

    jj = 1;
    iunit = *nderiv + 1;
    khe = (*iordre + 1) * iunit;

    if (*nderiv > 0) {

	i__1 = *iordre;
	for (ii = 0; ii <= i__1; ++ii) {
	    mmdrvcb_(nderiv, &c__1, &iorjac, &hermit[(ii + 3) * 6 - 18], 
		    tparam, &herm[jj - 1], &ier);
	    if (ier > 0) {
		goto L9102;
	    }

	    mmdrvcb_(nderiv, &c__1, &iorjac, &hermit[(ii + 6) * 6 - 18], 
		    tparam, &herm[jj + khe - 1], &ier);
	    if (ier > 0) {
		goto L9102;
	    }
	    jj += iunit;
	}

    } else {

	i__1 = *iordre;
	for (ii = 0; ii <= i__1; ++ii) {
	    mmpocrb_(&c__1, &iorjac, &hermit[(ii + 3) * 6 - 18], &c__1, 
		    tparam, &herm[jj - 1]);

	    mmpocrb_(&c__1, &iorjac, &hermit[(ii + 6) * 6 - 18], &c__1, 
		    tparam, &herm[jj + khe - 1]);
	    jj += iunit;
	}
    }

/*  (1.c) Evaluation des polynomes de Jaccobi */

    ii = *ncoeff - iorjac;

    mmpojac_(tparam, &iorjac, &ii, nderiv, vjac, &ier);
    if (ier > 0) {
	goto L9102;
    }

/*  (1.d) Evaluation de W(t) */

/* Computing MAX */
    i__1 = iorjac + 1;
    nwcof = max(i__1,1);
    mvriraz_(&nwcof, wpoly);
    wpoly[0] = 1.;
    if (*iordre == 2) {
	wpoly[2] = -3.;
	wpoly[4] = 3.;
	wpoly[6] = -1.;
    } else if (*iordre == 1) {
	wpoly[2] = -2.;
	wpoly[4] = 1.;
    } else if (*iordre == 0) {
	wpoly[2] = -1.;
    }

    mmdrvcb_(nderiv, &c__1, &nwcof, wpoly, tparam, wval, &ier);
    if (ier > 0) {
	goto L9102;
    }

    kk1 = *ncoeff - iorjac;
    kk2 = kk1 << 1;
    kk3 = kk1 * 3;

/*  (2) Evaluation a l'ordre 0 */

    jj = 1;
    i__1 = iorjac;
    for (ii = 1; ii <= i__1; ++ii) {
	valbas[ii] = herm[jj - 1];
	jj += iunit;
    }

    i__1 = kk1;
    for (ii = 1; ii <= i__1; ++ii) {
	valbas[ii + iorjac] = wval[0] * vjac[ii - 1];
    }

/*  (3) Evaluation a l'ordre 1 */

    if (*nderiv >= 1) {
	jj = 2;
	i__1 = iorjac;
	for (ii = 1; ii <= i__1; ++ii) {
	    valbas[ii + valbas_dim1] = herm[jj - 1];
	    jj += iunit;
	}


	i__1 = kk1;
	for (ii = 1; ii <= i__1; ++ii) {
	    valbas[ii + iorjac + valbas_dim1] = wval[0] * vjac[ii + kk1 - 1] 
		    + wval[1] * vjac[ii - 1];
	}
    }

/*  (4)  Evaluation a l'ordre 2 */

    if (*nderiv >= 2) {
	jj = 3;
	i__1 = iorjac;
	for (ii = 1; ii <= i__1; ++ii) {
	    valbas[ii + (valbas_dim1 << 1)] = herm[jj - 1];
	    jj += iunit;
	}

	i__1 = kk1;
	for (ii = 1; ii <= i__1; ++ii) {
	    valbas[ii + iorjac + (valbas_dim1 << 1)] = wval[0] * vjac[ii + 
		    kk2 - 1] + wval[1] * 2 * vjac[ii + kk1 - 1] + wval[2] * 
		    vjac[ii - 1];
	}
    }

/*  (5) Evaluation a l'ordre 3 */

    if (*nderiv >= 3) {
	jj = 4;
	i__1 = iorjac;
	for (ii = 1; ii <= i__1; ++ii) {
	    valbas[ii + valbas_dim1 * 3] = herm[jj - 1];
	    jj += iunit;
	}

	i__1 = kk1;
	for (ii = 1; ii <= i__1; ++ii) {
	    valbas[ii + iorjac + valbas_dim1 * 3] = wval[0] * vjac[ii + kk3 - 
		    1] + wval[1] * 3 * vjac[ii + kk2 - 1] + wval[2] * 3 * 
		    vjac[ii + kk1 - 1] + wval[3] * vjac[ii - 1];
	}
    }

    goto L9999;

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

L9101:
    *iercod = 1;
    goto L9999;

L9102:
    *iercod = 2;

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

L9999:

    if (*iercod > 0) {
	maermsg_("MMPOBAS", iercod, 7L);
    }
 return 0 ;
} /* mmpobas_ */

