Télécharger part4.eso

Retour à la liste

Numérotation des lignes :

  1. C PART4 SOURCE JC220346 16/11/18 21:19:45 9187
  2. * partitionne meleme dans itab en fonction du contenu de ipos
  3. *
  4. SUBROUTINE PART4(MELEME,IPOS,ICPR,NB,ITAB,IADJ,JADJC,KESCL)
  5. *
  6. IMPLICIT INTEGER(I-N)
  7. -INC SMELEME
  8. -INC CCOPTIO
  9. segment ifait(2**nb)
  10. segment ipos(0)
  11. segment icpr(0)
  12. segment iadj(0)
  13. segment jadjc(0)
  14. CALL CRTABL(ITAB)
  15. IF (KESCL.GT.0) THEN
  16. CALL ECCTAB(ITAB,'MOT',0,0.D0,'SOUSTYPE',.TRUE.,
  17. # 0,'MOT',0,0.D0,'ESCLAVE',.TRUE.,0)
  18. CALL ECCTAB(ITAB,'MOT',0,0.D0,'CREATEUR',.TRUE.,
  19. # 0,'MOT',0,0.D0,'PART',.TRUE.,0)
  20. ENDIF
  21. 90 continue
  22. segini ifait
  23. nodes=ipos(/1)/3
  24. nbelan=0
  25. nbelno=0
  26. * boucle sur les zones de maillages à creer
  27. izr=0
  28. do 10 iz=1,2**nb
  29. segact meleme
  30. nbnn=0
  31. nbelem=0
  32. nbref=0
  33. nbsous=max(1,lisous(/1))
  34. segini,ipt4
  35. jsous=0
  36. ipt1=meleme
  37. do 20 isous=1,max(1,lisous(/1))
  38. if (lisous(/1).ne.0) ipt1=lisous(isous)
  39. segact ipt1
  40. if (iz.eq.1) nbelan=nbelan+ipt1.num(/2)
  41. segini,ipt5=ipt1
  42. do 30 j=1,ipt5.num(/2)
  43. ifro=1
  44. do 40 i=1,ipt5.num(/1)
  45. ip=icpr(ipt5.num(i,j))
  46. if (ipos(2*nodes+ip).lt.nb) goto 40
  47. ifro=0
  48. if (ifait(iz).eq.0) then
  49. do k=1,iz-1
  50. if (ifait(k).eq.ipos(nodes+ip)) goto 35
  51. enddo
  52. ifait(iz)=ipos(nodes+ip)
  53. endif
  54. * write (6,*) ' itypel ifait ipos ',ipt5.itypel,ifait(iz),
  55. * > ipos(nodes+ip),ipos(2*nodes+ip)
  56. if (ifait(iz).eq.ipos(nodes+ip)) goto 37
  57. 40 continue
  58. if (ifro.eq.1) then
  59. * write (6,*) ' ifro 1 ',ifro
  60. * embetant tous les noeuds sont sur la frontiere
  61. * recherche de la zone voisine la plus grande
  62. izone=0
  63. write (6,*) ' element sur la frontiere ',ipt5.num(/1)
  64.  
  65. do 60 i=1,ipt5.num(/1)
  66. ip=icpr(ipt5.num(i,j))
  67. do 65 iv=iadj(ip),iadj(ip+1)-1
  68. K=JADJC(iv)
  69. * write (6,*) ' noeud ',ip,' vois ',k,' zone ',ipos(2*nodes+k),
  70. * > 'nb ',nb
  71. if (ipos(2*nodes+k).lt.nb) goto 65
  72. izone=max(izone,ipos(nodes+k))
  73. 65 continue
  74. 60 continue
  75. if (izone.eq.0) then
  76. * write (6,*) 'izone 0 apres 60 '
  77. * on essaye un peu plus loin
  78. do 80 i=1,ipt5.num(/1)
  79. ip=icpr(ipt5.num(i,j))
  80. do 85 iv=iadj(ip),iadj(ip+1)-1
  81. ivv=jadjc(iv)
  82. do 85 iw=iadj(ivv),iadj(ivv+1)-1
  83. K=JADJC(iw)
  84. * write (6,*) ' noeud ',ip,' vois ',k,' zone ',ipos(2*nodes+k),
  85. * > 'nb ',nb
  86. if (ipos(2*nodes+k).lt.nb) goto 85
  87. izone=max(izone,ipos(nodes+k))
  88. 85 continue
  89. 80 continue
  90. if (izone.eq.0) call erreur(920)
  91. if (ierr.ne.0) return
  92. endif
  93. if (ifait(iz).eq.0) then
  94. do k=1,iz-1
  95. if (ifait(k).eq.izone) goto 35
  96. enddo
  97. ifait(iz)=izone
  98. endif
  99. if (izone.eq.ifait(iz)) goto 37
  100. endif
  101. 35 continue
  102. * on annule l'element
  103. ipt5.num(1,j)=0
  104. 37 continue
  105. 30 continue
  106. * compaction de ipt5
  107. jf=0
  108. * write (6,*) 'avant compaction ipt5 itypel nbel',ipt5.itypel,
  109. * > ipt5.num(/2)
  110. do 50 j=1,ipt5.num(/2)
  111. if (ipt5.num(1,j).eq.0) goto 50
  112. jf=jf+1
  113. ipt5.icolor(jf)=ipt5.icolor(j)
  114. do i=1,ipt5.num(/1)
  115. ipt5.num(i,jf)=ipt5.num(i,j)
  116. enddo
  117. 50 continue
  118. nbnn=ipt5.num(/1)
  119. nbelem=jf
  120. nbelno=nbelno+nbelem
  121. nbsous=0
  122. nbref=0
  123. segadj ipt5
  124. * write (6,*) 'apres compaction ipt5 itypel nbel',ipt5.itypel,
  125. * > ipt5.num(/2)
  126. segdes ipt5
  127. if (jf.ne.0) then
  128. jsous=jsous+1
  129. ipt4.lisous(jsous)=ipt5
  130. else
  131. segsup ipt5
  132. endif
  133. segdes ipt1
  134. 20 continue
  135. nbsous=jsous
  136. nbref=0
  137. nbnn=0
  138. nbelem=0
  139. segadj ipt4
  140. if (jsous.eq.1) then
  141. ipt5=ipt4.lisous(1)
  142. segsup ipt4
  143. ipt4=ipt5
  144. endif
  145. segdes meleme,ipt4
  146. if (jsous.eq.0) goto 10
  147. izr=izr+1
  148. CALL ECCTAB(ITAB,'ENTIER',izr,0.D0,' ',.TRUE.,
  149. # 0,'MAILLAGE',0,0.D0,' ',.TRUE.,ipt4)
  150. 10 continue
  151. if (nbelno.ne.nbelan) call erreur(920)
  152. segsup ifait,ipos,icpr,iadj,jadjc
  153. end
  154.  
  155.  
  156.  
  157.  
  158.  
  159.  
  160.  
  161.  
  162.  
  163.  
  164.  
  165.  

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