Télécharger confor.eso

Retour à la liste

Numérotation des lignes :

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

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