Télécharger part4.eso

Retour à la liste

Numérotation des lignes :

  1. C PART4 SOURCE PASCAL 20/01/14 21:15:30 10496
  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 86 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 86
  87. izone=max(izone,ipos(nodes+k))
  88. 86 continue
  89. 85 continue
  90. 80 continue
  91. if (izone.eq.0) call erreur(920)
  92. if (ierr.ne.0) return
  93. endif
  94. if (ifait(iz).eq.0) then
  95. do k=1,iz-1
  96. if (ifait(k).eq.izone) goto 35
  97. enddo
  98. ifait(iz)=izone
  99. endif
  100. if (izone.eq.ifait(iz)) goto 37
  101. endif
  102. 35 continue
  103. * on annule l'element
  104. ipt5.num(1,j)=0
  105. 37 continue
  106. 30 continue
  107. * compaction de ipt5
  108. jf=0
  109. * write (6,*) 'avant compaction ipt5 itypel nbel',ipt5.itypel,
  110. * > ipt5.num(/2)
  111. do 50 j=1,ipt5.num(/2)
  112. if (ipt5.num(1,j).eq.0) goto 50
  113. jf=jf+1
  114. ipt5.icolor(jf)=ipt5.icolor(j)
  115. do i=1,ipt5.num(/1)
  116. ipt5.num(i,jf)=ipt5.num(i,j)
  117. enddo
  118. 50 continue
  119. nbnn=ipt5.num(/1)
  120. nbelem=jf
  121. nbelno=nbelno+nbelem
  122. nbsous=0
  123. nbref=0
  124. segadj ipt5
  125. * write (6,*) 'apres compaction ipt5 itypel nbel',ipt5.itypel,
  126. * > ipt5.num(/2)
  127. segdes ipt5
  128. if (jf.ne.0) then
  129. jsous=jsous+1
  130. ipt4.lisous(jsous)=ipt5
  131. else
  132. segsup ipt5
  133. endif
  134. segdes ipt1
  135. 20 continue
  136. nbsous=jsous
  137. nbref=0
  138. nbnn=0
  139. nbelem=0
  140. segadj ipt4
  141. if (jsous.eq.1) then
  142. ipt5=ipt4.lisous(1)
  143. segsup ipt4
  144. ipt4=ipt5
  145. endif
  146. segdes meleme,ipt4
  147. if (jsous.eq.0) goto 10
  148. izr=izr+1
  149. CALL ECCTAB(ITAB,'ENTIER',izr,0.D0,' ',.TRUE.,
  150. # 0,'MAILLAGE',0,0.D0,' ',.TRUE.,ipt4)
  151. 10 continue
  152. if (nbelno.ne.nbelan) call erreur(920)
  153. segsup ifait,ipos,icpr,iadj,jadjc
  154. end
  155.  
  156.  
  157.  
  158.  
  159.  
  160.  
  161.  
  162.  
  163.  
  164.  
  165.  
  166.  
  167.  
  168.  

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