Télécharger confor.eso

Retour à la liste

Numérotation des lignes :

  1. C CONFOR SOURCE CB215821 19/08/20 21:16:19 10287
  2. subroutine confor(mchelm,mchel1,mmodel,iprio)
  3. implicit real*8(a-h,o-z)
  4. implicit integer (i-n)
  5. -INC SMMODEL
  6. -INC SMCHAML
  7. -INC CCOPTIO
  8. *
  9. * verifie que dans un chamelem pas plus de zones que dans le modele
  10. * si c'est le cas essaye de regrouper les zones du chaml s'appuyant
  11. * sur le meme modele en prenant iprio comme lieu de support
  12. *
  13. segment lijk
  14. integer imail(no),isu(no),ipla(no),igard(nch)
  15. character*16 ncom(no),npha(no)
  16. endsegment
  17. character*16 icom,iph
  18. * write(6,*) ' entrée dans confor '
  19. nmo=kmodel(/1)
  20. nch=imache(/1)
  21. no=nmo
  22. n1=1
  23. segini lijk
  24. n3=infche(/2)
  25. l1 = titche(/1)
  26. segini,mchel1=mchelm
  27. * write(6,*) ' nmo nch ', nmo,nch
  28. * write(6,*) ' pour le modele imamod conmod phamod'
  29.  
  30. do 1 io=1,nmo
  31. imodel=kmodel(io)
  32. * write (6,*) imamod,conmod,phamod
  33. imail(io)=imamod
  34. ncom(io)=conmod
  35. npha(io)=conmod(17:24)
  36. 1 continue
  37.  
  38. * write(6,*) ' boucle sur le chamelem '
  39. do 2 io=1,nch
  40. ima=imache(io)
  41. icom=conche(io)
  42. iph=conche(io)(17:24)
  43. mcham1=ichaml(io)
  44. * write(6,*) ' nomche ',(mcham1.nomche(ic),ic=1,
  45. * $ mcham1.nomche(/2))
  46. * write(6,*) ima, icom,iph
  47. do 3 iu=1,nmo
  48. if( ima.eq.imail(iu)) then
  49. if(icom.eq.ncom(iu)) then
  50. if(iph.eq.npha(iu)) then
  51. * on a trouvé sur quelle partie du modele on s'appuie
  52. * on teste si deja rencontré et si oui on met tout le monde
  53. * sur le support iprio
  54. if(isu(iu).ne.0) then
  55. isune=infche(io,6)
  56. if(isu(iu).ne.iprio.and.isu(iu).ne.isune) then
  57. * il faut changer le support du ipla(iu)
  58. ia = ipla(iu)
  59. * write(6,*) ' ia iu',ia,iu
  60. segini mmode1
  61. mmode1.kmodel(1)=kmodel(iu)
  62. segini mchel2
  63. mchel2.CONCHE(1)=conche(Ia)
  64. mchel2.IMACHE(1)=imache(ia)
  65. mchel2.IMACHE(1)=imache(ia)
  66. mchel2.ICHAML(1)=ICHAML(ia)
  67. mchel2.ifoche=ifoche
  68. mchel2.titche=titche
  69. do iy=1,n3
  70. mchel2.infche(1,iy)=infche(ia,iy)
  71. enddo
  72. * write(6,*) ' confor appel a chasup'
  73. call chasup(mmode1,mchel2,mchel3,irt,iprio)
  74. isu(iu)=iprio
  75. if(irt.ne.0) return
  76. mchel1.ichaml(ia)=mchel3.ichaml(1)
  77. mchel1.infche(ia,6)=mchel3.infche(1,6)
  78. segsup mchel2,mmode1
  79. endif
  80. * il suffit d'additionner au ipla(iu )ieme ( si pas bon support
  81. * faire un chasup)
  82. * write(6,*) ' passage 2 io '
  83. ia=io
  84. segini mchel2
  85. mchel2.CONCHE(1)=conche(Ia)
  86. mchel2.IMACHE(1)=imache(ia)
  87. mchel2.ICHAML(1)=ICHAML(ia)
  88. mchel2.ifoche=ifoche
  89. mchel2.titche=titche
  90. do iy=1,n3
  91. mchel2.infche(1,iy)=infche(ia,iy)
  92. enddo
  93. if(infche(io,6).ne.isu(iu)) then
  94. n1=1
  95. isuppr=1
  96. segini mmode1
  97. mmode1.kmodel(1)=kmodel(iu)
  98. * write(6,*) ' confor appel a chasup 2'
  99. call chasup(mmode1,mchel2,mchel3,irt,iprio)
  100. segsup mmode1,mchel2
  101. else
  102. isuppr=0
  103. mchel3=mchel2
  104. endif
  105. ib=ipla(iu)
  106. * write(6,*) ' ib iu ' , ib,iu
  107. mchaml=mchel1.ichaml(ib)
  108. segini,mcham4=mchaml
  109. mchaml=mcham4
  110. mchel1.ichaml(ib)=mchaml
  111. n22= ielval(/1)
  112. mcham3=mchel3.ichaml(1)
  113. n4=mcham3.ielval(/1)
  114. n2=n22+n4
  115. segadj mchaml
  116. * write(6,*) ' n2 n22 n4 ', n2 , n22 , n4
  117. do iy=1,n4
  118. mchaml.nomche(iy+n22)=mcham3.nomche(iy)
  119. mchaml.typche(iy+n22)=mcham3.typche(iy)
  120. mchaml.ielval(iy+n22)=mcham3.ielval(iy)
  121. enddo
  122. if(isuppr.eq.1) segsup mchel3,mcham3
  123. else
  124. * on se contente de stocker le champ
  125. isu(iu)=infche(io,6)
  126. ipla(iu)=io
  127. igard(io)=1
  128. * write(6,*) ' iu io',iu,io
  129. endif
  130. go to 2
  131. endif
  132. endif
  133. endif
  134. 3 continue
  135. call erreur( 19)
  136. return
  137. 2 continue
  138. *
  139. * il ne reste plus qu'a tasser mchel1
  140. *
  141. ico=0
  142. do iy=1,nch
  143. if(igard(iy).eq.1) then
  144. ico=ico+1
  145. do ip=1,n3
  146. mchel1.infche(ico,ip)=mchel1.infche(iy,ip)
  147. enddo
  148. mchel1.conche(ico)=mchel1.conche(iy)
  149. mchel1.imache(ico)=mchel1.imache(iy)
  150. mchel1.ichaml(ico)=mchel1.ichaml(iy)
  151. endif
  152. enddo
  153. if(ico.ne.nch) then
  154. n1=ico
  155. l1=mchel1.titche(/1)
  156. n3= mchel1.infche(/2)
  157. segadj mchel1
  158. endif
  159. * if(ico.ne.no) call erreur(19)
  160. segsup lijk
  161.  
  162. end
  163.  
  164.  
  165.  

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