Télécharger interb.eso

Retour à la liste

Numérotation des lignes :

  1. C INTERB SOURCE CB215821 15/03/31 12:19:31 8457
  2.  
  3. SUBROUTINE INTERB(IMAMA1,IMAMA2,IRET,IMAMA3)
  4.  
  5. ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
  6. C
  7. C INTERSECTION (sens ensembliste) DE DEUX MAILLAGES
  8. C
  9. ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
  10. C
  11. c IPT1,IPT2 : les 2 maillages
  12. c IRET : code de retour (0 = OK, 1 = intersection vide)
  13. C IPT3 : maillage de l'intersection (=0 si IRET = 1)
  14. C
  15. C Suppose que chaque maillage n'a pas 2 sous-zones de même type
  16. C
  17. ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
  18. IMPLICIT INTEGER(I-N)
  19. LOGICAL VERIF
  20.  
  21. -INC CCOPTIO
  22. -INC SMELEME
  23.  
  24. IRET = 0
  25. ipt1 = IMAMA1
  26. ipt2 = IMAMA2
  27. ipt3 = 0
  28.  
  29. SEGACT,IPT1,IPT2
  30. NBSOU1=IPT1.LISOUS(/1)
  31. NBSOU2=IPT2.LISOUS(/1)
  32.  
  33. C Structure 1er maillage ?
  34. IF (NBSOU1.NE.0) THEN
  35. C il est composé
  36. GOTO 10
  37. ELSE
  38. C IPT1 est simple, INTERC verifiera s'il est vide
  39. ENDIF
  40.  
  41. C Structure 2e maillage ?
  42. IF (NBSOU2.NE.0) THEN
  43. C il est composé
  44. GOTO 11
  45. ELSE
  46. C IPT2 est simple, INTERC verifiera s'il est vide
  47. ENDIF
  48.  
  49. C LES DEUX MAILLAGES SONT SIMPLES
  50. C ===============================
  51. CALL INTERC(IPT1,IPT2,IPT3)
  52. GOTO 1000
  53.  
  54. C UN DES DEUX EST COMPOSÉ, L'AUTRE SIMPLE
  55. C =======================================
  56. 10 IF (NBSOU2.NE.0) THEN
  57. GOTO 20
  58. ELSE
  59. GOTO 12
  60. ENDIF
  61. C LE 2e EST COMPOSÉ, LE 1ER SIMPLE : on les intervertit
  62. 11 IS = IPT2
  63. IPT2 = IPT1
  64. IPT1 = IS
  65.  
  66. C on les a dans l'ordre IPT1=composé, IPT2=simple ...
  67. 12 CONTINUE
  68. NBSOU1 = IPT1.LISOUS(/1)
  69. C Recherche de la sous-zone de même type dans IPT2
  70. ITYP2 = IPT2.ITYPEL
  71. DO IS = 1, NBSOU1
  72. IPT4 = IPT1.LISOUS(IS)
  73. SEGACT,IPT4
  74. IF (IPT4.ITYPEL .EQ. ITYP2) THEN
  75. IF (IPT2.EQ.IPT4) THEN
  76. C le petit est inclus dans le grand
  77. IPT3 = IPT2
  78. ELSE
  79. C on determine l'intersection pour cette seule sous-zone
  80. CALL INTERC(IPT2,IPT4,IPT3)
  81. SEGDES,IPT4
  82. ENDIF
  83. GOTO 1000
  84. ENDIF
  85. SEGDES,IPT4
  86. ENDDO
  87. c on n'en a pas trouvé
  88. GOTO 1000
  89.  
  90. C LES DEUX MAILLAGES SONT COMPOSÉS
  91. C ================================
  92. 20 CONTINUE
  93. NBELEM=0
  94. NBNN =0
  95. NBREF =0
  96. NBSOUS=MIN(NBSOU1,NBSOU2)
  97. SEGINI,IPT4
  98.  
  99. I3=0
  100. DO 21 I1=1,NBSOU1
  101. IPT5=IPT1.LISOUS(I1)
  102. SEGACT IPT5
  103. C Recherche de la sous-zone de même type dans IPT2
  104. ITYP5 = IPT5.ITYPEL
  105. DO 22 I2=1,NBSOU2
  106. IPT6=IPT2.LISOUS(I2)
  107. SEGACT IPT6
  108. IF (ITYP5.EQ.IPT6.ITYPEL) THEN
  109. C on l'a trouvée, on fait l'intersection
  110. IF (IPT5.EQ.IPT6) THEN
  111. C les deux sous-maillages sont confondus
  112. IPT7=IPT5
  113. ELSE
  114. CALL INTERC(IPT5,IPT6,IPT7)
  115. SEGDES IPT6
  116. IF (IPT7.NE.0) SEGDES,IPT7
  117. ENDIF
  118. IF (IPT7.NE.0) THEN
  119. C intersection non vide, on stocke le maillage obtenu
  120. I3 = I3+1
  121. IPT4.LISOUS(I3)=IPT7
  122. ENDIF
  123. GOTO 23
  124. ENDIF
  125. 22 CONTINUE
  126. 23 CONTINUE
  127. SEGDES IPT5
  128. 21 CONTINUE
  129.  
  130. C Maillage résultat
  131. C Aucune sous-zone ...
  132. IF (I3.EQ.0) THEN
  133. SEGSUP,IPT4
  134. ELSE
  135. NBSOUS = I3
  136. SEGADJ,IPT4
  137. IPT3 = IPT4
  138. C Si une seule sous-zone ...
  139. IF (I3.EQ.1) THEN
  140. IPT3 = IPT4.LISOUS(1)
  141. SEGSUP,IPT4
  142. ENDIF
  143. ENDIF
  144.  
  145. 1000 CONTINUE
  146. SEGDES,IPT1,IPT2
  147. IF (IPT3.EQ.0) THEN
  148. IRET = 1
  149. ELSE
  150. SEGDES,IPT3
  151. IRET = 0
  152. ENDIF
  153. IMAMA3 = IPT3
  154.  
  155. RETURN
  156. END
  157.  
  158.  
  159.  
  160.  
  161.  

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