Télécharger ouexcl.eso

Retour à la liste

Numérotation des lignes :

  1. C OUEXCL SOURCE MAUGIS 07/10/10 21:15:07 5889
  2. SUBROUTINE OUEXCL(IPT1,IPT2,MELEME)
  3. *=============================================================
  4. *
  5. * CE SOUS PROGRAMME REALISE L'OPERATION "OU EXCLUSIF" SUR DEUX LIGNES
  6. * IL INTERVIENT DANS LA FUSION DES CONTOURS DE DEUX OBJETS SURFACIQUE
  7. *
  8. *=============================================================
  9. *
  10. * Création : ???
  11. * Modifications : PM 05/10/2007
  12. * gère les éléments dégénérés (à noeuds doubles)
  13. *
  14. *=============================================================
  15. *
  16. * REMARQUES:
  17. *
  18. *=============================================================
  19. IMPLICIT INTEGER(I-N)
  20. -INC CCOPTIO
  21. -INC SMELEME
  22. -INC SMCOORD
  23. SEGMENT INV(NBT)
  24. SEGMENT NINV(NBNO)
  25. SEGMENT NPOS(NBNO)
  26. SEGMENT ICPR(XCOOR(/1)/(IDIM+1))
  27. SEGMENT IVU(NBVU)
  28.  
  29. SEGACT IPT1,IPT2
  30.  
  31. * Type d'élément incorrect ?
  32. IF (IPT1.ITYPEL .NE.IPT2.ITYPEL ) CALL ERREUR(16)
  33. IF (IPT1.NUM(/1).NE.IPT2.NUM(/1)) CALL ERREUR(16)
  34. IF (IERR.NE.0) RETURN
  35.  
  36. NBREF = 0
  37. NBNN = IPT1.NUM(/1)
  38. NBELE1 = IPT1.NUM(/2)
  39. NBELE2 = IPT2.NUM(/2)
  40.  
  41. * DETERMINATION DU NOMBRE DE NOEUDS
  42. SEGACT MCOORD
  43. SEGINI ICPR
  44. NBNO=0
  45. DO I=1,NBELE1
  46. DO 15 J=1,NBNN
  47. IPT=IPT1.NUM(J,I)
  48. IF (ICPR(IPT).NE.0) GOTO 15
  49. ICPR(IPT)=NBNO
  50. 15 CONTINUE
  51. ENDDO
  52.  
  53. * NB MAX ELEMENTS TOUCHANT UN NOEUD
  54. SEGINI NINV,NPOS
  55. DO I=1,NBELE1
  56. DO J=1,NBNN
  57. NINV(ICPR(IPT1.NUM(J,I)))=NINV(ICPR(IPT1.NUM(J,I)))+1
  58. ENDDO
  59. ENDDO
  60. NBC=0
  61. NBT=0
  62. DO I=1,NBNO
  63. NBC=MAX(NBC,NINV(I))
  64. NPOS(I)=NBT
  65. NBT=NBT+NINV(I)
  66. NINV(I)=0
  67. ENDDO
  68. SEGINI INV
  69. DO I=1,NBELE1
  70. DO J=1,NBNN
  71. IPP=ICPR(IPT1.NUM(J,I))
  72. NINV(IPP)=NINV(IPP)+1
  73. INV(NPOS(IPP)+NINV(IPP))=I
  74. ENDDO
  75. ENDDO
  76.  
  77. * Création table d'indicateur de noeud déjà trouvé
  78. NBVU=NBNN
  79. SEGINI, IVU
  80.  
  81. * CREATION DE LA DIFFERENCE SYMETRIQUE
  82. NBSOUS=0
  83. NBELEM=NBELE1+NBELE2
  84. SEGINI MELEME
  85. DO I=1,NBELE1
  86. ICOLOR(I)=IPT1.ICOLOR(I)
  87. DO J=1,NBNN
  88. NUM(J,I)=IPT1.NUM(J,I)
  89. ENDDO
  90. ENDDO
  91.  
  92. DO I=1,NBELE2
  93. ICOLOR(I+NBELE1)=IPT2.ICOLOR(I)
  94. DO J=1,NBNN
  95. NUM(J,I+NBELE1)=IPT2.NUM(J,I)
  96. ENDDO
  97. ENDDO
  98.  
  99. DO 2 I=1,NBELE2
  100. DO J=1,NBNN
  101. IPP=ICPR(NUM(J,I+NBELE1))
  102. IF (IPP.EQ.0) GOTO 2
  103. DO 23 K=1,NINV(IPP)
  104. IEL=INV(NPOS(IPP)+K)
  105. * Comparaison des numéros de noeud de l'élément
  106. * ICOIN=nb de noeuds qui conviennent
  107. ICOIN=0
  108. DO M=1,NBNN
  109. IVU(M)=0
  110. ENDDO
  111. DO 24 L=1,NBNN
  112. DO M=1,NBNN
  113. *PM On ne teste que les noeuds non encore identifiés.
  114. IF (NUM(M,IEL).EQ.NUM(L,I+NBELE1) .AND.
  115. & IVU(M).EQ.0) THEN
  116. ICOIN = ICOIN + 1
  117. IVU(M) = 1
  118. GOTO 24
  119. ENDIF
  120. ENDDO
  121. 24 CONTINUE
  122.  
  123. IF (ICOIN.NE.NBNN) GOTO 23
  124. * Les deux élements coincident
  125. NUM(1,I+NBELE1)=-NUM(1,I+NBELE1)
  126. NUM(1,IEL)=-NUM(1,IEL)
  127. NBELEM=NBELEM-2
  128. * WRITE (6,*) ' COINCIDE ',I,IEL,NBELEM,NBELE1,NBELE2,NBNN
  129. GOTO 2
  130. 23 CONTINUE
  131. ENDDO
  132. 2 CONTINUE
  133.  
  134. * RETASSER LE MELEME RÉSULTAT
  135. IPT3=MELEME
  136. MELEME=0
  137. IF(NBELEM.EQ.0) SEGSUP IPT3
  138. IF(NBELEM.EQ.0) RETURN
  139.  
  140. SEGINI MELEME
  141. ITYPEL=IPT1.ITYPEL
  142. SEGDES IPT1,IPT2
  143.  
  144. J=1
  145. DO I=1,NBELEM
  146. 51 IF (IPT3.NUM(1,J).GT.0) GOTO 52
  147. J=J+1
  148. GOTO 51
  149. 52 DO K=1,NBNN
  150. NUM(K,I)=IPT3.NUM(K,J)
  151. ENDDO
  152. ICOLOR(I)=IPT3.ICOLOR(J)
  153. J=J+1
  154. ENDDO
  155.  
  156. SEGSUP IPT3,INV,NINV,NPOS,IVU
  157. RETURN
  158. END
  159.  
  160.  
  161.  
  162.  
  163.  
  164.  

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