1 : C CONFOR SOURCE CHAT 11/03/16 21:17:55 6902 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' 77 : call chasup(mmode1,mchel2,mchel3,irt,iprio) 78 : isu(iu)=iprio 79 : if(irt.ne.0) return 80 : segact mchel3 81 : mchel1.ichaml(ia)=mchel3.ichaml(1) 82 : mchel1.infche(ia,6)=mchel3.infche(1,6) 83 : segsup mchel2,mmode1 84 : endif 85 : * il suffit d'additionner au ipla(iu )ieme ( si pas bon support 86 : * faire un chasup) 87 : * write(6,*) ' passage 2 io ' 88 : ia=io 89 : segini mchel2 90 : mchel2.CONCHE(1)=conche(Ia) 91 : mchel2.IMACHE(1)=imache(ia) 92 : mchel2.ICHAML(1)=ICHAML(ia) 93 : mchel2.ifoche=ifoche 94 : mchel2.titche=titche 95 : do iy=1,n3 96 : mchel2.infche(1,iy)=infche(ia,iy) 97 : enddo 98 : if(infche(io,6).ne.isu(iu)) then 99 : n1=1 100 : isuppr=1 101 : segini mmode1 102 : mmode1.kmodel(1)=kmodel(iu) 103 : * write(6,*) ' confor appel a chasup 2' 103 : call chasup(mmode1,mchel2,mchel3,irt,iprio) 104 : segsup mmode1,mchel2 105 : else 106 : isuppr=0 107 : mchel3=mchel2 108 : endif 109 : ib=ipla(iu) 110 : * write(6,*) ' ib iu ' , ib,iu 111 : mchaml=mchel1.ichaml(ib) 112 : segini,mcham4=mchaml 113 : segdes mchaml 114 : mchaml=mcham4 115 : mchel1.ichaml(ib)=mchaml 116 : segact mchel3 117 : n22= ielval(/1) 118 : mcham3=mchel3.ichaml(1) 119 : segact mcham3 120 : n4=mcham3.ielval(/1) 121 : n2=n22+n4 122 : segadj mchaml 123 : * write(6,*) ' n2 n22 n4 ', n2 , n22 , n4 124 : do iy=1,n4 125 : mchaml.nomche(iy+n22)=mcham3.nomche(iy) 126 : mchaml.typche(iy+n22)=mcham3.typche(iy) 127 : mchaml.ielval(iy+n22)=mcham3.ielval(iy) 128 : enddo 129 : if(isuppr.eq.1) segsup mchel3,mcham3 130 : else 131 : * on se contente de stocker le champ 132 : isu(iu)=infche(io,6) 133 : ipla(iu)=io 134 : igard(io)=1 135 : * write(6,*) ' iu io',iu,io 136 : endif 137 : go to 2 138 : endif 139 : endif 140 : endif 141 : 3 continue 141 : call erreur( 19) 142 : return 143 : 2 continue 144 : * 145 : * il ne reste plus qu'a tasser mchel1 146 : * 147 : ico=0 148 : do iy=1,nch 149 : if(igard(iy).eq.1) then 150 : ico=ico+1 151 : do ip=1,n3 152 : mchel1.infche(ico,ip)=mchel1.infche(iy,ip) 153 : enddo 154 : mchel1.conche(ico)=mchel1.conche(iy) 155 : mchel1.imache(ico)=mchel1.imache(iy) 156 : mchel1.ichaml(ico)=mchel1.ichaml(iy) 157 : endif 158 : enddo 159 : if(ico.ne.nch) then 160 : n1=ico 161 : l1=mchel1.titche(/1) 162 : n3= mchel1.infche(/2) 163 : segadj mchel1 164 : endif 164 : if(ico.ne.no)call erreur(19) 165 : do i=1,mchelm.ichaml(/1) 166 : mchaml=mchelm.ichaml(i) 167 : segdes mchaml 168 : enddo 169 : do i=1,mchel1.ichaml(/1) 170 : mchaml=mchel1.ichaml(i) 171 : segdes mchaml 172 : enddo 173 : segdes mchel1 174 : segdes mchelm 175 : segdes mmodel 176 : segsup lijk 177 : return 178 : end 179 : 180 : 181 : 182 : 183 :
© Cast3M 2003 - All rights reserved.
Disclaimer