Télécharger disjo.eso

Retour à la liste

Numérotation des lignes :

  1. C DISJO SOURCE CHAT 10/12/21 21:15:07 6831
  2. SUBROUTINE disjo(IPT1,IPT2,MELEME,ipt4,ipt5,icpr)
  3. *
  4. * a partir de deux maillages elementaires de meme itypel (ipt1,ipt2)
  5. * realise trois maillages : meleme intersection de ipt1 et ipt2
  6. * ipt4 partie de ipt1 pas dans ipt2
  7. * ipt5 partiere de ipt2 pas dans ipt1
  8. * les pointeurs valent zero si rien dedans
  9.  
  10. IMPLICIT INTEGER(I-N)
  11. -INC CCOPTIO
  12. -INC SMELEME
  13. -INC SMCOORD
  14. SEGMENT INV(NBT)
  15. SEGMENT NINV(NBNO)
  16. SEGMENT NPOS(NBNO)
  17.  
  18. SEGMENT IVU(NBVU)
  19. segment icpr(ino)
  20.  
  21. SEGACT IPT1,IPT2
  22.  
  23. * Type d'élément incorrect ?
  24. IF (IPT1.ITYPEL .NE.IPT2.ITYPEL ) CALL ERREUR(16)
  25. IF (IPT1.NUM(/1).NE.IPT2.NUM(/1)) CALL ERREUR(16)
  26. IF (IERR.NE.0) RETURN
  27.  
  28. NBREF = 0
  29. NBNN = IPT1.NUM(/1)
  30. NBELE1 = IPT1.NUM(/2)
  31. NBELE2 = IPT2.NUM(/2)
  32.  
  33. * DETERMINATION DU NOMBRE DE NOEUDS
  34. SEGACT MCOORD
  35. * SEGINI ICPR
  36. do io=1,icpr(/1)
  37. icpr(io)=0
  38. enddo
  39. NBNO=0
  40. DO I=1,NBELE1
  41. DO 15 J=1,NBNN
  42. IPT=IPT1.NUM(J,I)
  43. IF (ICPR(IPT).NE.0) GOTO 15
  44. ICPR(IPT)=NBNO
  45. 15 CONTINUE
  46. ENDDO
  47.  
  48. * NB MAX ELEMENTS TOUCHANT UN NOEUD
  49. SEGINI NINV,NPOS
  50. DO I=1,NBELE1
  51. DO J=1,NBNN
  52. NINV(ICPR(IPT1.NUM(J,I)))=NINV(ICPR(IPT1.NUM(J,I)))+1
  53. ENDDO
  54. ENDDO
  55. NBC=0
  56. NBT=0
  57. DO I=1,NBNO
  58. NBC=MAX(NBC,NINV(I))
  59. NPOS(I)=NBT
  60. NBT=NBT+NINV(I)
  61. NINV(I)=0
  62. ENDDO
  63. SEGINI INV
  64. DO I=1,NBELE1
  65. DO J=1,NBNN
  66. IPP=ICPR(IPT1.NUM(J,I))
  67. NINV(IPP)=NINV(IPP)+1
  68. INV(NPOS(IPP)+NINV(IPP))=I
  69. ENDDO
  70. ENDDO
  71.  
  72. * Création table d'indicateur de noeud déjà trouvé
  73. NBVU=NBNN
  74. SEGINI, IVU
  75.  
  76. * CREATION DE LA DIFFERENCE SYMETRIQUE
  77. NBSOUS=0
  78. nbref=0
  79. NBELEM=NBELE1+NBELE2
  80. SEGINI MELEME
  81. DO I=1,NBELE1
  82. ICOLOR(I)=IPT1.ICOLOR(I)
  83. DO J=1,NBNN
  84. NUM(J,I)=IPT1.NUM(J,I)
  85. ENDDO
  86. ENDDO
  87.  
  88. DO I=1,NBELE2
  89. ICOLOR(I+NBELE1)=IPT2.ICOLOR(I)
  90. DO J=1,NBNN
  91. NUM(J,I+NBELE1)=IPT2.NUM(J,I)
  92. ENDDO
  93. ENDDO
  94. nbelem=0
  95. DO 2 I=1,NBELE2
  96. DO J=1,NBNN
  97. * write(6,* ) 'NUM(J,I+NBELE1)',NUM(J,I+NBELE1)
  98. IPP=ICPR(NUM(J,I+NBELE1))
  99. IF (IPP.EQ.0) GOTO 2
  100. DO 23 K=1,NINV(IPP)
  101. IEL=INV(NPOS(IPP)+K)
  102. * Comparaison des numéros de noeud de l'élément
  103. * ICOIN=nb de noeuds qui conviennent
  104. ICOIN=0
  105. DO M=1,NBNN
  106. IVU(M)=0
  107. ENDDO
  108. DO 24 L=1,NBNN
  109. DO M=1,NBNN
  110. *PM On ne teste que les noeuds non encore identifiés.
  111. IF (NUM(M,IEL).EQ.NUM(L,I+NBELE1) .AND.
  112. & IVU(M).EQ.0) THEN
  113. ICOIN = ICOIN + 1
  114. IVU(M) = 1
  115. GOTO 24
  116. ENDIF
  117. ENDDO
  118. 24 CONTINUE
  119.  
  120. IF (ICOIN.NE.NBNN) GOTO 23
  121. * Les deux élements coincident
  122. NUM(1,I+NBELE1)=-NUM(1,I+NBELE1)
  123. NUM(1,IEL)=0
  124. NBELEM=NBELEM+1
  125. * WRITE (6,*) ' COINCIDE ',I,IEL,NBELEM,NBELE1,NBELE2,NBNN
  126. GOTO 2
  127. 23 CONTINUE
  128. ENDDO
  129. 2 CONTINUE
  130.  
  131. * RETASSER LE MELEME RÉSULTAT
  132. IPT3=MELEME
  133. * write(6,*) 'nbelem ',nbelem
  134. IF(NBELEM.EQ.0) then
  135. * les maillages sont disjoints pas d'intersection
  136. meleme=0
  137. else
  138. nbmil=nbelem
  139. SEGINI MELEME
  140. nbnn=ipt1.num(/1)
  141. nbelem= nbele1 - nbmil
  142. if( nbelem.eq.0) then
  143. * le premier ipt1 etait inclus dans ipt2
  144. ipt4=0
  145. else
  146. segini ipt4
  147. ipt4.itypel=IPT1.ITYPEL
  148. endif
  149. nbelem= nbele2 - nbmil
  150. if( nbelem.eq.0) then
  151. * le ipt2 etait inclus dans ipt1
  152. ipt5=0
  153. else
  154. segini ipt5
  155. ipt5.itypel=IPT1.ITYPEL
  156. endif
  157. ITYPEL=IPT1.ITYPEL
  158. I=0
  159. I4=0
  160. I5=0
  161. DO J=1,NBELE1+nbele2
  162. IF(ipt3.num(1,j).eq.0) go to 36
  163. IF (IPT3.NUM(1,J).lt.0) then
  164. I=I+1
  165. DO K=1,NBNN
  166. NUM(K,I)=abs(IPT3.NUM(K,J))
  167. ENDDO
  168. ICOLOR(I)=IPT3.ICOLOR(J)
  169. ELSEIF (J.le.nbele1) then
  170. I4=I4+1
  171. DO K=1,NBNN
  172. ipt4.NUM(K,I4)=IPT3.NUM(K,J)
  173. ENDDO
  174. ipt4.ICOLOR(I4)=IPT3.ICOLOR(J)
  175. ELSE
  176. I5=I5+1
  177. DO K=1,NBNN
  178. ipt5.NUM(K,I5)=IPT3.NUM(K,J)
  179. ENDDO
  180. ipt5.ICOLOR(I5)=IPT3.ICOLOR(J)
  181. ENDIF
  182. 36 continue
  183. ENDDO
  184. endif
  185. * write(6,*) ' sortir disjo ', ipt4,ipt5,meleme
  186. SEGSUP IPT3,INV,NINV,NPOS,IVU
  187. RETURN
  188. END
  189.  
  190.  
  191.  
  192.  
  193.  
  194.  
  195.  

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