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

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