Télécharger la plaquette Cast3M


fr en

Télécharger racli1.eso

Retour à la liste

Numérotation des lignes : 

racli1

  1. C RACLI1    SOURCE    BP208322  16/11/18    21:20:40     9177           
  2.       SUBROUTINE RACLI1(L1,IPE, NL1)
  3.       IMPLICIT INTEGER(I-N)
  4.       IMPLICIT REAL*8 (A-H,O-Z)
  5. ************************************************************************
  6. *
  7. *                             R A C L I 1
  8. *                             -----------
  9. *
  10. * FONCTION:
  11. * ---------
  12. *
  13. *     CREER UNE LIGNE 'NL1' S'APPUYANT SUR LA LIGNE 'L1'
  14. *     ET FINISSANT EN UN POINT E
  15. *     L'ORIENTATION EST LIGNE-POINT
  16. *
  17. * MODULES UTILISES:
  18. * -----------------
  19. *
  20. -INC CCGEOME
  21.  
  22. -INC PPARAM
  23. -INC CCOPTIO
  24. -INC SMELEME
  25. *
  26. * PARAMETRES:   (E)=ENTREE   (S)=SORTIE   (+ = CONTENU DANS UN COMMUN)
  27. * -----------
  28. *
  29. *     L1      (E)  LIGNE
  30. *     IPE     (E)  POINT
  31. *             (S)  ATTENTION: LA DENSITE DU POINT PEUT ETRE MODIFIEE
  32. *                  (EN FONCTION DE LA DENSITE SUR "L1").
  33. *     NL1     (S)  LIGNE DE RACCORDEMENT LIGNE-POINT
  34. *
  35. * CONSTANTES:
  36. * -----------
  37. *
  38.       PARAMETER (DEMI=0.5D0)
  39. *
  40. * VARIABLES:
  41. * ----------
  42. *
  43. *     NBNOEU = NOMBRE DE NOEUD
  44. *     NBELEM = NOMBRE D'ELEMENT
  45. *
  46.       INTEGER NBNOEU,NBELEM,NL,N,
  47.      &        ITYPLM,NBSOUS,NBREF,NBNN
  48. *
  49. * AUTEUR, DATE DE CREATION:
  50. * -------------------------
  51. *
  52. *     LIONEL VIVAN       23 NOVEMBRE 1987
  53. *
  54. * LANGAGE:
  55. * --------
  56. *
  57. *     ESOPE + FORTRAN77
  58. *
  59. ************************************************************************
  60. *
  61.       MELEME=L1
  62.       SEGACT,MELEME
  63.       NL=LISOUS(/1)
  64.       IF (NL.NE.0) THEN
  65.          CALL ERREUR(25)
  66.          RETURN
  67.       END IF
  68.       IF (ILCOUR.EQ.0) THEN
  69.          CALL ERREUR(16)
  70.          RETURN
  71.       END IF
  72.       ITYPLM=KDEGRE(ILCOUR)
  73.       IF (ITYPLM.EQ.0) THEN
  74.          CALL ERREUR(16)
  75.          RETURN
  76.       END IF
  77.       NBNN=NBNNE(ITYPLM)
  78.       IF (NBNN.NE.2.AND.NBNN.NE.3) THEN
  79.          CALL ERREUR(16)
  80.          RETURN
  81.       END IF
  82.       NBSOUS=0
  83.       NBREF=0
  84.       NBNOEU=NUM(/1)
  85.       NBELEM=NUM(/2)
  86.       IP8=NUM(1,NBELEM)
  87.       IP9=NUM(NBNOEU,NBELEM)
  88. *
  89.       CALL EXCOO1(IPE,XE,YE,ZE,DE)
  90.       CALL EXCOO1(IP8,X8,Y8,Z8,D8)
  91.       CALL EXCOO1(IP9,X9,Y9,Z9,D9)
  92.       PS=(X9-X8)*(XE-X9)+(Y9-Y8)*(YE-Y9)+(Z9-Z8)*(ZE-Z9)
  93. *
  94.       DE9=SQRT((X9-XE)**2+(Y9-YE)**2+(Z9-ZE)**2)
  95.       D98=SQRT((X8-X9)**2+(Y8-Y9)**2+(Z8-Z9)**2)
  96.       IF (PS.GE.0.) THEN
  97. *
  98. *        POINT E HORS DE LA DROITE
  99. *
  100.          IF (DE9 .GT. (D98/2.D0) ) THEN
  101. *
  102. *           ON CREE UNE DROITE   NL1 = L1 + DROITE(P9,PE)
  103. *
  104.             CALL ECROBJ('POINT',IPE)
  105.             CALL ECROBJ('MAILLAGE',L1)
  106.             CALL LIGNE(1,1,DEN1,DEN2,N)
  107.             IF (IERR.NE.0) RETURN
  108.             CALL LIROBJ('MAILLAGE',NL1,1,IRETOU)
  109.             IF (IERR.NE.0) RETURN
  110.          ELSE
  111. *
  112. *           ON RALLONGE LE DERNIER ELEMENT
  113. *
  114.             DE = D9
  115.             CALL MODPOI (XE,YE,ZE,DE,IPE)
  116.             SEGINI,IPT1
  117.             IPT1.ITYPEL=ITYPLM
  118.             NL1=IPT1
  119.             IPT1.NUM(NBNOEU,NBELEM)=IPE
  120.             IPT1.NUM(1,NBELEM)=NUM(1,NBELEM)
  121.             IPT1.ICOLOR(NBELEM)=IDCOUL
  122.             IF (NBNOEU.EQ.3) THEN
  123.                X7=(XE+X8)*DEMI
  124.                Y7=(YE+Y8)*DEMI
  125.                Z7=(ZE+Z8)*DEMI
  126.                D7=(DE+D8)*DEMI
  127.                CALL CREPO2(X7,Y7,Z7,D7,IP7)
  128.                IPT1.NUM(2,NBELEM)=IP7
  129.             END IF
  130.             DO 12 I=1,(NBELEM-1)
  131.                IPT1.ICOLOR(I)=IDCOUL
  132.                DO 12 J=1,NBNOEU
  133.                   IPT1.NUM(J,I)=NUM(J,I)
  134. 12                CONTINUE
  135. *              END DO
  136. *           END DO
  137.             SEGDES,IPT1
  138.          END IF
  139.       ELSE
  140. *
  141. *        LE POINT E SE SITUE SUR LA DROITE
  142. *
  143. *        RECHERCHE DE L'ELEMENT I OU SE TROUVE LE POINT E
  144. *
  145. 105      IF (DE9.GT.D98) THEN
  146.             NBELEM=NBELEM-1
  147.             IF (NBELEM.EQ.0) THEN
  148.                CALL ERREUR(399)
  149.                RETURN
  150.             END IF
  151.             IP9=NUM(NBNOEU,NBELEM)
  152.             IP8=NUM(1,NBELEM)
  153.             CALL EXCOO1(IP9,X9,Y9,Z9,D9)
  154.             CALL EXCOO1(IP8,X8,Y8,Z8,D8)
  155.             DE9=SQRT((X9-XE)**2+(Y9-YE)**2+(Z9-ZE)**2)
  156.             D98=SQRT((X8-X9)**2+(Y8-Y9)**2+(Z8-Z9)**2)
  157.             GOTO 105
  158.          END IF
  159.          IF (DE9 .LE. (D98/2.D0) ) THEN
  160. *
  161. *           LE POINT E  EST PROCHE DU POINT 9
  162. *
  163.             DE = D9
  164.             CALL MODPOI (XE,YE,ZE,DE,IPE)
  165.             SEGINI,IPT1
  166.             IPT1.ITYPEL=ITYPLM
  167.             NL1=IPT1
  168.             IPT1.NUM(NBNOEU,NBELEM)=IPE
  169.             IPT1.NUM(1,NBELEM)=NUM(1,NBELEM)
  170.             IPT1.ICOLOR(NBELEM)=IDCOUL
  171.             IF (NBNOEU.EQ.3) THEN
  172.                X7=(X8+XE)*DEMI
  173.                Y7=(Y8+YE)*DEMI
  174.                Z7=(Z8+ZE)*DEMI
  175.                D7=(D8+DE)*DEMI
  176.                CALL CREPO2(X7,Y7,Z7,D7,IP7)
  177.                IPT1.NUM(2,NBELEM)=IP7
  178.             END IF
  179.             DO 22 I=1,(NBELEM-1)
  180.                IPT1.ICOLOR(I)=IDCOUL
  181.                DO 22 J=1,NBNOEU
  182.                   IPT1.NUM(J,I)=NUM(J,I)
  183. 22                CONTINUE
  184. *              END DO
  185. *           END DO
  186.             SEGDES,IPT1
  187.          ELSE
  188. *
  189. *           LE POINT E  EST PROCHE DU POINT 8
  190. *
  191.             NBELEM = NBELEM - 1
  192.             IF (NBELEM.LE.0) THEN
  193. *              RAYON TROP GRAND
  194.                CALL ERREUR(399)
  195.                RETURN
  196.             END IF
  197. *
  198.             DE = D8
  199.             CALL MODPOI (XE,YE,ZE,DE,IPE)
  200.             SEGINI,IPT1
  201.             IPT1.ITYPEL=ITYPLM
  202.             NL1=IPT1
  203.             IPT1.NUM(NBNOEU,NBELEM)=IPE
  204.             IPT1.NUM(1,NBELEM)=NUM(1,NBELEM)
  205.             IPT1.ICOLOR(NBELEM)=IDCOUL
  206.             IF (NBNOEU.EQ.3) THEN
  207.                IP6=NUM(1,NBELEM)
  208.                CALL EXCOO1(IP6,X6,Y6,Z6,D6)
  209.                X7=(XE+X6)*DEMI
  210.                Y7=(YE+Y6)*DEMI
  211.                Z7=(ZE+Z6)*DEMI
  212.                D7=(DE+D6)*DEMI
  213.                CALL CREPO2(X7,Y7,Z7,D7,IP7)
  214.                IPT1.NUM(2,NBELEM)=IP7
  215.             END IF
  216.             DO 32 I=1,(NBELEM-1)
  217.                IPT1.ICOLOR(I)=IDCOUL
  218.                DO 32 J=1,NBNOEU
  219.                   IPT1.NUM(J,I)=NUM(J,I)
  220. 32                CONTINUE
  221. *              END DO
  222. *           END DO
  223.             SEGDES,IPT1
  224.          END IF
  225.       END IF
  226.       SEGDES,MELEME
  227. *
  228.       END
  229.  
  230.  
  231.  
  232.  
  233.  
  234.  
  235.  
  236.  
  237.  
  238.  

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