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

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