Télécharger deda.eso

Retour à la liste

Numérotation des lignes :

  1. C DEDA SOURCE BP208322 16/11/18 21:16:11 9177
  2. SUBROUTINE DEDA
  3. C ******************************************************************
  4. C
  5. C LOG1 = DEDA PO1 MAIL1 (FLO1) ;
  6. C
  7. C OBJET :
  8. C _______
  9. C
  10. C L'OPERATEUR DEDA DETERMINE SI UN POINT PO1 EST SITUE A L'INTERIEUR
  11. C DU MAILLAGE D'UN CONTOUR (EN 2D) OU D'UNE ENVELOPPE (EN 3D)
  12. C
  13. C DATE : 25.07.14
  14. C ______
  15. C
  16. C AUTEURS : F. DI PAOLA
  17. C _________
  18. C
  19. C ******************************************************************
  20. IMPLICIT INTEGER(I-N)
  21. IMPLICIT REAL*8 (A-H,O-Z)
  22. C
  23. -INC CCOPTIO
  24. -INC SMCOORD
  25. -INC SMELEME
  26. -INC CCGEOME
  27. -INC SMLENTI
  28. C
  29. C Un logique, resultat du programme
  30. LOGICAL BOOL1
  31. C
  32. C Une liste d'entiers ca sert toujours
  33. POINTEUR LV1.MLENTI
  34. C
  35. C Une structure pour decrire les elements adjacents du maillage
  36. C contour/enveloppe
  37. SEGMENT,MADJACEN
  38. INTEGER LEAC(NBL1,IDIM,2)
  39. ENDSEGMENT
  40. POINTEUR ILEA1.MADJACEN
  41. C
  42. C
  43. C ===============================
  44. C --- 1.LECTURE DES DONNEES ET TESTS ---
  45. C ===============================
  46. C
  47. C Acquisition du point
  48. CALL LIROBJ('POINT',NP1,1,IRETOU)
  49. IF (IERR.NE.0) THEN
  50. C ON A PAS TROUVE LE POINT
  51. CALL ERREUR(504)
  52. GOTO 999
  53. ENDIF
  54. C
  55. C Acquisition du maillage
  56. CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU)
  57. IF (IERR.NE.0) THEN
  58. C ON A PAS TROUVE LE MAILLAGE
  59. CALL ERREUR(503)
  60. GOTO 999
  61. ENDIF
  62. SEGACT IPT1
  63. NBSZ=IPT1.LISOUS(/1)
  64. NTYP=IPT1.ITYPEL
  65. C
  66. C Acquisition d'une tolerance pour la mesure de l'angle solide
  67. C (facultative, 1E-9 par defaut)
  68. CALL LIRREE(XTOL,0,IRETOU)
  69. IF (IRETOU.EQ.0) XTOL=1D-9
  70. C
  71. C ====================================
  72. C --- 2.TESTS SUR LA VALIDITE DES DONNEES ---
  73. C ET AJUSTEMENTS EVENTUELS
  74. C ====================================
  75. C
  76. C Valeur de la dimension
  77. IF ((IDIM.LT.2).OR.(IDIM.GT.3)) THEN
  78. INTERR(1)=IDIM
  79. C FONCTION INDISPONIBLE EN DIMENSION %I1
  80. SEGDES IPT1
  81. CALL ERREUR(709)
  82. GOTO 999
  83. ENDIF
  84. C
  85. C Maillage elementaire
  86. IF (NBSZ.NE.0) THEN
  87. C OPERATION INTERDITE SUR UN OBJET COMPLEXE
  88. SEGDES IPT1
  89. CALL ERREUR(25)
  90. GOTO 999
  91. ENDIF
  92. C
  93. C Type d'elements
  94. IF (((IDIM.EQ.2).AND.(NTYP.NE.2)).OR.
  95. & ((IDIM.EQ.3).AND.(NTYP.NE.4))) THEN
  96. C TYPE D'ELEMENTS INCORRECT
  97. SEGDES IPT1
  98. CALL ERREUR(16)
  99. GOTO 999
  100. ENDIF
  101. C
  102. C Orientation des elements du maillage (appel a VERSENS)
  103. CALL ECROBJ('MAILLAGE',IPT1)
  104. CALL VERSEN
  105. CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU)
  106. IF (IERR.NE.0) THEN
  107. GOTO 999
  108. ENDIF
  109. SEGACT IPT1
  110. C
  111. C Le maillage doit etre ferme, on le verifie en construisant la
  112. C table des elements adjacents
  113. C Le tableau ILEA1.LEAC comporte 3 dimensions : ILEA1.LEAC(I,J,K)
  114. C dimension 1 : I est le numero de l'element du contour/enveloppe
  115. C dimension 2 : J est le numero du noeud de l'element I
  116. C dimension 3 : K=1 --> renvoie le numero de l'element adjacent a
  117. C l'element I par rapport au noeud J
  118. C K=2 --> renvoie le numero du noeud de l'element
  119. C adjacent situe en vis a vis du noeud J
  120. C On a donc les symetries suivantes :
  121. C si ILEA1.LEAC(I,J,1) = I' et ILEA1.LEAC(I,J,2) = J'
  122. C alors ILEA1.LEAC(I',J',1) = I et ILEA1.LEAC(I',J',2) = J
  123. C
  124. C Initialisation de la table des elements adjacents
  125. NBL1=IPT1.NUM(/2)
  126. SEGINI ILEA1
  127. JG=IPT1.NUM(/1)
  128. SEGINI LV1
  129. C Nombre de noeuds en commun a trouver pour adjacence
  130. NNREF=IPT1.NUM(/1)-1
  131. C Somme des numeros des noeuds
  132. IF (IDIM.EQ.2) THEN
  133. NSREF=1+2
  134. ELSE
  135. NSREF=1+2+3
  136. ENDIF
  137. C Boucle sur les elements de IPT1
  138. DO I=1,IPT1.NUM(/2)
  139. C Numeros des noeuds de l'element I
  140. DO J=1,IPT1.NUM(/1)
  141. LV1.LECT(J)=IPT1.NUM(J,I)
  142. ENDDO
  143. C On va detrminer tous les voisins de l'element I
  144. C Deuxieme boucle sur les elements de numero superieurs a I
  145. DO II=I+1,IPT1.NUM(/2)
  146. NNC=0
  147. NSOMA=0
  148. NSOMB=0
  149. C Test si l'element II a des noeuds communs a l'element I
  150. DO J=1,IPT1.NUM(/1)
  151. NTEST=IPT1.NUM(J,II)
  152. DO K=1,IPT1.NUM(/1)
  153. IF (NTEST.EQ.LV1.LECT(K)) THEN
  154. NNC=NNC+1
  155. NSOMA=NSOMA+K
  156. NSOMB=NSOMB+J
  157. ENDIF
  158. ENDDO
  159. ENDDO
  160. C Si l'element II est bien adjacent a l'element I
  161. IF (NNC.EQ.NNREF) THEN
  162. NI=NSREF-NSOMA
  163. NII=NSREF-NSOMB
  164. ILEA1.LEAC(I,NI,1)=II
  165. ILEA1.LEAC(I,NI,2)=NII
  166. ILEA1.LEAC(II,NII,1)=I
  167. ILEA1.LEAC(II,NII,2)=NI
  168. ENDIF
  169. ENDDO
  170. C Test si on a bien trouve un voisin pour chaque cote de I
  171. DO J=1,IPT1.NUM(/1)
  172. IF (ILEA1.LEAC(I,J,1).EQ.0) THEN
  173. C Le contour n'est pas reconnu ferme
  174. SEGDES IPT1
  175. SEGSUP ILEA1
  176. CALL ERREUR(28)
  177. GOTO 999
  178. ENDIF
  179. ENDDO
  180. ENDDO
  181. C
  182. C
  183. C ==========================
  184. C --- 3.REALISATION DE LA TACHE ---
  185. C ==========================
  186. C
  187. CALL DEDANS(NP1,IPT1,XTOL,BOOL1)
  188. IF (IERR.EQ.0) CALL ECRLOG(BOOL1)
  189. GOTO 999
  190. C
  191. 999 END
  192.  
  193.  
  194.  
  195.  
  196.  

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