1 : C SPLITAG SOURCE CHAT 11/03/16 21:31:43 6902 2 : SUBROUTINE SPLITAG(IPMODL,IPCARA,IPCHC1,IPMOD2,IPCAR2, 3 : & ipchc2,siezo) 4 : *====================================================================== 5 : * On a un seul modele defini sur des seg2 definissant des cables 6 : * on veut fabriquer un modele intermediaire comportant une sous zone 7 : * par cable pour appliquer des tensions a leurs extremites et 8 : * calculer des pertes de precontraintes 9 : * 10 : * on partitione : 11 : * geometrie 12 : * modele ipmodl ---> ipmod2 13 : * champs de caracteristiques ipcara ---> ipcar2 14 : * champs de precontraintes si presents ipchc1 ---> ipchc2 15 : * 16 : * routine appelee par precop 17 : *====================================================================== 18 : IMPLICIT INTEGER(I-N) 19 : -INC CCOPTIO 20 : -INC SMCHAML 21 : -INC SMELEME 22 : -INC SMMODEL 23 : -INC CCHAMP 24 : -INC SMCOORD 25 : segment icpr(3,xcoor(/1)/(idim+1)) 26 : segment iextr(0) 27 : segment sielc 28 : integer ideb(niz),ifin(niz),nbcz,isens(2,nbele),idejvu(nbele) 29 : endsegment 30 : * stockage depointeurs sur des segment sielc 31 : segment siezo 32 : integer iezon(nsous) 33 : endsegment 34 : * 35 : MMODEL = ipmodl 36 : segact MMODEL 37 : nsous = kmodel(/1) 38 : 39 : segini siezo 40 : nbcabt=0 41 : iz=1 42 : C===== 43 : do 1000 isous=1,nsous 44 : imodel= kmodel(isous) 45 : 46 : segact imodel 47 : meleme = imamod 48 : * 49 : segact meleme 50 : nbele = num(/2) 51 : 52 : niz=50 53 : segini sielc 54 : iezon(isous)=sielc 55 : C 56 : segini iextr 57 : segini icpr 58 : C icpr(1,ip) contient le nombre d elements connectes au pt ip 59 : C icpr(2,ip) et (3,ip) les numeros des elements en question 60 : do iel=1,num(/2) 61 : do j=1,num(/1) 62 : ip = num(j,iel) 63 : icpr(1,ip) = icpr(1,ip)+1 64 : if(icpr(1,ip).le.2) then 65 : icpr(icpr(1,ip)+1,ip) =iel 66 : else 67 : C maillage incorrect deux cables se coupent 68 : segsup iextr,icpr,sielc,siezo 69 : segdes meleme,imodel,mmodel 70 : iret=0 70 : call erreur(845) 71 : return 72 : endif 73 : enddo 74 : enddo 75 : C tableau des extremites 76 : do iel=1,num(/2) 77 : do j=1,num(/1) 78 : if(icpr(1,num(j,iel)).eq.1) iextr(**)= num(j,iel) 79 : enddo 80 : enddo 81 : C write(6,*) (iextr(k),k=1,iextr(/1)) 82 : C 83 : C on fabrique de toute facon des objets temporaires 84 : C ----- reorientation et decoupages 85 : C il y a plusieurs cables dans le modele 86 : C isens(1,n) numero du nieme element ordonne dans le maillage originel 87 : C isens(2,n) son sens de parcours / par rapport au pt de depart 88 : nbc =0 89 : inel=0 90 : ip1= iextr(1) 91 : iextr(1)=0 92 : C 93 : 1999 continue 94 : 95 : nbc =nbc+1 96 : if (nbc.gt.niz) then 97 : niz = niz+50 98 : segadj sielc 99 : endif 100 : inel=inel+1 101 : iel=icpr(2,ip1) 102 : idejvu(iel)=inel 103 : isens(1,inel)=iel 104 : 105 : ideb(nbc)=inel 106 : if(num(2,iel).eq.ip1) then 107 : ip1=num(1,iel) 108 : isens(2,inel)=2 109 : else 110 : ip1=num(2,iel) 111 : isens(2,inel)=1 112 : endif 113 : C ---- recherche suite des elements 114 : if(icpr(1,ip1).eq.1) then 115 : C petit rattrapage pour fantaisie ( cables a 1 seul element ) 116 : i2= ip1 117 : goto 2001 118 : endif 119 : 1998 continue 120 : do 2000 ik=2,3 121 : iel=icpr(ik,ip1) 122 : if(idejvu(iel).ne.0) goto 2000 123 : if(num(1,iel).eq.ip1) then 124 : i2= num(2,iel) 125 : ise=1 126 : elseif(num(2,iel).eq.ip1) then 127 : i2= num(1,iel) 128 : ise=2 129 : endif 130 : C write(6,*) 'iel ip1 num ',iel,ip1, num(1,iel),num(2,iel) 131 : inel=inel+1 132 : idejvu(iel)=inel 133 : isens(1,inel)=iel 134 : isens(2,inel)=ise 135 : if(icpr(1,i2).eq.1) goto 2001 136 : ip1=i2 137 : 2000 continue 138 : goto 1998 139 : 2001 continue 140 : ifin(nbc)=inel 141 : C write(6,*) ' fin de la partition ' 142 : C write(6,*) nbc,ideb(nbc),ifin(nbc) 143 : C recherche d un nouveau depart 144 : do ik=1,iextr(/1) 145 : if(iextr(ik).eq.i2) iextr(ik)=0 146 : enddo 147 : do ik=1,iextr(/1) 148 : if(iextr(ik).ne.0) then 149 : ip1 =iextr(ik) 150 : iextr(ik)=0 151 : goto 1999 152 : endif 153 : enddo 154 : C fin du traitement des cables elementaires 155 : C endif 156 : nbcz=nbc 157 : C write(6,*) ' nombre de cables crees ' ,nbc,nbcz 158 : segdes sielc 159 : segsup icpr,iextr 160 : nbcabt=nbcabt+nbc 161 : 1000 continue 162 : 163 : 164 : 4444 format(10I4) 165 : C======== 166 : * 167 : * MCHELM caracteristiques MCHEL2 caract splitees 168 : * MCHEL3 contraintes init MCHEL4 cont int splitees 169 : * 170 : * le champ de caracteristiques 171 : n1=nbcabt 172 : n3=6 173 : MCHELM = ipcara 174 : segact MCHELM 175 : L1=titche(/1) 176 : segini,MMODE2,MCHEL2 177 : mchel2.ifoche=ifoche 178 : mchel2.titche=titche 179 : ipmod2= mmode2 180 : ipcar2= mchel2 181 : C 182 : if(ipchc1.ne.0) then 183 : MCHEL3 =ipchc1 184 : SEGACT MCHEL3 185 : L1=MCHEL3.titche(/1) 186 : segini MCHEL4 187 : ipchc2=MCHEL4 188 : mchel4.titche=mchel3.titche 189 : mchel4.ifoche=mchel3.ifoche 190 : else 191 : ipchc2 =0 192 : endif 193 : C 194 : mn3=infmod(/1) 195 : nfor=formod(/2) 196 : nmat=matmod(/2) 197 : nparmo=0 198 : C 199 : idmod=0 200 : do 2100 isous=1,nsous 201 : imodel = kmodel(isous) 202 : mchaml=ichaml(isous) 203 : segact imodel,mchaml 204 : meleme = imamod 205 : sielc=iezon(isous) 206 : segact sielc 207 : C======= 208 : do 2150 ibc = 1,nbcz 209 : idmod=idmod+1 210 : NBSOUS=0 211 : NBREF=0 212 : NBNN=2 213 : NBELEM=ifin(ibc)-ideb(ibc)+1 214 : C le meleme 215 : segini ipt1 216 : ipt1.itypel=2 217 : iii = 0 218 : do inel=ideb(ibc),ifin(ibc) 219 : iel=isens(1,inel) 220 : iii = iii+1 221 : if(isens(2,inel).eq.1) then 222 : do ip=1,2 223 : ipt1.num(ip,iii)=num(ip,iel) 224 : enddo 225 : else 226 : do ip=1,2 227 : ipt1.num(ip,iii)=num(3-ip,iel) 228 : enddo 229 : endif 230 : enddo 231 : C------------- 232 : segdes ipt1 232 : C call ecmail(ipt1) 233 : nobmod=0 234 : segini imode2 235 : mmode2.kmodel(idmod) = imode2 236 : C 237 : C le modele 238 : C 239 : imode2.imamod = ipt1 240 : imode2.nefmod=nefmod 241 : imode2.conmod=conmod 242 : do i=1,infmod(/1) 243 : imode2.infmod(i)=infmod(i) 244 : enddo 245 : do i=1,nfor 246 : imode2.formod(i) = formod(i) 247 : enddo 248 : do i=1,nmat 249 : imode2.matmod(i)=matmod(i) 250 : enddo 251 : C 252 : C ------- les caracteristiques 253 : C 254 : mchel2.conche(idmod)= conche(isous) 255 : mchel2.imache(idmod)= ipt1 256 : 257 : C ------- on a seulement besoin de 'YOUN' et 'SECT' 258 : n2=2 259 : segini mcham2 260 : mchel2.ichaml(idmod)= mcham2 261 : C 262 : do i=1,n3 263 : mchel2.infche(idmod,i)=infche(isous,i) 264 : enddo 265 : C 266 : N1EL= NBELEM 267 : N2EL= 0 268 : N2PTEL= 0 269 : C ipos=0 270 : do ic=1,ielval(/1) 271 : ipos=1 272 : if (nomche(ic).eq.'YOUN'.or.nomche(ic).eq.'SECT'. 273 : . or.nomche(ic).eq.'FF '.or.nomche(ic).eq.'PHIF') then 274 : if (nomche(ic).eq.'SECT'.or.nomche(ic).eq.'PHIF') ipos=2 275 : 276 : melval=mchaml.ielval(ic) 277 : segact melval 278 : N1PTEL= velche(/1) 279 : if(velche(/2).eq.1) N1EL=1 280 : segini melva2 281 : mcham2.ielval(ipos)= melva2 282 : mcham2.nomche(ipos)=nomche(ic) 283 : mcham2.typche(ipos)=typche(ic) 284 : 285 : if(velche(/1).eq.1.and.velche(/2).eq.1) then 286 : melva2.velche(1,1)=velche(1,1) 287 : else 288 : iii=0 289 : do inel=ideb(ibc),ifin(ibc) 290 : iii=iii+1 291 : iel=isens(1,inel) 292 : if(isens(2,inel).eq.1) then 293 : do ip=1,velche(/1) 294 : melva2.velche(ip,iii) = velche(ip,iel) 295 : enddo 296 : else 297 : id=2 298 : if(velche(/1).eq.2) id=3 299 : do ip=1,velche(/1) 300 : melva2.velche(ip,iii) = velche(id-ip,iel) 301 : enddo 302 : endif 303 : enddo 304 : endif 305 : segdes melva2,melval 306 : endif 307 : enddo 308 : segdes mcham2 309 : C 310 : C les precontraintes 311 : C 312 : if(ipchc1.ne.0) then 313 : C mchel4.titche=mchel3.titche 314 : C mchel4.ifoche=mchel3.ifoche 315 : mchel4.imache(idmod)= ipt1 316 : mcham3=mchel3.ichaml(isous) 317 : mchel4.conche(idmod)= mchel3.conche(isous) 318 : do i=1,n3 319 : mchel4.infche(idmod,i)=mchel3.infche(isous,i) 320 : enddo 321 : C 322 : segact mcham3 323 : n2=mcham3.ielval(/1) 324 : segini mcham4 325 : mchel4.ichaml(idmod)= mcham4 326 : C 327 : N1EL= NBELEM 328 : N2EL= 0 329 : N2PTEL= 0 330 : C 331 : do ic=1,n2 332 : mcham4.nomche(ic)=mcham3.nomche(ic) 333 : mcham4.typche(ic)=mcham3.typche(ic) 334 : melval = mcham3.ielval(ic) 335 : segact melval 336 : N1PTEL= velche(/1) 337 : if(velche(/2).eq.1) N1EL=1 338 : segini melva4 339 : mcham4.ielval(ic)=melva4 340 : C 341 : if(velche(/1).eq.1.and.velche(/2).eq.1) then 342 : melva4.velche(1,1)=velche(1,1) 343 : else 344 : iii=0 345 : do inel=ideb(ibc),ifin(ibc) 346 : iel=isens(1,inel) 347 : iii=iii+1 348 : if(isens(2,inel).eq.1) then 349 : do ip=1,velche(/1) 350 : melva4.velche(ip,iii) = velche(ip,iel) 351 : enddo 352 : else 353 : do ip=1,velche(/1) 354 : melva4.velche(ip,iii) = velche(3-ip,iel) 355 : enddo 356 : endif 357 : enddo 358 : endif 359 : segdes melval,melva4 360 : enddo 361 : segdes mcham4 362 : endif 363 : C 364 : 2150 continue 365 : segdes sielc,mchaml 366 : if(ipchc1.ne.0) segdes mcham3 367 : 2100 continue 368 : segdes MMODEl,MCHELM 369 : segdes MMODE2,mchel2 370 : if(ipchc1.ne.0) then 371 : segdes MCHEL3,MCHEL4 372 : endif 373 : segdes siezo 374 : return 375 : end 376 : 377 : 378 : 379 : 380 : 381 : 382 : 383 : 384 : 385 : 386 : 387 : 388 : 389 : 390 : 391 : 392 :
© Cast3M 2003 - All rights reserved.
Disclaimer