C CONFOR SOURCE CB215821 20/11/04 21:15:49 10766 subroutine confor(mchelm,mchel1,mmodel,iprio) implicit real*8(a-h,o-z) implicit integer (i-n) -INC SMMODEL -INC SMCHAML -INC PPARAM -INC CCOPTIO * * verifie que dans un chamelem pas plus de zones que dans le modele * si c'est le cas essaye de regrouper les zones du chaml s'appuyant * sur le meme modele en prenant iprio comme lieu de support * segment lijk integer imail(no),isu(no),ipla(no),igard(nch) character*16 ncom(no),npha(no) endsegment character*16 icom,iph * write(6,*) ' entrée dans confor ' nmo=kmodel(/1) nch=imache(/1) no=nmo n1=1 segini lijk n3=infche(/2) l1 = titche(/1) segini,mchel1=mchelm * write(6,*) ' nmo nch ', nmo,nch * write(6,*) ' pour le modele imamod conmod phamod' do 1 io=1,nmo imodel=kmodel(io) * write (6,*) imamod,conmod,phamod imail(io)=imamod ncom(io)=conmod npha(io)=conmod(17:24) 1 continue * write(6,*) ' boucle sur le chamelem ' do 2 io=1,nch ima=imache(io) icom=conche(io) iph=conche(io)(17:24) mcham1=ichaml(io) * write(6,*) ' nomche ',(mcham1.nomche(ic),ic=1, * $ mcham1.nomche(/2)) * write(6,*) ima, icom,iph do 3 iu=1,nmo if( ima.eq.imail(iu)) then if(icom.eq.ncom(iu)) then if(iph.eq.npha(iu)) then * on a trouvé sur quelle partie du modele on s'appuie * on teste si deja rencontré et si oui on met tout le monde * sur le support iprio if(isu(iu).ne.0) then isune=infche(io,6) if(isu(iu).ne.iprio.and.isu(iu).ne.isune) then * il faut changer le support du ipla(iu) ia = ipla(iu) * write(6,*) ' ia iu',ia,iu segini mmode1 mmode1.kmodel(1)=kmodel(iu) segini mchel2 mchel2.CONCHE(1)=conche(Ia) mchel2.IMACHE(1)=imache(ia) mchel2.IMACHE(1)=imache(ia) mchel2.ICHAML(1)=ICHAML(ia) mchel2.ifoche=ifoche mchel2.titche=titche do iy=1,n3 mchel2.infche(1,iy)=infche(ia,iy) enddo * write(6,*) ' confor appel a chasup' call chasup(mmode1,mchel2,mchel3,irt,iprio) isu(iu)=iprio if(irt.ne.0) return mchel1.ichaml(ia)=mchel3.ichaml(1) mchel1.infche(ia,6)=mchel3.infche(1,6) segsup mchel2,mmode1 endif * il suffit d'additionner au ipla(iu )ieme ( si pas bon support * faire un chasup) * write(6,*) ' passage 2 io ' ia=io segini mchel2 mchel2.CONCHE(1)=conche(Ia) mchel2.IMACHE(1)=imache(ia) mchel2.ICHAML(1)=ICHAML(ia) mchel2.ifoche=ifoche mchel2.titche=titche do iy=1,n3 mchel2.infche(1,iy)=infche(ia,iy) enddo if(infche(io,6).ne.isu(iu)) then n1=1 isuppr=1 segini mmode1 mmode1.kmodel(1)=kmodel(iu) * write(6,*) ' confor appel a chasup 2' call chasup(mmode1,mchel2,mchel3,irt,iprio) segsup mmode1,mchel2 else isuppr=0 mchel3=mchel2 endif ib=ipla(iu) * write(6,*) ' ib iu ' , ib,iu mchaml=mchel1.ichaml(ib) segini,mcham4=mchaml mchaml=mcham4 mchel1.ichaml(ib)=mchaml n22= ielval(/1) mcham3=mchel3.ichaml(1) n4=mcham3.ielval(/1) n2=n22+n4 segadj mchaml * write(6,*) ' n2 n22 n4 ', n2 , n22 , n4 do iy=1,n4 mchaml.nomche(iy+n22)=mcham3.nomche(iy) mchaml.typche(iy+n22)=mcham3.typche(iy) mchaml.ielval(iy+n22)=mcham3.ielval(iy) enddo if(isuppr.eq.1) segsup mchel3,mcham3 else * on se contente de stocker le champ isu(iu)=infche(io,6) ipla(iu)=io igard(io)=1 * write(6,*) ' iu io',iu,io endif go to 2 endif endif endif 3 continue call erreur( 19) return 2 continue * * il ne reste plus qu'a tasser mchel1 * ico=0 do iy=1,nch if(igard(iy).eq.1) then ico=ico+1 do ip=1,n3 mchel1.infche(ico,ip)=mchel1.infche(iy,ip) enddo mchel1.conche(ico)=mchel1.conche(iy) mchel1.imache(ico)=mchel1.imache(iy) mchel1.ichaml(ico)=mchel1.ichaml(iy) endif enddo if(ico.ne.nch) then n1=ico l1=mchel1.titche(/1) n3= mchel1.infche(/2) segadj mchel1 endif * if(ico.ne.no) call erreur(19) segsup lijk end