Sources Esope | Cast3M

courb4
C COURB4    SOURCE    PV        20/03/24    21:16:21     10554          
      SUBROUTINE COURB4 (MCOURB,MABCUR,MABSCI,ALONG)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
************************************************************************
*
*                           C O U R B 4
*                           -----------
*
* FONCTION:
* ---------
*
*     DETERMINATION, A PARTIR D'UNE SUITE DISCRETE D'ABSCISSES
*     CURVILIGNES LE LONG DE LA COURBE POLYNOMIALE, DES COORDONNEES
*     DE POINTS A DES ABSCISSES CURVILIGNES DONNEES (PAR INTERPOLATION
*     LINEAIRE).
*
* MODULES UTILISES:
* -----------------
*
 
-INC PPARAM
-INC CCOPTIO
-INC CCGEOME
-INC CCREEL
-INC SMCOORD
-INC TMCOURB
*
* PARAMETRES:   (E)=ENTREE   (S)=SORTIE   (+ = CONTENU DANS UN COMMUN)
* -----------
*
*     MCOURB  (E)  SEGMENT ACTIF.
*             (S)  ETENDU EN SORTIE (TABLEAU "UCOU" REMPLI).
*     MABCUR  (E)  SEGMENT ACTIF DEFINI DANS LE S-P "COURB3".
*     MABSCI  (E)  SEGMENT ACTIF DEFINI DANS LE S-P "COURB2".
*                  ICI, IL S'AGIT D'ABSCISSES CURVILIGNES.
*     ALONG   (E)  LONGUEUR APPROXIMATIVE DE LA COURBE POLYNOMIALE.
*    +IDIM    (E)  VOIR LE COMMUN "COPTIO".
*    +ILCOUR  (E)  VOIR LE COMMUN "CGEOME".
*    +XPETIT  (E)  VOIR LE COMMUN "CREEL".
*    +MCOORD  (E)  SEGMENT ACTIF.
*             (S)  COMPLETE EN SORTIE.
*
      SEGMENT,MABCUR
         REAL*8 ABCURV(NPDISC)
      ENDSEGMENT
      SEGMENT,MABSCI
         REAL*8 ABSCIS(NPOIN)
      ENDSEGMENT
*
* VARIABLES:
* ----------
*
*     COFDEN = FACTEUR CORRECTIF DE LA DENSITE LOCALE CALCULEE, SELON
*              LE TYPE D'ELEMENT (SEG2 OU SEG3).
*
      REAL*8 COFDEN
      REAL*8 U
*
* FONCTIONS:
* ----------
*
      REAL*8 POLYNO
*
* REMARQUES:
* ----------
*
*     CE SOUS-PROGRAMME N'EST PAS PREVU POUR FONCTIONNER AVEC UN NOMBRE
*     DE POINTS NUL.
*
* AUTEUR, DATE DE CREATION:
* -------------------------
*
*     PASCAL MANIGOT     10 SEPTEMBRE 1986
*     P.M.   24/02/87 : REMODELAGE, AVEC UN NOUVEAU SEGMENT "MCOURB".
*
* LANGAGE:
* --------
*
*     ESOPE + FORTRAN77
*
************************************************************************
*
      NPOIN = ABSCIS(/1)
      NPDISC = ABCURV(/1)
      DU = (U2COU - U1COU) / REAL(NPDISC-1)
*
      IF (ILCOUR .EQ. 2) THEN
         COFDEN = 0.5
      ELSE
*        "ILCOUR" EST SUPPOSE VALOIR 3.
         COFDEN = 1.
      END IF
      ABSC1 = 0.
      ABSC2 = ABSCIS(1)
*
      LONG = NPOIN
      SEGADJ,MCOURB
      IDIMP1 = IDIM + 1
      segact mcoord*mod
      NBPTA=nbpts
      NBPTS=NBPTA+NPOIN
      SEGADJ MCOORD
      MCOFCO = ICOFCO
      SEGACT,MCOFCO
*
      DO 200 IB=1,NPOIN
*
*        POUR UN POINT A ETUDIER, DETERMINATION DE 2 POINTS DE
*        COORDONNEES PARAMETRIQUES CONNUES ET L'ENCADRANT SUR LA COURBE.
*
         ABSC0 = ABSC1
         ABSC1 = ABSC2
         IF (IB .EQ. NPOIN) THEN
            ABSC2 = ALONG
         ELSE
            ABSC2 = ABSCIS(IB+1)
         END IF
*
         DO 210 IB2=2,NPDISC
            IF (ABSC1 .LE. ABCURV(IB2)) THEN
*              --> SORTIE DE BOUCLE
               GOTO 212
            END IF
  210       CONTINUE
*        END DO
         IB2 = NPDISC
*+*      VAUDRAIT-IL MIEUX UN MESSAGE D'ERREUR ?
  212    CONTINUE
*
*        CALCUL DE LA COORDONNEE INTRINSEQUE PAR INTERPOLATION LINEAIRE
*
         COFDIV = ABCURV(IB2) - ABCURV(IB2-1)
         IF (ABS(COFDIV) .LE. XPETIT) THEN
*           LA PORTION DE COURBE EST DE LONGUEUR NULLE. L'ABSCISSE
*           CURVILIGNE RESTE PRATIQUEMENT CONSTANTE.
            COF = 0.
         ELSE
            COF = (ABSC1 - ABCURV(IB2-1)) / COFDIV
         END IF
         U = U1COU + DU*REAL(IB2-2) + DU*COF
*
*        CALCUL DES COORDONNEES.
*
         XCOOR(NBPTA*IDIMP1+1) = POLYNO (COFCOU(1,1),ND1COU,1,U)
         XCOOR(NBPTA*IDIMP1+2) = POLYNO (COFCOU(1,2),ND1COU,1,U)
         IF (IDIM .EQ. 3)
     #   XCOOR(NBPTA*IDIMP1+3) = POLYNO (COFCOU(1,3),ND1COU,1,U)
         XCOOR(NBPTA*IDIMP1+IDIMP1) = (ABSC2 - ABSC0) * COFDEN
         NBPTA=NBPTA+1
*
*+*      ON POURRAIT ENVISAGER UN PETIT SCHEMA ITERATIF POUR QUE
*+*      L'INTERPOLATION SOIT LINEAIRE SUIVANT L'ABSCISSE CURVILIGNE.
*
         UCOU(IB) = U
*
  200    CONTINUE
*     END DO
*
      SEGDES,MCOFCO
*
      END