Télécharger interc.eso

Retour à la liste

Numérotation des lignes :

  1. C INTERC SOURCE GF238795 16/11/28 21:15:07 9210
  2. C
  3. C CE SOUS PROGRAMME REALISE l'intersection ensembliste de deux maillages
  4. C simples (1 seul type d'element)
  5. C Les maillages IPT1 et IPT2 sont supposes ACTIF en E/S (non modifies)
  6. C Si pas d'intersection, IPT3 = 0 sinon pointeur MELEME (ACTIF en S)
  7. C
  8. SUBROUTINE INTERC(IPT1,IPT2, IPT3)
  9.  
  10. IMPLICIT INTEGER(I-N)
  11. IMPLICIT REAL*8(A-H,O-Z)
  12.  
  13. -INC CCOPTIO
  14. -INC SMELEME
  15. -INC SMCOORD
  16. segment ipos(nbpts)
  17. segment ind(mm)
  18.  
  19. IPT3 = 0
  20.  
  21. C* SEGACT IPT1,IPT2 <- Segments actifs en Entree
  22. NBNN1=IPT1.NUM(/1)
  23. NBNN2=IPT2.NUM(/1)
  24. C Un des maillages n'est pas simple :
  25. IF (NBNN1.EQ.0 .OR. NBNN2.EQ.0) GOTO 900
  26.  
  27. NBELE1=IPT1.NUM(/2)
  28. NBELE2=IPT2.NUM(/2)
  29. ITYP1 =IPT1.ITYPEL
  30. ITYP2 =IPT2.ITYPEL
  31.  
  32. C Les maillages ne sont pas du meme type :
  33. IF ((ITYP1.NE.ITYP2) .OR. (NBNN1.NE.NBNN2)) GOTO 900
  34.  
  35. NBNN = NBNN1
  36. NBELEM = MAX(NBELE1,NBELE2)
  37. NBREF = 0
  38. NBSOUS = 0
  39. SEGINI,MELEME
  40. ITYPEL = ITYP1
  41.  
  42. C Creation de ipos
  43. SEGACT,mcoord
  44. np = xcoor(/1) / (idim+1)
  45. nbpts = np + 1
  46. SEGINI,ipos
  47. C Remplissage de ipos
  48. DO 10 i = 1, NBELE1
  49. DO 11 j = 1, NBNN1
  50. ia=ipt1.num(j,i)
  51. ipos(ia)=ipos(ia)+1
  52. 11 CONTINUE
  53. 10 CONTINUE
  54. i_z = ipos(1)
  55. DO 13 i = 2, np
  56. i_z = i_z + ipos(i)
  57. ipos(i) = i_z
  58. 13 CONTINUE
  59. mm = ipos(np)
  60. ipos(nbpts) = mm
  61. C Creation de ind
  62. SEGINI,ind
  63. C Remplissage de ind
  64. DO 20 i = 1, NBELE1
  65. DO 21 j = 1, NBNN1
  66. ia = ipt1.num(j,i)
  67. ide=ipos(ia)
  68. ind(ide)=i
  69. ipos(ia)=ide-1
  70. 21 CONTINUE
  71. 20 CONTINUE
  72.  
  73. * Remplissage de l'intersection
  74. I=0
  75. DO 1 i1 = 1, NBELE2
  76. ia=ipt2.num(1,i1)
  77. ideb=ipos(ia)+1
  78. ifin=ipos(ia+1)
  79. IF (ifin.lt.ideb) go to 1
  80. DO 2 ie=ideb,ifin
  81. iel=ind(ie)
  82. DO 134 in1=1,NBNN1
  83. DO 136 in2=1,NBNN2
  84. IF(ipt1.num(in1,iel).EQ.ipt2.num(in2,i1)) GOTO 134
  85. 136 CONTINUE
  86. GOTO 2
  87. 134 CONTINUE
  88. C OK pour cet element
  89. I=I+1
  90. ICOLOR(I)=IPT1.ICOLOR(Iel)
  91. DO 135 J=1,NBNN
  92. NUM(J,I)=IPT1.NUM(J,iel)
  93. 135 CONTINUE
  94. GOTO 1
  95. 2 CONTINUE
  96. 1 CONTINUE
  97.  
  98. SEGSUP,ipos,ind
  99.  
  100. NBELEM = I
  101. IF (NBELEM.EQ.0) THEN
  102. SEGSUP,MELEME
  103. IPT3 = 0
  104. ELSE
  105. SEGADJ,MELEME
  106. C* SEGDES,MELEME <- Segment cree actif en sortie
  107. IPT3 = MELEME
  108. ENDIF
  109.  
  110. 900 CONTINUE
  111. C* SEGDES,IPT1,IPT2 <- Segments actifs en Sortie (non modifies)
  112.  
  113. RETURN
  114. END
  115.  
  116.  
  117.  
  118.  
  119.  
  120.  

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