Télécharger la plaquette Cast3M


fr en

Télécharger courb1.eso

Retour à la liste

Numérotation des lignes : 

courb1

  1. C COURB1    SOURCE    PV        20/03/30    21:16:40     10567          
  2.       SUBROUTINE COURB1 (MCOURB,LIGNE)
  3.       implicit real*8 (a-h,o-z)
  4. ************************************************************************
  5. *
  6. *                             C O U R B 1
  7. *                             -----------
  8. *
  9. * FONCTION:
  10. * ---------
  11. *
  12. *     EXECUTE LA TACHE DE L'OPERATEUR "COURBE".
  13. *
  14. * MODULES UTILISES:
  15. * -----------------
  16. *
  17.       IMPLICIT INTEGER(I-N)
  18.  
  19. -INC PPARAM
  20. -INC CCOPTIO
  21. -INC CCGEOME
  22. -INC SMCOORD
  23. -INC SMELEME
  24. -INC TMCOURB
  25. *
  26. * PARAMETRES:   (E)=ENTREE   (S)=SORTIE   (+ = CONTENU DANS UN COMMUN)
  27. * -----------
  28. *
  29. *     MCOURB  (E)  SEGMENT ACTIF.
  30. *    +DENSIT  (E)  VOIR LE COMMUN "CGEOME".
  31. *    +IDIM    (E)  VOIR LE COMMUN "COPTIO".
  32. *    +MCOORD  (E)  VOIR LE COMMUN "COPTIO".
  33. *     LIGNE   (S)  OBJET 'MAILLAGE' CREE.
  34. *
  35. * VARIABLES:
  36. * ----------
  37. *
  38. *     NOXTRM = .TRUE.  SI AUCUN POINT-EXTREMITE CONVENABLE N'A ETE
  39. *              FOURNI (UTILISE DANS LA PROCEDURE INTERNE, A LA FIN).
  40. *     DIST   = DISTANCE ENTRE POINT FOURNI POUR EXTREMITE ET VERITABLE
  41. *              POINT EXTREME DE LA COURBE.
  42. *     X1COU,   )
  43. *     X2COU,   )  COORDONNEES DES POINTS EXTREMITES DE LA COURBE.
  44. *     Y1COU,   )
  45. *       ETC... )
  46. *
  47.       INTEGER PT0COU,LI0COU
  48.       LOGICAL NOXTRM,ltelq
  49.       REAL*8 X1COU,Y1COU,Z1COU,X2COU,Y2COU,Z2COU
  50.       REAL*8 X0COU,Y0COU,Z0COU,D0COU
  51. *
  52. * FONCTIONS:
  53. * ----------
  54. *
  55.       REAL*8 POLYNO
  56. *
  57. * AUTEUR, DATE DE CREATION:
  58. * -------------------------
  59. *
  60. *     PASCAL MANIGOT     10 SEPTEMBRE 1986
  61. *     P.M.   24/02/87 : REMODELAGE, AVEC UN NOUVEAU SEGMENT "MCOURB".
  62. *
  63. * LANGAGE:
  64. * ------
  65. *
  66. *     ESOPE + FORTRAN77 + EXTENSION: DECLARATION "REAL*8".
  67. *
  68. ************************************************************************
  69. *
  70.       SEGACT,MCOORD
  71. *
  72. *     RECHERCHE DES POINTS EXTREMES EN CAS DE DONNEE DE COURBES A
  73. *     RACCORDER:
  74. *
  75.       IF (LI1COU .NE. 0) THEN
  76. *        ON RELEVE LE DERNIER POINT DE LA LIGNE A RACCORDER EN TETE DE
  77. *        LA COURBE:
  78.          N = 1
  79. *        (CURIEUSEMENT, C'EST LA VALEUR "1" QUI PERMET D'EXTRAIRE LE
  80. *        DERNIER POINT)
  81.          LI0COU = LI1COU
  82.          IPT6=LI0COU
  83.          SEGACT IPT6
  84.          CALL EXTRPO (LI0COU,N,  PT0COU)
  85.          IF (IERR .NE. 0) RETURN
  86.          PT1COU = PT0COU
  87.       END IF
  88. *
  89.       IF (LI2COU .NE. 0) THEN
  90. *        ON RELEVE LE 1ER POINT DE LA LIGNE A RACCORDER A LA FIN DE LA
  91. *        COURBE:
  92.          N = 2
  93.          LI0COU = LI2COU
  94.          IPT6=LI0COU
  95.          SEGACT IPT6
  96.          CALL EXTRPO (LI0COU,N,  PT0COU)
  97.          IF (IERR .NE. 0) RETURN
  98.          PT2COU = PT0COU
  99.       END IF
  100. *
  101. *     CALCUL DES COORDONNEES DES POINTS EXTREMES.
  102. *
  103.       MCOFCO = ICOFCO
  104.       SEGACT,MCOFCO
  105.       X1COU = POLYNO (COFCOU(1,1),ND1COU,1,U1COU)
  106.       X2COU = POLYNO (COFCOU(1,1),ND1COU,1,U2COU)
  107.       Y1COU = POLYNO (COFCOU(1,2),ND1COU,1,U1COU)
  108.       Y2COU = POLYNO (COFCOU(1,2),ND1COU,1,U2COU)
  109.       IF (IDIM .EQ. 3) THEN
  110.          Z1COU = POLYNO (COFCOU(1,3),ND1COU,1,U1COU)
  111.          Z2COU = POLYNO (COFCOU(1,3),ND1COU,1,U2COU)
  112.       END IF
  113.       SEGDES,MCOFCO
  114. *
  115. *     LES POINTS EXTREMES FOURNIS EXPLICITEMENT (LE CAS ECHEANT)
  116. *     SONT-ILS ACCEPTABLES ?
  117. *     (SINON, CREATION DE NOUVEAUX)
  118. *
  119. *     APPEL PROCEDURE INTERNE:
  120.          PT0COU = PT1COU
  121.          X0COU = X1COU
  122.          Y0COU = Y1COU
  123.          IF (IDIM .EQ. 3) Z0COU = Z1COU
  124.          D0COU = D1COU
  125. *        ASSIGN 105 TO IRTURN
  126.          irturn=105
  127.          GOTO 500
  128.   105    CONTINUE
  129. *     RETOUR DE PROCEDURE INTERNE.
  130.       IF (PT1COU .NE. 0 .AND. PT1COU .NE. PT0COU) THEN
  131.          IF (LI1COU .EQ. 0) THEN
  132.             CALL ERREUR (295)
  133.          ELSE
  134.             CALL ERREUR (297)
  135.          END IF
  136. *        IL N'Y A PAS LIEU DE S'ARRETER POUR SI PEU.
  137.       END IF
  138.       PT1COU = PT0COU
  139.       D1COU = D0COU
  140. *
  141. *     APPEL PROCEDURE INTERNE:
  142.          PT0COU = PT2COU
  143.          X0COU = X2COU
  144.          Y0COU = Y2COU
  145.          IF (IDIM .EQ. 3) Z0COU = Z2COU
  146.          D0COU = D2COU
  147. *        ASSIGN 205 TO IRTURN
  148.          irturn=205
  149.          GOTO 500
  150.   205    CONTINUE
  151. *     RETOUR DE PROCEDURE INTERNE.
  152.       IF (PT2COU .NE. 0 .AND. PT2COU .NE. PT0COU) THEN
  153.          IF (LI2COU .EQ. 0) THEN
  154.             CALL ERREUR (296)
  155.          ELSE
  156.             CALL ERREUR (298)
  157.          END IF
  158. *        IL N'Y A PAS LIEU DE S'ARRETER POUR SI PEU.
  159.       END IF
  160.       PT2COU = PT0COU
  161.       D2COU = D0COU
  162. *
  163. *     LES EXTREMITES ETANT MAINTENANT BIEN DEFINIES, ON APPELLE LE
  164. *     SOUS-PROGRAMME DE MAILLAGE.
  165. *
  166.       CALL COURB2 (MCOURB,  LIGNE)
  167.       IF (IERR .NE. 0) RETURN
  168. *
  169. *     SI DES LIGNES ONT ETE DONNEES AU LIEU DE POINTS EXTREMES,
  170. *     L'OBJET RESULTAT N'EST PAS CE QUI VIENT D'ETRE CREE MAIS LA
  171. *     REUNION DES ANCIENNES LIGNES ET DE CE QUI VIENT D'ETRE CREE:
  172. *
  173.       IF (LI1COU .NE. 0) THEN
  174.          LI0COU = LI1COU
  175.          ltelq=.false.
  176.          CALL FUSE (LI0COU,LIGNE,  IP,ltelq)
  177.          IF (IERR .NE. 0) RETURN
  178.          LIGNE = IP
  179.       END IF
  180.       IF (LI2COU .NE. 0) THEN
  181.          LI0COU = LI2COU
  182.          ltelq=.false.
  183.          CALL FUSE (LIGNE,LI0COU,  IP,ltelq)
  184.          IF (IERR .NE. 0) RETURN
  185.          LIGNE = IP
  186.       END IF
  187. *
  188.       IF (IIMPI .EQ. 342) THEN
  189.          IDIMP1 = IDIM + 1
  190.          DO 400 IB=1,nbpts*idimp1,IDIMP1
  191.             IB2 = IB / IDIMP1 + 1
  192.             WRITE (IOIMP,'(1X,I5,3(1X,G12.5))') IB2,XCOOR(IB)
  193.      &      ,XCOOR(IB+1),XCOOR(IB+IDIM)
  194.   400       CONTINUE
  195. *        END DO
  196.       END IF
  197. *
  198.       RETURN
  199. *
  200. *     ***********************
  201. *     *  PROCEDURE INTERNE  *
  202. *     ***********************
  203. *
  204. *     PARAMETRES:
  205. *
  206. *     PT0COU  (E)  POINT EXTREME PROPOSE.
  207. *             (S)  POINT EXTREME FINALEMENT RETENU.
  208. *     X0COU   (E)  )
  209. *     Y0COU   (E)  )) COORDONNEES DU VERITABLE POINT EXTREME.
  210. *     Z0COU   (E)  )
  211. *     D0COU   E/S  DENSITE ASSOCIEE (LARGEUR DE MAILLE).
  212. *     MCOORD  (E)  SEGMENT ACTIF.
  213. *             (S)  CE SEGMENT EST EVENTUELLEMENT ETENDU.
  214. *
  215.   500 CONTINUE
  216. *
  217.       IF (PT0COU .NE. 0) THEN
  218.          IPD = (PT0COU - 1) * (IDIM + 1)
  219.          X0DONN = XCOOR(IPD+1)
  220.          Y0DONN = XCOOR(IPD+2)
  221.          IF (IDIM .EQ. 3) THEN
  222.             Z0DONN = XCOOR(IPD+3)
  223.             DIST = SQRT((X0COU-X0DONN)**2 + (Y0COU-Y0DONN)**2
  224.      &                + (Z0COU-Z0DONN)**2)
  225.          ELSE
  226.             DIST = SQRT((X0COU-X0DONN)**2 + (Y0COU-Y0DONN)**2)
  227.          END IF
  228.          IF (D0COU .EQ. 0.) THEN
  229.             IPD = PT0COU * (IDIM + 1)
  230.             D0DONN = XCOOR(IPD)
  231.             PETIT = D0DONN * 0.1
  232.          ELSE
  233.             PETIT = D0COU * 0.1
  234.          END IF
  235.          NOXTRM = DIST.GT.PETIT
  236.       ELSE
  237.          NOXTRM = .TRUE.
  238.       END IF
  239. *
  240.       IF (NOXTRM) THEN
  241. *        UN POINT EXTREME NON ACCEPTABLE A ETE FOURNI OU BIEN AUCUN
  242. *        POINT N'A ETE FOURNI.
  243. *        CREATION D'UN NOUVEAU POINT POUR L'EXTREMITE:
  244.          IF (D0COU .EQ. 0.) THEN
  245.             D0COU = DENSIT
  246.          END IF
  247.          CALL CREPO2 (X0COU,Y0COU,Z0COU,D0COU,  PT0COU)
  248.          IF (IERR .NE. 0) RETURN
  249.       ELSE IF (D0COU .EQ. 0.) THEN
  250. *        POINT IMPOSE CORRECT ET PAS DE DENSITE IMPOSEE
  251. *        --> ON PREND CELLE DU POINT IMPOSE:
  252.          D0COU = D0DONN
  253. *     ELSE
  254. *        SI POINT IMPOSE CORRECT ET DENSITE FOURNIE, RIEN A FAIRE.
  255.       END IF
  256. *
  257.       if (irturn.eq.105) goto 105
  258.       if (irturn.eq.205) goto 205
  259.       call erreur(5)
  260. *
  261.       END
  262.  
  263.  
  264.  
  265.  
  266.  
  267.  
  268.  
  269.  
  270.  
  271.  
  272.  
  273.  
  274.  
  275.  
  276.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales