Télécharger disj.eso

Retour à la liste

Numérotation des lignes :

  1. C DISJ SOURCE CHAT 11/10/27 22:15:01 7180
  2. subroutine disj (ipt1,icpr,ijfam,nomg)
  3. implicit real*8(a-h,o-z)
  4. implicit integer (i-n)
  5. * on a des familles et un objet ipt1 qui sera un groupe,
  6. * on modifie si besoin les pour avoir le nouveaux groupe
  7. -INC CCOPTIO
  8. -INC SMCOORD
  9. -INC SMELEME
  10. character*8 nomg
  11. segment icpr(ino)
  12. segment ijfam
  13. * ifam pointeur sur un meleme, inogro pointeur sur un nomgro
  14. integer ifam(jg),inogro(jg),nfam
  15. endsegment
  16. segment nomgro
  17. * nogrou contient les noms des groupes qui inclus la famille
  18. character*8 nogrou(kg)
  19. integer noco
  20. endsegment
  21. pointeur nomgr1.nomgro,nomgr2.nomgro
  22. segact ipt1
  23. ipt5=0
  24. ipt4=0
  25. ipt3=0
  26. * write(6,*) ' traitement de ' , nomg, ' nfam ' , nfam
  27. if( nfam.eq.0) then
  28. * c'est la premiere fois, on declare famille tous les lisous de l'objet ipt1
  29. do i=1,max(1,ipt1.lisous(/1))
  30. if(ipt1.lisous(/1) .ne. 0) then
  31. ipt8=ipt1.lisous(i)
  32. else
  33. ipt8=ipt1
  34. endif
  35. segini,ipt9=ipt8
  36. if( nfam.ge.ifam(/1)) then
  37. jg=ifam(/1)+200
  38. segadj ijfam
  39. endif
  40. nfam=nfam+1
  41. * write(6,*) ' creation premiere famille ', ipt9,nomg
  42. ifam(nfam)=ipt9
  43. kg=10
  44. segini nomgro
  45. inogro(nfam)=nomgro
  46. noco=1
  47. nogrou(1)=nomg
  48. enddo
  49. return
  50. endif
  51. * il faut tester si intersection avec d autres familles
  52. do 1 i=1,max(1,ipt1.lisous(/1))
  53. if( ipt1.lisous(/1).ne.0) then
  54. ipt6=ipt1.lisous(i)
  55. segact ipt6
  56. else
  57. ipt6=ipt1
  58. endif
  59. do 2 j=1,nfam
  60. ipt7=ifam(j)
  61. segact ipt7
  62. * write(6,*) ' disj envoi ipt6,ipt7 ', ipt6,ipt7
  63. if( ipt6.itypel.ne.ipt7.itypel) go to 2
  64. call disjo(ipt6,ipt7,meleme,ipt8,ipt9,icpr)
  65. * write(6,*) ' meleme ipt8 ipt9 ' , meleme, ipt8, ipt9
  66. if( meleme.eq.0) go to 2
  67. * il existe une intersection
  68. if(ipt9.eq.0.and.IPT8.EQ.0) then
  69. * les deux objets sont superposes on ajoute le nom dans la famille on a fini
  70. * pour ipt6
  71. nomgro=inogro(j)
  72. noco=noco+1
  73. if(noco.gt.nogrou(/2)) then
  74. kg=nogrou(/2)+10
  75. segadj nomgro
  76. endif
  77. nogrou(noco)=nomg
  78. go to 1
  79. elseif(ipt8.eq.0) then
  80. ifam(j)=ipt9
  81. nomgro=inogro(j)
  82. noco=noco+1
  83. if(noco.gt.nogrou(/2)) then
  84. kg=nogrou(/2)+10
  85. segadj nomgro
  86. endif
  87. nogrou(noco)=nomg
  88. nfam=nfam+1
  89. * write(6,*) 'Acreation nouvelle famille ' ,nfam ,meleme
  90. if( nfam.gt.ifam(/1)) then
  91. jg=ifam(/1)+200
  92. segadj ijfam
  93. endif
  94. ifam(nfam)=meleme
  95. nomgr1=inogro(j)
  96. segini,nomgro=nomgr1
  97. inogro(nfam)=nomgro
  98. noco=noco+1
  99. if(noco.gt.nogrou(/2)) then
  100. kg=nogrou(/2)+10
  101. segadj nomgro
  102. endif
  103. nogrou(noco)=nomg
  104. elseif(ipt9.eq.0)then
  105. nomgro=inogro(j)
  106. noco=noco+1
  107. if(noco.gt.nogrou(/2)) then
  108. kg=nogrou(/2)+10
  109. segadj nomgro
  110. endif
  111. nogrou(noco)=nomg
  112. ipt6=ipt8
  113. else
  114. * aucun n'est nul meleme ipt8,ipt9
  115. ipt6=ipt8
  116. ifam(j)=ipt9
  117. nfam=nfam+1
  118. * write(6,*) 'Bcreation nouvelle famille ' ,nfam ,meleme
  119. if( nfam.gt.ifam(/1)) then
  120. jg=ifam(/1)+200
  121. segadj ijfam
  122. endif
  123. ifam(nfam)=meleme
  124. nomgr1=inogro(j)
  125. segini,nomgro=nomgr1
  126. inogro(nfam)=nomgro
  127. noco=noco+1
  128. if(noco.gt.nogrou(/2)) then
  129. kg=nogrou(/2)+10
  130. segadj nomgro
  131. endif
  132. nogrou(noco)=nomg
  133. endif
  134. 2 Continue
  135. nfam=nfam+1
  136. if( nfam.gt.ifam(/1)) then
  137. jg=ifam(/1)+200
  138. segadj ijfam
  139. endif
  140. * write(6,*) 'Ccreation nouvelle famille ' ,nfam ,ipt6
  141. ifam(nfam)=ipt6
  142. kg=10
  143. segini nomgro
  144. inogro(nfam)=nomgro
  145. noco=1
  146. nogrou(1)=nomg
  147. 1 Continue
  148. return
  149. end
  150.  
  151.  
  152.  
  153.  

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