Télécharger disj.eso

Retour à la liste

Numérotation des lignes :

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

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