Sources Esope | Cast3M

courbe
C COURBE    SOURCE    CHAT      05/01/12    22:25:31     5004
      SUBROUTINE COURBE
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
************************************************************************
*
*                             C O U R B E
*                             -----------
*
*            SOUS-PROGRAMME ASSOCIE A L'OPERATEUR "COURBE"
*
* FONCTION:
* ---------
*
*     CREATION D'UNE COURBE POLYNOMIALE, C'EST-A-DIRE DONT LES POINTS
*     "P" VERIFIENT UNE EQUATION:
*
*                         2       3
*     P(U) = P0 + U.P1 + U .P2 + U .P3 + ...
*
* PHRASE D'APPEL (EN GIBIANE):
* ----------------------------
*
*     LILI = COURBE (N) (DINI DENS1) (DFIN DENS2) (PINI OB1) (PFIN OB2)
*                   P0 P1 (P2 (P3 ...) ) (PARAMETRE U1 U2) (REGULIER) ;
*
* OPERANDES ET RESULTATS:
* -----------------------
*
*     LILI      'MAILLAGE'  MAILLAGE RESULTANT DE L'OPERATION. OUTRE LA
*                           COURBE POLYNOMIALE NOUVELLEMENT CREEE, CE
*                           MAILLAGE COMPRENDRA "OB1" ET/OU "OB2", QUE
*                           CE SOIENT DES 'POINTS' OU DES 'MAILLAGE'.
*     N         'ENTIER  '  NOMBRE D'ELEMENTS GEOMETRIQUES DEMANDE.
*                           > 0 : LONGUEURS EGALES DES ELEMENTS.
*                           &lt; 0 : LONGUEURS DES ELEMENTS FONCTIONS DES
*                           DENSITES DES EXTREMITES DE LA COURBE.
*     DINI      'MOT     '
*     DENS1     'FLOTTANT'  DENSITE DEMANDEE POUR LE 1ER ELEMENT.
*     DFIN      'MOT     '
*     DENS2     'FLOTTANT'  DENSITE DEMANDEE POUR LE DERNIER ELEMENT.
*     PINI      'MOT     '
*     OB1       'POINT   '  POINT INITIAL DE LA COURBE: SERA
*                           EFFECTIVEMENT PRIS COMME TEL SI SES
*                           COORDONNEES S'OBTIENNENT POUR LA VALEUR "U1"
*                           (VOIR DEFINITION PLUS LOIN).
*            OU 'MAILLAGE'  LE POINT FINAL DE CET OBJET "OB1" (FORCEMENT
*                           UNE LIGNE) SERA LE POINT INITIAL DE LA
*                           COURBE (AVEC LES MEMES RESERVES QUE
*                           CI-DESSUS) ET "LILI" CONTIENDRA "OB1".
*     PFIN      'MOT     '
*     OB2       'POINT   '  POINT FINAL DE LA COURBE: SERA EFFECTIVEMENT
*                           PRIS COMME TEL SI SES COORDONNEES
*                           S'OBTIENNENT POUR LA VALEUR "U2" (VOIR
*                           DEFINITION PLUS LOIN).
*            OU 'MAILLAGE'  LE POINT INITIAL DE CET OBJET "OB2"
*                           (FORCEMENT UNE LIGNE) SERA LE POINT FINAL
*                           DE LA COURBE (AVEC LES MEMES RESERVES QUE
*                           CI-DESSUS) ET "LILI" CONTIENDRA "OB2".
*     P0, P1,   'POINT   '  POINTS DE LA REPRESENTATION POLYNOMIALE DE
*     P2, ...               LA COURBE.
*                           CES POINTS NE FONT PAS PARTIE DE LA COURBE.
*                           "P0" ET "P1" SONT OBLIGATOIRES.
*     PARAMETR  'MOT     '
*     U1, U2    'FLOTTANT'  BORNES DU PARAMETRE "U" DU POLYNOME DE LA
*                           COURBE.
*                           = (0,1)  PAR DEFAUT.
*     REGULIER  'MOT     '  INDIQUE QUE LA COURBE DEVRA ETRE SUBDIVISEE
*                           EN ELEMENTS DONT LES LONGUEURS SERONT
*                           ETABLIES SELON L'ABSCISSE CURVILIGNE ET NON
*                           PAS SELON LE PARAMETRE "U".
*
* MODULES UTILISES:
* -----------------
*
 
-INC PPARAM
-INC CCOPTIO
-INC CCREEL
-INC SMCOORD
-INC TMCOURB
*
* VARIABLES:
* ----------
*
*     BIDSP, BIDDP = VARIABLES UTILISEES POUR RESOUDRE DES PROBLEMES DE
*                    LECTURES DE REELS, TANTOT EN S.P., TANTOT EN D.P.,
*                    ET, PEUT-ETRE, BIENTOT EN ON-NE-SAIT-QUOI.
*
      SEGMENT,MTEMP
         INTEGER ITEMP(2)
      ENDSEGMENT
*
* CONSTANTES:
* -----------
*
*     MOTCLE   LISTE DES MOTS-CLES RECONNUS.
*
      INTEGER LMOTCL
      PARAMETER (LMOTCL = 6)
      CHARACTER*4 MOTCLE(LMOTCL)
*
* AUTEUR, DATE DE CREATION:
* -------------------------
*
*     PASCAL MANIGOT     11 SEPTEMBRE 1986
*     P.M.  25/02/87 : REPRISE.
*
* LANGAGE:
* --------
*
*     ESOPE + FORTRAN77 + EXTENSION: CARACTERES MIS DANS DES ENTIERS
*
************************************************************************
*
      REAL*8 RBID(1)
      DIMENSION IBID(1)
      DATA MOTCLE/'DINI','DFIN','PINI','PFIN','PARA','REGU'/
*
      LONG = 0
      SEGINI,MCOURB
*
*     -- LECTURE DES PARAMETRES PARTICULIERS --
*
*     FACTEUR DE DECOUPAGE:
      CALL LIRENT (I,0,IRETOU)
      IF (IRETOU .EQ. 1) THEN
         NLMCOU = I
      ELSE
         NLMCOU = 0
      END IF
*
      U1COU = 0.D0
      U2COU = 1.D0
      D1COU = 0.
      D2COU = 0.
      PT1COU = 0
      LI1COU = 0
      PT2COU = 0
      LI2COU = 0
      REGCOU = .FALSE.
*
*     DO
  205    CONTINUE
*
         IRETOU = 0
         CALL LIRMOT (MOTCLE,LMOTCL,IRETOU,0)
         IF (IRETOU .LE. 0) THEN
*           --> SORTIE DE BOUCLE
            GOTO 206
         END IF
*
         GOTO (101,102,103,104,105,106) IRETOU
  101    CONTINUE
            CALL LIRE04 (XPETIT,BIDDP,0,1,IRETOU)
            IF (IERR .NE. 0) RETURN
            D1COU = BIDDP
            GOTO 200
  102    CONTINUE
            CALL LIRE04 (XPETIT,BIDDP,0,1,IRETOU)
            IF (IERR .NE. 0) RETURN
            D2COU = BIDDP
            GOTO 200
  103    CONTINUE
*           IL FAUT ESSAYER DE LIRE UN "MAILLAGE" AVANT UN "POINT" POUR
*           NE PAS LIRE PAR ERREUR LES POINTS-COEFFICIENTS DU POLYNOME.
            IRETOU = 0
            CALL LIROBJ ('MAILLAGE',I,0,IRETOU)
            IF (IRETOU .EQ. 1) THEN
               LI1COU = I
            ELSE
               CALL LIROBJ ('POINT',I,1,IRETOU)
               IF (IERR .NE. 0) RETURN
               PT1COU = I
            END IF
            GOTO 200
  104    CONTINUE
            IRETOU = 0
            CALL LIROBJ ('MAILLAGE',I,0,IRETOU)
            IF (IRETOU .EQ. 1) THEN
               LI2COU = I
            ELSE
               CALL LIROBJ ('POINT',I,1,IRETOU)
               IF (IERR .NE. 0) RETURN
               PT2COU = I
            END IF
            GOTO 200
  105    CONTINUE
            CALL LIRREE (BIDSP,1,IRETOU)
            IF (IERR .NE. 0) RETURN
            U1COU = BIDSP
            CALL LIRREE (BIDSP,1,IRETOU)
            IF (IERR .NE. 0) RETURN
            U2COU = BIDSP
*           RQ: AUCUNE RELATION D'ORDRE ENTRE "U1COU" ET "U2COU" POUR
*               NE PAS IMPOSER, PAR EXEMPLE, AU POINT INITIAL DE
*               CORRESPONDRE AU PLUS PETIT PARAMETRE.
            GOTO 200
  106    CONTINUE
            REGCOU = .TRUE.
            GOTO 200
  200    CONTINUE
*
         GOTO 205
*     END DO
  206 CONTINUE
*
*     -- LECTURE DES POINTS DU POLYNOME --
*
      SEGINI,MTEMP
      CALL LIROBJ ('POINT',IP,1,IRETOU)
      IF (IERR .NE. 0) RETURN
      ITEMP(1) = IP
      CALL LIROBJ ('POINT',IP,1,IRETOU)
      IF (IERR .NE. 0) RETURN
      ITEMP(2) = IP
*     DO
  305    CONTINUE
         CALL LIROBJ ('POINT',IP,0,IRETOU)
         IF (IRETOU .EQ. 1) THEN
            ITEMP(**) = IP
         ELSE
*           --> SORTIE DE BOUCLE
            GOTO 306
         END IF
         GOTO 305
*     END DO
  306 CONTINUE
      ND1COU = ITEMP(/1)
*
*     CREATION DES POLYNOMES REELS:
      N = ND1COU
      SEGINI,MCOFCO
      ICOFCO = MCOFCO
      SEGACT,MCOORD
      IF (IDIM .EQ. 3) THEN
         CALL DCOMP1(ITEMP,N,XCOOR,COFCOU(1,1),COFCOU(1,2),COFCOU(1,3))
      ELSE
         CALL DCOMP1(ITEMP,N,XCOOR,COFCOU(1,1),COFCOU(1,2),RBID)
      END IF
      SEGSUP,MTEMP
      SEGDES,MCOFCO
*
      CALL COURB1 (MCOURB,  LIGNE)
      IF (IERR .NE. 0) RETURN
      MCOFCO = ICOFCO
      SEGSUP,MCOFCO
      SEGSUP,MCOURB
*
      CALL ECROBJ ('MAILLAGE',LIGNE)
*
      END