Télécharger dedou.eso

Retour à la liste

Numérotation des lignes :

  1. C DEDOU SOURCE GF238795 16/06/30 21:15:00 8997
  2. SUBROUTINE DEDOU
  3. C
  4. IMPLICIT INTEGER(I-N)
  5. IMPLICIT REAL*8 (A-H,O-Z)
  6. -INC CCOPTIO
  7. -INC SMELEME
  8. -INC SMCOORD
  9. C
  10. SEGMENT TTRAV
  11. INTEGER ILIS(NNOE)
  12. ENDSEGMENT
  13. SEGMENT XDET(NNOE)
  14. SEGMENT ICPR(XCOOR(/1)/(IDIM+1))
  15. IF(IDIM.NE.2) THEN
  16. INTERR(1)=IDIM
  17. CALL ERREUR(709)
  18. RETURN
  19. ENDIF
  20. C
  21. C *** LECTURE DU MAILLAGE
  22. C
  23. CALL LIROBJ ('MAILLAGE',IPT1,1,IRETOU)
  24. IF(IERR.NE.0) RETURN
  25. SEGINI,MELEME=IPT1
  26. IF(LISOUS(/1).NE.0) THEN
  27. DO 1 I=1,LISOUS(/1)
  28. IPT3=LISOUS(I)
  29. SEGINI,IPT2=IPT3
  30. LISOUS(I)=IPT2
  31. SEGDES IPT2
  32. 1 CONTINUE
  33. ENDIF
  34. NBREF=0
  35. NBNN=NUM(/1)
  36. NBELEM=NUM(/2)
  37. NBSOUS=LISOUS(/1)
  38. SEGADJ MELEME
  39. SEGDES MELEME
  40. C
  41. C *** LECTURE DE LA LIGNE A DEDOUBLER
  42. C *** TTRAV CONTIENT LA LIGNE REORDONNEE ET ORIENTEE PAR LIGMAI
  43. C
  44. CALL LIROBJ ('MAILLAGE',IPT2,1,IRETOU)
  45. IF(IERR.NE.0) RETURN
  46. CALL LIGMAI(IPT2,TTRAV,0)
  47. IF(IERR.NE.0) THEN
  48. C Menage avant de quitter en erreur
  49. SEGACT MELEME*MOD
  50. IF(LISOUS(/1).NE.0) THEN
  51. DO 111 I=1,LISOUS(/1)
  52. IPT3=LISOUS(I)
  53. SEGSUP IPT3
  54. 111 CONTINUE
  55. ENDIF
  56. SEGSUP MELEME
  57. RETURN
  58. ENDIF
  59.  
  60. SEGACT TTRAV
  61. C
  62. C *** CREATION DE LA DEUXIEME LEVRE
  63. C
  64. SEGINI,IPT5=IPT2
  65. C
  66. C *** ON REGARDE SI LA FISSURE EST DEBOUCHANTE
  67. C
  68. CALL ECROBJ('MAILLAGE',MELEME)
  69. CALL PRCONT
  70. IF(IERR.NE.0) THEN
  71. C Menage avant de quitter en erreur
  72. SEGACT MELEME*MOD
  73. IF(LISOUS(/1).NE.0) THEN
  74. DO 112 I=1,LISOUS(/1)
  75. IPT3=LISOUS(I)
  76. SEGSUP IPT3
  77. 112 CONTINUE
  78. ENDIF
  79. SEGSUP MELEME
  80. SEGSUP IPT5
  81. RETURN
  82. ENDIF
  83. SEGACT MELEME
  84. IF(LISREF(/1).NE.0) THEN
  85. NBREF=0
  86. NBNN=NUM(/1)
  87. NBELEM=NUM(/2)
  88. NBSOUS=LISOUS(/1)
  89. SEGADJ MELEME
  90. ENDIF
  91. SEGDES MELEME
  92. CALL LIROBJ('MAILLAGE',IPT2,1,IRETOU)
  93. SEGACT IPT2
  94. DO 4 IPASS=1,2
  95. IF(IPASS.EQ.1) THEN
  96. I=1
  97. ELSE
  98. I=ILIS(/1)
  99. ENDIF
  100. N1=ILIS(I)
  101. IPT3=IPT2
  102. DO 2 ISOU=1,MAX(1,IPT2.LISOUS(/1))
  103. IF(IPT2.LISOUS(/1).NE.0) THEN
  104. IPT3=LISOUS(ISOU)
  105. SEGACT IPT3
  106. ENDIF
  107. DO 3 K=1,IPT3.NUM(/2)
  108. DO 3 J=1,IPT3.NUM(/1)
  109. IF(IPT3.NUM(J,K).EQ.N1) GO TO 21
  110. 3 CONTINUE
  111. 2 CONTINUE
  112. GOTO 4
  113. 21 CONTINUE
  114. C Le point N1 est une extremite qui appartient au contour
  115. C On rajoute a ILIS un autre point du contour
  116. DO 22 J=1,IPT3.NUM(/1)
  117. IF(IPT3.NUM(J,K).NE.N1) N2=IPT3.NUM(J,K)
  118. 22 CONTINUE
  119. NNOE=ILIS(/1)+1
  120. SEGADJ TTRAV
  121. IF(I.EQ.1) THEN
  122. DO 23 K=NNOE,2,-1
  123. ILIS(K)=ILIS(K-1)
  124. 23 CONTINUE
  125. ILIS(1)=N2
  126. ELSE
  127. ILIS(NNOE)=N2
  128. ENDIF
  129. 4 CONTINUE
  130. IF(IPT2.LISOUS(/1).NE.0) THEN
  131. DO 6 I=1,IPT2.LISOUS(/1)
  132. IPT3=LISOUS(I)
  133. SEGSUP IPT3
  134. 6 CONTINUE
  135. ENDIF
  136. SEGSUP IPT2
  137. C
  138. C *** AJOUT DE NOUVEAUX POINTS A MCOORD ET CREATION
  139. C *** D'UN ICPR DES NOEUDS A DEDOUBLER
  140. C
  141. NNOE=ILIS(/1)
  142. NDED=NNOE-2
  143. NNOEU=XCOOR(/1)/(IDIM+1)
  144. SEGINI ICPR
  145. NBPTS=NNOEU+NDED
  146. SEGADJ MCOORD
  147. DO 5 I=2,NNOE-1
  148. N1=ILIS(I)
  149. N2=I+NNOEU-1
  150. XCOOR((N2-1)*3+1)=XCOOR((N1-1)*3+1)
  151. XCOOR((N2-1)*3+2)=XCOOR((N1-1)*3+2)
  152. ICPR(N1)=I
  153. 5 CONTINUE
  154. ICPR(ILIS(1))=1
  155. ICPR(ILIS(NNOE))=NNOE
  156. C
  157. C *** CREATION DU TABLEAU XDET QUI CONTIENT LE
  158. C *** DETERMINANT DE DEUX VECTEURS CONSECUTIFS
  159. C
  160. SEGINI XDET
  161. N1=ILIS(1)
  162. N2=ILIS(2)
  163. VX1=XCOOR((N2-1)*3+1)-XCOOR((N1-1)*3+1)
  164. VY1=XCOOR((N2-1)*3+2)-XCOOR((N1-1)*3+2)
  165. DO 51 I=2,NNOE-1
  166. N3=ILIS(I+1)
  167. VX2=XCOOR((N3-1)*3+1)-XCOOR((N2-1)*3+1)
  168. VY2=XCOOR((N3-1)*3+2)-XCOOR((N2-1)*3+2)
  169. XDET(I)=VX1*VY2-VX2*VY1
  170. VX1=VX2
  171. VY1=VY2
  172. N1=N2
  173. N2=N3
  174. 51 CONTINUE
  175. C
  176. C *** RENUMEROTATION DES ELEMENTS DU MAILLAGE RESULTAT
  177. C
  178. SEGACT MELEME*MOD
  179. IPT1=MELEME
  180. DO 7 I=1,MAX(1,LISOUS(/1))
  181. IF(LISOUS(/1).NE.0) THEN
  182. IPT1=LISOUS(I)
  183. SEGACT IPT1*MOD
  184. ENDIF
  185. DO 8 J=1,IPT1.NUM(/2)
  186. DO 9 K=1,IPT1.NUM(/1)
  187. N1=IPT1.NUM(K,J)
  188. IN1=ICPR(N1)
  189. IF(IN1.GT.1.AND.IN1.LT.NNOE) GOTO 10
  190. 9 CONTINUE
  191. GOTO 8
  192. C *** L'element contient un noeud N1 sur la ligne
  193. C *** N2 est le noeud suivant (sur la ligne), N3 le noeud precedent,
  194. C *** N4 un noeud de l'element qui n'appartient pas a la ligne.
  195. C *** Si l'element est "au-dessus" on va en 13 pour renumeroter.
  196. 10 N2=ILIS(IN1+1)
  197. N3=ILIS(IN1-1)
  198. DO 11 K=1,IPT1.NUM(/1)
  199. N4=IPT1.NUM(K,J)
  200. IF(ICPR(N4).EQ.0) GO TO 12
  201. 11 CONTINUE
  202. C *** Cas particulier ou tous les noeuds de l'element
  203. C *** appartiennent a la ligne
  204. N4=IPT1.NUM(1,J)
  205. N5=IPT1.NUM(2,J)
  206. N6=IPT1.NUM(3,J)
  207. IN1=MIN(ICPR(N4),ICPR(N5),ICPR(N6))+1
  208. IF(XDET(IN1).GE.0) GOTO 13
  209. GOTO 8
  210. C *** Cas general
  211. 12 VX1=XCOOR((N2-1)*3+1)-XCOOR((N1-1)*3+1)
  212. VY1=XCOOR((N2-1)*3+2)-XCOOR((N1-1)*3+2)
  213. VX2=XCOOR((N1-1)*3+1)-XCOOR((N3-1)*3+1)
  214. VY2=XCOOR((N1-1)*3+2)-XCOOR((N3-1)*3+2)
  215. VX3=XCOOR((N4-1)*3+1)-XCOOR((N1-1)*3+1)
  216. VY3=XCOOR((N4-1)*3+2)-XCOOR((N1-1)*3+2)
  217. DET1=VX1*VY3-VY1*VX3
  218. DET2=VX2*VY3-VY2*VX3
  219. IF(XDET(IN1).GE.0) THEN
  220. IF(DET1.GE.0.AND.DET2.GE.0.) GOTO 13
  221. ELSE
  222. IF(DET1.GT.0.OR.DET2.GT.0.) GOTO 13
  223. ENDIF
  224. GOTO 8
  225. 13 DO 14 K=1,IPT1.NUM(/1)
  226. N5=IPT1.NUM(K,J)
  227. IN5=ICPR(N5)
  228. IF(IN5.GT.1.AND.IN5.LT.NNOE)
  229. & IPT1.NUM(K,J)=IN5+NNOEU-1
  230. 14 CONTINUE
  231. 8 CONTINUE
  232. 7 CONTINUE
  233. IF(LISOUS(/1).NE.0) THEN
  234. DO 15 I=1,LISOUS(/1)
  235. IPT1=LISOUS(I)
  236. SEGDES IPT1
  237. 15 CONTINUE
  238. ENDIF
  239. C
  240. C *** RENUMEROTATION DE LA DEUXIEME LEVRE
  241. C
  242. IPT1=IPT5
  243. DO 16 I=1,MAX(1,IPT5.LISOUS(/1))
  244. IF(IPT5.LISOUS(/1).NE.0) THEN
  245. IPT1=IPT5.LISOUS(I)
  246. SEGACT IPT1
  247. ENDIF
  248. DO 17 J=1,IPT1.NUM(/2)
  249. DO 18 K=1,IPT1.NUM(/1)
  250. N1=IPT1.NUM(K,J)
  251. IN1=ICPR(N1)
  252. IF(IN1.GT.1.AND.IN1.LT.NNOE) IPT1.NUM(K,J)=IN1+NNOEU-1
  253. 18 CONTINUE
  254. 17 CONTINUE
  255. 16 CONTINUE
  256. IF(IPT5.LISOUS(/1).NE.0) THEN
  257. DO 19 I=1,IPT5.LISOUS(/1)
  258. IPT1=IPT5.LISOUS(I)
  259. SEGDES IPT1
  260. 19 CONTINUE
  261. ENDIF
  262. SEGDES IPT5,MELEME
  263. SEGSUP TTRAV,XDET,ICPR
  264. CALL ECROBJ ('MAILLAGE',IPT5)
  265. CALL ECROBJ ('MAILLAGE',MELEME)
  266. RETURN
  267. END
  268.  
  269.  
  270.  
  271.  
  272.  
  273.  
  274.  
  275.  
  276.  
  277.  
  278.  

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