Télécharger ouexcl.eso

Retour à la liste

Numérotation des lignes :

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

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