Sources Esope | Cast3M

courb3
C COURB3    SOURCE    PV        07/11/23    21:16:08     5978
      SUBROUTINE COURB3 (MCOURB,ALONG,MABCUR)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
************************************************************************
*
*                          C O U R B 3
*                          -----------
*
* FONCTION:
* ---------
*
*     CREATION D'ABSCISSES CURVILIGNES EN UN NOMBRE DISCRET DE POINTS
*     DE LA COURBE POLYNOMIALE, ET DE SA LONGUEUR TOTALE APPROXIMATIVE.
*
* MODULES UTILISES:
* -----------------
*
 
-INC PPARAM
-INC CCOPTIO
-INC SMCOORD
-INC TMCOURB
*
* PARAMETRES:   (E)=ENTREE   (S)=SORTIE   (+ = CONTENU DANS UN COMMUN)
* -----------
*
*     MCOURB  (E)  SEGMENT ACTIF.
*    +IDIM    (E)  VOIR LE COMMUN "COPTIO".
*    +MCOORD  (E)  SEGMENT ACTIF.
*     ALONG   (S)  LONGUEUR APPROXIMATIVE DE LA COURBE POLYNOMIALE.
*     MABCUR  (S)  POINTEUR DE SEGMENT CONTENANT LES ABSCISSES
*                  CURVILIGNES EN UN NOMBRE FINI DE POINTS DE LA COURBE
*                  (DONT LES POINTS EXTREMITES).
*                  SEGMENT LAISSE DANS L'ETAT ACTIF.
*
      SEGMENT,MABCUR
         REAL*8 ABCURV(NPDISC)
      ENDSEGMENT
*
* VARIABLES:
* ----------
*
      REAL*8 U
*
* CONSTANTES:
* -----------
*
*     NPDISC   NOMBRE DE POINTS DE DISCRETISATION DE LA COURBE.
*
      INTEGER NPDISC,NPDIS1
      PARAMETER (NPDISC = 101, NPDIS1 = NPDISC-1)
*
* FONCTIONS:
* ----------
*
      REAL*8 POLYNO
*
* REMARQUES:
* ----------
*
*     LE REMPLISSAGE DE "ABCURV" NE S'IMPOSE QUE POUR L'OPTION
*     "REGULIER" DE L'OPERATEUR "COURBE".
*
* AUTEUR, DATE DE CREATION:
* -------------------------
*
*     PASCAL MANIGOT     10 SEPTEMBRE 1986
*     P.M.   24/02/87 : REMODELAGE, AVEC UN NOUVEAU SEGMENT "MCOURB".
*
* LANGAGE:
* --------
*
*     ESOPE + FORTRAN77 + EXTENSION: DECLARATION "REAL*8".
*
************************************************************************
*
      SEGINI,MABCUR
      ABCURV(1) = 0.
      U = U1COU
      DU = (U2COU - U1COU) / REAL(NPDIS1)
      IP = (PT1COU - 1) * (IDIM + 1)
      X3COU = XCOOR(IP+1)
      Y3COU = XCOOR(IP+2)
      Z3COU = XCOOR(IP+3)
      IP = (PT2COU - 1) * (IDIM + 1)
      X2COU = XCOOR(IP+1)
      Y2COU = XCOOR(IP+2)
      Z2COU = XCOOR(IP+3)
*
      MCOFCO = ICOFCO
      SEGACT,MCOFCO
      IF (IDIM .EQ. 3) THEN
         DO 100 IB=2,NPDIS1
            U = U + DU
            X4COU = POLYNO (COFCOU(1,1),ND1COU,1,U)
            Y4COU = POLYNO (COFCOU(1,2),ND1COU,1,U)
            Z4COU = POLYNO (COFCOU(1,3),ND1COU,1,U)
            ABCURV(IB) = ABCURV(IB-1) + SQRT((X4COU-X3COU)**2
     &                 + (Y4COU-Y3COU)**2 + (Z4COU-Z3COU)**2)
            X3COU = X4COU
            Y3COU = Y4COU
            Z3COU = Z4COU
  100       CONTINUE
*        END DO
         ALONG = ABCURV(NPDIS1) + SQRT((X2COU-X3COU)**2
     &         + (Y2COU-Y3COU)**2 + (Z2COU-Z3COU)**2)
      ELSE
         DO 110 IB=2,NPDIS1
            U = U + DU
            X4COU = POLYNO (COFCOU(1,1),ND1COU,1,U)
            Y4COU = POLYNO (COFCOU(1,2),ND1COU,1,U)
            ABCURV(IB) = ABCURV(IB-1) + SQRT((X4COU-X3COU)**2
     &                 + (Y4COU-Y3COU)**2)
            X3COU = X4COU
            Y3COU = Y4COU
  110       CONTINUE
*        END DO
         ALONG = ABCURV(NPDIS1) + SQRT((X2COU-X3COU)**2
     &         + (Y2COU-Y3COU)**2)
      END IF
      ABCURV(NPDISC) = ALONG
*
      SEGDES,MCOFCO
*
      END