Télécharger disj.eso

Retour à la liste

Numérotation des lignes :

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

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