Télécharger confor.eso

Retour à la liste

Numérotation des lignes :

  1. C CONFOR SOURCE PASCAL 16/01/04 21:15:00 8764
  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. segact mchelm
  20. segact mmodel
  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. segact imodel
  35. * write (6,*) imamod,conmod,phamod
  36. imail(io)=imamod
  37. ncom(io)=conmod
  38. npha(io)=conmod(17:24)
  39. segdes imodel
  40. 1 continue
  41.  
  42. * write(6,*) ' boucle sur le chamelem '
  43. do 2 io=1,nch
  44. ima=imache(io)
  45. icom=conche(io)
  46. iph=conche(io)(17:24)
  47. mcham1=ichaml(io)
  48. segact mcham1
  49. * write(6,*) ' nomche ',(mcham1.nomche(ic),ic=1,
  50. * $ mcham1.nomche(/2))
  51. * write(6,*) ima, icom,iph
  52. do 3 iu=1,nmo
  53. if( ima.eq.imail(iu)) then
  54. if(icom.eq.ncom(iu)) then
  55. if(iph.eq.npha(iu)) then
  56. * on a trouvé sur quelle partie du modele on s'appuie
  57. * on teste si deja rencontré et si oui on met tout le monde
  58. * sur le support iprio
  59. if(isu(iu).ne.0) then
  60. isune=infche(io,6)
  61. if(isu(iu).ne.iprio.and.isu(iu).ne.isune) then
  62. * il faut changer le support du ipla(iu)
  63. ia = ipla(iu)
  64. * write(6,*) ' ia iu',ia,iu
  65. segini mmode1
  66. mmode1.kmodel(1)=kmodel(iu)
  67. segini mchel2
  68. mchel2.CONCHE(1)=conche(Ia)
  69. mchel2.IMACHE(1)=imache(ia)
  70. mchel2.IMACHE(1)=imache(ia)
  71. mchel2.ICHAML(1)=ICHAML(ia)
  72. mchel2.ifoche=ifoche
  73. mchel2.titche=titche
  74. do iy=1,n3
  75. mchel2.infche(1,iy)=infche(ia,iy)
  76. enddo
  77. * write(6,*) ' confor appel a chasup'
  78. call chasup(mmode1,mchel2,mchel3,irt,iprio)
  79. isu(iu)=iprio
  80. if(irt.ne.0) return
  81. segact mchel3
  82. mchel1.ichaml(ia)=mchel3.ichaml(1)
  83. mchel1.infche(ia,6)=mchel3.infche(1,6)
  84. segsup mchel2,mmode1
  85. endif
  86. * il suffit d'additionner au ipla(iu )ieme ( si pas bon support
  87. * faire un chasup)
  88. * write(6,*) ' passage 2 io '
  89. ia=io
  90. segini mchel2
  91. mchel2.CONCHE(1)=conche(Ia)
  92. mchel2.IMACHE(1)=imache(ia)
  93. mchel2.ICHAML(1)=ICHAML(ia)
  94. mchel2.ifoche=ifoche
  95. mchel2.titche=titche
  96. do iy=1,n3
  97. mchel2.infche(1,iy)=infche(ia,iy)
  98. enddo
  99. if(infche(io,6).ne.isu(iu)) then
  100. n1=1
  101. isuppr=1
  102. segini mmode1
  103. mmode1.kmodel(1)=kmodel(iu)
  104. * write(6,*) ' confor appel a chasup 2'
  105. call chasup(mmode1,mchel2,mchel3,irt,iprio)
  106. segsup mmode1,mchel2
  107. else
  108. isuppr=0
  109. mchel3=mchel2
  110. endif
  111. ib=ipla(iu)
  112. * write(6,*) ' ib iu ' , ib,iu
  113. mchaml=mchel1.ichaml(ib)
  114. segini,mcham4=mchaml
  115. segdes mchaml
  116. mchaml=mcham4
  117. mchel1.ichaml(ib)=mchaml
  118. segact mchel3
  119. n22= ielval(/1)
  120. mcham3=mchel3.ichaml(1)
  121. segact mcham3
  122. n4=mcham3.ielval(/1)
  123. n2=n22+n4
  124. segadj mchaml
  125. * write(6,*) ' n2 n22 n4 ', n2 , n22 , n4
  126. do iy=1,n4
  127. mchaml.nomche(iy+n22)=mcham3.nomche(iy)
  128. mchaml.typche(iy+n22)=mcham3.typche(iy)
  129. mchaml.ielval(iy+n22)=mcham3.ielval(iy)
  130. enddo
  131. if(isuppr.eq.1) segsup mchel3,mcham3
  132. else
  133. * on se contente de stocker le champ
  134. isu(iu)=infche(io,6)
  135. ipla(iu)=io
  136. igard(io)=1
  137. * write(6,*) ' iu io',iu,io
  138. endif
  139. go to 2
  140. endif
  141. endif
  142. endif
  143. 3 continue
  144. call erreur( 19)
  145. return
  146. 2 continue
  147. *
  148. * il ne reste plus qu'a tasser mchel1
  149. *
  150. ico=0
  151. do iy=1,nch
  152. if(igard(iy).eq.1) then
  153. ico=ico+1
  154. do ip=1,n3
  155. mchel1.infche(ico,ip)=mchel1.infche(iy,ip)
  156. enddo
  157. mchel1.conche(ico)=mchel1.conche(iy)
  158. mchel1.imache(ico)=mchel1.imache(iy)
  159. mchel1.ichaml(ico)=mchel1.ichaml(iy)
  160. endif
  161. enddo
  162. if(ico.ne.nch) then
  163. n1=ico
  164. l1=mchel1.titche(/1)
  165. n3= mchel1.infche(/2)
  166. segadj mchel1
  167. endif
  168. * if(ico.ne.no) call erreur(19)
  169. do i=1,mchelm.ichaml(/1)
  170. mchaml=mchelm.ichaml(i)
  171. segdes mchaml
  172. enddo
  173. do i=1,mchel1.ichaml(/1)
  174. mchaml=mchel1.ichaml(i)
  175. segdes mchaml
  176. enddo
  177. segdes mchel1
  178. segdes mchelm
  179. segdes mmodel
  180. segsup lijk
  181. return
  182. end
  183.  
  184.  
  185.  
  186.  
  187.  
  188.  
  189.  

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