1 : C PRECOP SOURCE CHAT 11/03/16 21:29:18 6902 2 : SUBROUTINE PRECOP(IPMODL,IPCHA1,IPTAB,IPSTRS,IRAN, 3 : & PS1,IPCHC1,IRET) 4 : C======================================================================C 5 : C C 6 : C ENTREES : C 7 : C C 8 : C IPMODL: POINTEUR SUR UN MMODEL C 9 : C IPCHA1: Pointeur sur le MCHAML de CARACTERISTIQUES C 10 : C PS1 : Force sous vérin 11 : C IRAN : Pointeur sur maillage des points d application 12 : C IPCHC1: POINTEUR SUR le MCHAML DE PRECONTRAINTE INITIALE 13 : C IPTAB : pointeur sur la table des parametres frottement .... C 14 : C C 15 : C SORTIES : C 16 : C C 17 : C IPSTRS: MCHAML CONTENANT LES PRECONTAINTES ET LES FORCES C 18 : C DU CABLE SUR LE BETON C 19 : C IRET : 1 cela c est bien passe 20 : C 0 probleme dans le traitement C 21 : C C 22 : C======================================================================C 23 : IMPLICIT INTEGER(I-N) 24 : IMPLICIT REAL*8(A-H,O-Z) 25 : C 26 : -INC CCOPTIO 27 : -INC SMCHAML 28 : -INC SMELEME 29 : -INC SMINTE 30 : -INC SMMODEL 31 : -INC CCHAMP 32 : -INC SMCOORD 33 : -INC SMTABLE 34 : C 35 : REAL*8 XVALIN,XVALRE 36 : LOGICAL LOGRE,LOGIN 37 : CHARACTER*8 TAPIND,TYPOBJ,CHARIN,CHARRE 38 : CHARACTER*4 MOPAR(6) 39 : * 40 : DATA MOPAR/'F1 ','F2 ','GANC','RMU0','FPRG','RH10'/ 41 : SEGMENT INFO 42 : INTEGER INFELL(JG) 43 : ENDSEGMENT 44 : * stockage de pointeurs sur des segment sielc crees dans splitag 45 : segment siezo 46 : integer iezon(*) 47 : endsegment 48 : segment sielc 49 : integer ideb(*),ifin(*),nbcz,isens(2,*),idejvu(*) 50 : endsegment 51 : C 52 : SEGMENT ALTRAV 53 : REAL*8 ANG(NAM+1),DANG(NAM),ACUR(NAM+1),DACUR(NAM) 54 : ENDSEGMENT 55 : C 56 : SEGMENT NOTYPE 57 : CHARACTER*16 TYPE(NBTYPE) 58 : ENDSEGMENT 59 : C 60 : SEGMENT MPTVAL 61 : INTEGER IPOS(NS) ,NSOF(NS) 62 : INTEGER IVAL(NCOSOU) 63 : CHARACTER*16 TYVAL(NCOSOU) 64 : ENDSEGMENT 65 : C 66 : SEGMENT WRK3 67 : REAL*8 X1(3),X2(3),X3(3),RL(3),RS(3) 68 : ENDSEGMENT 69 : 70 : C 71 : CHARACTER*8 CMATE,LNOM 72 : CHARACTER*(NCONCH) CONM 73 : PARAMETER ( NINF=3 ) 74 : PARAMETER ( ITEMAX=50 ) 75 : INTEGER INFOS(NINF) 76 : DIMENSION FGG(ITEMAX),XLAM(ITEMAX) 77 : logical ivers,lsupco 78 : 79 : cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 80 : 81 : if (ipchc1.ne.0) then 82 : MCHELM = ipchc1 83 : segact MCHELM 84 : C actuellement un cable n a qu une zone de maillage 85 : imail = imache(1) 86 : segdes MCHELM 87 : endif 88 : 89 : IRET=0 90 : C verification on doit avoir des elements soit BARR soit CERC 91 : MMODEL = ipmodl 92 : segact mmodel 93 : do i = 1,kmodel(/1) 94 : imodel = kmodel(i) 95 : segact imodel 96 : if(ipchc1.ne.0.and.imail.ne.imamod) then 96 : call erreur(21) 97 : return 98 : endif 99 : meleme = imamod 100 : segact meleme 101 : if(ifomod.eq.0.and.itypel.ne.1) then 102 : segdes imodel,meleme,mmodel 102 : call erreur(21) 103 : return 104 : endif 105 : segdes imodel,meleme 106 : enddo 107 : segdes mmodel 108 : 109 : C --- Vérification du support des MCHAML -------------- 110 : 111 : if(ipchc1.gt.0) then 111 : call quesup(ipmodl,ipchc1,5,0,iresig,iret2) 112 : if(iresig.eq.9999) then 113 : moterr(1:8)='CONTRAIN' 113 : call erreur(124) 114 : return 115 : endif 116 : endif 117 : 117 : call quesup(ipmodl,ipcha1,5,0,irecar,iret2) 118 : if(irecar.eq.9999) then 119 : moterr(1:8)='CARACTER' 119 : call erreur(124) 120 : return 121 : endif 122 : if(irecar.eq.1) then 123 : ipcara = 0 124 : iret = 0 124 : call chasup(ipmodl,ipcha1,ipcara,iret,5) 125 : if(iret.ne.0) return 126 : else 127 : ipcara = ipcha1 128 : endif 129 : *--------------------------------------------------------- 130 : ipmod0 = ipmodl 131 : *--------------------------------------------------------- 132 : if(ifomod.ne.0.and.ifomod.ne.1) then 133 : ipcar0 = ipcara 134 : ipchc0 = ipchc1 134 : call splitag(ipmodl,ipcara,ipchc1,ipmod2,ipcar2, 135 : & ipchc2,siezo) 136 : ipmodl = ipmod2 137 : ipcara = ipcar2 138 : ipchc1 = ipchc2 139 : else 140 : C pas elegant mais on duplique le modele 141 : MMODEL = ipmodl 142 : segini , mmode2=MMODEL 143 : ipmodl = mmode2 144 : endif 145 : C 146 : ipmodt = ipmodl 147 : MMODEL = IPMODL 148 : C 149 : SEGACT MMODEL 150 : NSOUS=KMODEL(/1) 151 : C 152 : C ----PREPARATION DU CHAMP DE SORTIE---------------- 153 : C 154 : mmode2 = ipmod0 155 : segact mmode2 156 : N1=mmode2.kmodel(/1) 157 : L1=11 158 : N3=6 159 : segini mchel5 160 : mchel5.titche='CONTRAINTES' 161 : mchel5.ifoche=ifour 162 : 163 : do isous=1,n1 164 : imodel=mmode2.kmodel(isous) 165 : segact imodel 166 : mchel5.imache(isous)=imamod 167 : mchel5.conche(isous)=conmod 168 : mele= nefmod 169 : C==== 169 : CALL ELQUOI(MELE,0,5,INFO,IMODEL) 170 : IF (IERR.NE.0) THEN 171 : SEGDES IMODEL*NOMOD,MMODEL*NOMOD 172 : SEGSUP MCHEL5 173 : IRET=0 174 : RETURN 175 : ENDIF 176 : MINTE= INFELL(11) 177 : C==== 178 : MCHEL5.INFCHE(ISOUS,1)=0 179 : MCHEL5.INFCHE(ISOUS,2)=0 180 : MCHEL5.INFCHE(ISOUS,3)=NIFOUR 181 : MCHEL5.INFCHE(ISOUS,4)=MINTE 182 : MCHEL5.INFCHE(ISOUS,5)=0 183 : MCHEL5.INFCHE(ISOUS,6)=5 184 : C 185 : N2=1 186 : segini MCHAML 187 : mchel5.ichaml(isous)=mchaml 188 : nomche(1)='EFFX' 189 : typche(1)='REAL*8' 190 : meleme = imamod 191 : segact meleme 192 : N1PTEL=2 193 : N1EL= NUM(/2) 194 : N2PTEL=0 195 : N2EL=0 196 : segini melval 197 : ielval(1)=melval 198 : segdes melval,mchaml,meleme,imodel 199 : segsup info 200 : enddo 201 : 202 : segdes mmode2 203 : C 204 : C ----FIN PREPARATION DU CHAMP DE SORTIE---------------- 205 : C 206 : 207 : C preparation de la recherche du sens d application des tensions 208 : if(iran.ne.0) then 209 : ipt3=iran 210 : segact ipt3 211 : segini , ipt5=ipt3 212 : segdes ipt3 213 : ity=ipt5.itypel 214 : if(ity.ne.1) then 215 : segdes ipt5 215 : call change(iran,1) 216 : ipt5=iran 217 : segact ipt5 218 : endif 219 : else 220 : ipt5=0 221 : endif 222 : 223 : C 224 : C --- CREATION DU MCHELM DE CALCUL ( TEMPORAIRE ) 225 : C 226 : N1=NSOUS 227 : C 228 : L1=11 229 : N3=6 230 : SEGINI MCHELM 231 : TITCHE='CONTRAINTES' 232 : IFOCHE=IFOUR 233 : IPSTRS=MCHELM 234 : C 235 : C --- DEBUT DE LA BOUCLE SUR LES DIFFERENTES ZONES 236 : C 237 : DO 500 ISOUS=1,NSOUS 238 : C 239 : C --- INITIALISATION 240 : C 241 : MOCARA=0 242 : MOMATR=0 243 : MOSTRS=0 244 : IVAMAT=0 245 : IVACAR=0 246 : IVASTR=0 247 : ivasi0=0 248 : c 249 : ipeffx = 0 250 : ipyoun = 0 251 : ipff = 0 252 : ipphif = 0 253 : ipganc = 0 254 : iprmu0 = 0 255 : ipfprg = 0 256 : iprh10 = 0 257 : ipsect = 0 258 : IMODEL=KMODEL(ISOUS) 259 : SEGACT IMODEL 260 : IPMAIL=IMAMOD 261 : CONM =CONMOD 262 : IMACHE(ISOUS)=IPMAIL 263 : CONCHE(ISOUS)=CONMOD 264 : C ...... TRAITEMENT DU MODELE ...................... 265 : 266 : MELE=NEFMOD 267 : MELEME=IPMAIL 268 : C 269 : segact meleme 270 : itpdel=itypel 271 : 272 : NFOR=FORMOD(/2) 273 : NMAT=MATMOD(/2) 274 : C 275 : C ... on ordonne le nouveau maillage (si on en a besoin) ... 276 : 277 : NBELEM = NUM(/2) 278 : C===================================================== 279 : if(itypel.eq.1) then 280 : 281 : c ... dans le cas des POI1 on n'a rien a orienter ... 282 : C===================================================== 283 : elseif(itypel.eq.2) then 284 : 285 : ipt2 = meleme 286 : NOD1=NUM(1,1) 287 : NOD2=NUM(2,num(/2)) 288 : C write(6,*)' noeuds extremites ' ,nod1,nod2 289 : if(iran.eq.0) then 290 : ivers=.false. 291 : else 292 : do ino=1,ipt5.num(/2) 293 : inodi=ipt5.num(1,ino) 294 : if(inodi.eq.nod1) then 295 : ivers=.false. 296 : goto 364 297 : elseif(inodi.eq.nod2) then 298 : ivers=.true. 299 : goto 364 300 : endif 301 : enddo 302 : C aucune des extremites n'est dans la liste 303 : C on applique au point final 303 : call erreur(833) 304 : C attention aux desactivations 305 : SEGDES IMODEL*NOMOD,MMODEL*NOMOD ,meleme 306 : SEGSUP MCHELM 307 : IRET=0 308 : RETURN 309 : 364 continue 310 : endif 311 : C===================================================== 312 : c ... si ITYPEL différent de 1 et 2 ... 313 : else 314 : 315 : c ... Type d''élément support inconnu !!!!!!!!!!! ............ 316 : SEGDES IMODEL*NOMOD,MMODEL*NOMOD ,meleme 317 : SEGSUP MCHELM 318 : IRET=0 319 : RETURN 319 : call erreur(19) 320 : return 321 : endif 322 : C===================================================== 323 : C 324 : C ------ NATURE DU MATERIAU 325 : C 325 : CALL NOMATE(FORMOD,NFOR,MATMOD,NMAT,CMATE,MATE,INAT) 326 : IF (CMATE.EQ.' ') THEN 326 : CALL ERREUR(251) 327 : SEGDES IMODEL*NOMOD,MMODEL*NOMOD ,meleme 328 : SEGSUP MCHELM 329 : IRET=0 330 : RETURN 331 : ENDIF 332 : C 333 : C ------ INFORMATION SUR L'ELEMENT FINI 334 : C 334 : CALL ELQUOI(MELE,0,5,IPINF,IMODEL) 335 : IF (IERR.NE.0) THEN 336 : SEGDES IMODEL*NOMOD,MMODEL*NOMOD,meleme 337 : SEGSUP MCHELM 338 : IRET=0 339 : RETURN 340 : ENDIF 341 : C 342 : INFO=IPINF 343 : MELE =INFELL(1) 344 : MFR =INFELL(13) 345 : MINTE=INFELL(11) 346 : NSTRS=INFELL(16) 347 : 348 : SEGINI WRK3 349 : C 350 : C ------ CREATION DU TABLEAU INFOS 351 : C 352 : IPCHE1=0 353 : IPCHE2=0 354 : c ... ATTENTION !!! A quoi ca sert ????????????? ....... 354 : CALL IDENT(IPMAIL,CONM,IPCHE1,IPCHE2,INFOS,IRTD) 355 : IF (IRTD.EQ.0) THEN 356 : SEGDES IMODEL*NOMOD,MMODEL*NOMOD,meleme 357 : SEGSUP MCHELM 358 : SEGSUP INFO 359 : IRET=0 360 : RETURN 361 : ENDIF 362 : 363 : c ... Remplissage du tableau INFCHE du MCHELM ... 364 : 365 : INFCHE(ISOUS,1)=0 366 : INFCHE(ISOUS,2)=0 367 : INFCHE(ISOUS,3)=NIFOUR 368 : INFCHE(ISOUS,4)=MINTE 369 : INFCHE(ISOUS,5)=0 370 : INFCHE(ISOUS,6)=5 371 : C 372 : C ------ LECTURE de NBPGAU dans 373 : C 374 : SEGACT MINTE 375 : NBPGAU=POIGAU(/1) 376 : SEGDES MINTE 377 : C 378 : C ------ RECHERCHE DES NOMS DE COMPOSANTES des contraintes ... 379 : C 380 : if(lnomid(4).ne.0) then 381 : nomid=lnomid(4) 382 : segact nomid 383 : mostrs=nomid 384 : nstr=lesobl(/2) 385 : nfac=lesfac(/2) 386 : lsupco=.false. 387 : else 388 : lsupco=.true. 388 : CALL IDCONT(IMODEL,IFOUR,MOSTRS,NSTR,NFAC) 389 : endif 390 : nomid = mostrs 391 : segact,nomid 391 : call place(lesobl,nstr,ipeffx,'EFFX') 392 : segdes,nomid 393 : C 394 : C ------ VERIFICATION DE LEUR PRESENCE et ... 395 : C ------ RECUPERATION DES CONTRAINTES INITIALES (s'il le faut) ... 396 : C 397 : if(IPCHC1.gt.0) then 398 : 399 : NBTYPE=INFELL(16) 400 : SEGINI NOTYPE 401 : MOTYPE=NOTYPE 402 : TYPE(1)='REAL*8' 403 : 403 : call komcha(ipchc1,ipmail,conm,mostrs,motype,1,infos,3, 404 : & ivasi0) 405 : 406 : IF (IERR.NE.0) THEN 407 : NSTRS=0 408 : GOTO 9990 409 : ENDIF 410 : 411 : SEGSUP NOTYPE 412 : endif 413 : 414 : C 415 : C ------ CREATION DU MCHAML DE LA SOUS ZONE 416 : C 417 : N2=NSTRS 418 : SEGINI MCHAML 419 : ICHAML(ISOUS)=MCHAML 420 : 421 : NS=1 422 : NCOSOU=NSTRS 423 : SEGINI MPTVAL 424 : IVASTR=MPTVAL 425 : 426 : C 427 : C ------ RECHERCHE DE LA TAILLE DES MELVAL A ALLOUER 428 : C 429 : N1PTEL=nbpgau 430 : N1EL=NBELEM 431 : N2PTEL=0 432 : N2EL=0 433 : C 434 : NOMID=MOSTRS 435 : SEGACT NOMID 436 : C initialisation des melvals des precontaintes 437 : DO 100 ICOMP=1,NSTRS 438 : NOMCHE(ICOMP)=LESOBL(ICOMP) 439 : TYPCHE(ICOMP)='REAL*8' 440 : SEGINI MELVAL 441 : IELVAL(ICOMP)=MELVAL 442 : IVAL(ICOMP)=MELVAL 443 : 100 CONTINUE 444 : SEGDES NOMID 445 : C ipacara preparé dans splitag 446 : C recuperation du module de young dans ivamat ( position 1 ) 447 : C recuperation de la section dans ivacar ( position 2 ) 448 : mchel6=ipcara 449 : segact mchel6 450 : mcham6=mchel6.ichaml(isous) 451 : segact mcham6 452 : melval= mcham6.ielval(1) 453 : segact melval 454 : ivamat=melval 455 : melval= mcham6.ielval(2) 456 : segact melval 457 : ivacar=melval 458 : 459 : C 460 : C ------ CALCUL lui même -------------------------- 461 : C 462 : C ... cas du CERC ... 463 : C 464 : 465 : IF(MELE.EQ.95) THEN 466 : DO 2004 IB=1,NBELEM 467 : MPTVAL=IVASTR 468 : DO 1701 I=1,NSTRS 469 : MELVAL=IVAL(I) 470 : VELCHE(1,IB)=PS1 471 : 1701 CONTINUE 472 : iret=1 473 : 2004 CONTINUE 474 : 475 : ELSE 476 : C ----------------valeurs par defaut ---------------------- 477 : 478 : f1 = 0.18d0 479 : f2 = 0.002d0 480 : ganc = 0.d0 481 : rmu0 = 0.43d0 482 : fprg = 1.7d9 483 : rh10 = 2.5d0 484 : 485 : if(iptab.ne.0) then 486 : MTABLE = iptab 487 : segact mtable 488 : nbind= mlotab 489 : IVALIN = 0 490 : XVALIN = 0.D0 491 : LOGIN = .TRUE. 492 : IOBIN = 0 493 : TAPIND = 'MOT' 494 : C 495 : TYPOBJ = ' ' 495 : Call acctab(MTABLE,'MOT',IVALIN,XVALIN,'FF',LOGIN,0, 496 : & TYPOBJ,IVELRE,XVALRE,CHARRE,LOGRE,IOBRE) 497 : IF(TYPOBJ.EQ.'FLOTTANT') F1 = XVALRE 498 : IF(TYPOBJ.EQ.'ENTIER ') F1 = IVELRE 499 : TYPOBJ = ' ' 499 : Call acctab(MTABLE,'MOT',IVALIN,XVALIN,'PHIF',LOGIN,0, 500 : & TYPOBJ,IVELRE,XVALRE,CHARRE,LOGRE,IOBRE) 501 : IF(TYPOBJ.EQ.'FLOTTANT') F2 = XVALRE 502 : IF(TYPOBJ.EQ.'ENTIER ') F2 = IVELRE 503 : TYPOBJ = ' ' 503 : Call acctab(MTABLE,'MOT',IVALIN,XVALIN,'GANC',LOGIN,0, 504 : & TYPOBJ,IVELRE,XVALRE,CHARRE,LOGRE,IOBRE) 505 : IF(TYPOBJ.EQ.'FLOTTANT') GANC = XVALRE 506 : IF(TYPOBJ.EQ.'ENTIER ') GANC = IVELRE 507 : TYPOBJ = ' ' 507 : Call acctab(MTABLE,'MOT',IVALIN,XVALIN,'RMU0',LOGIN,0, 508 : & TYPOBJ,IVELRE,XVALRE,CHARRE,LOGRE,IOBRE) 509 : IF(TYPOBJ.EQ.'FLOTTANT') RMU0 = XVALRE 510 : IF(TYPOBJ.EQ.'ENTIER ') RMU0 = IVELRE 511 : TYPOBJ = ' ' 511 : Call acctab(MTABLE,'MOT',IVALIN,XVALIN,'FPRG',LOGIN,0, 512 : & TYPOBJ,IVELRE,XVALRE,CHARRE,LOGRE,IOBRE) 513 : IF(TYPOBJ.EQ.'FLOTTANT') FPRG = XVALRE 514 : IF(TYPOBJ.EQ.'ENTIER ') RPRG = IVELRE 515 : TYPOBJ = ' ' 515 : Call acctab(MTABLE,'MOT',IVALIN,XVALIN,'RH10',LOGIN,0, 516 : & TYPOBJ,IVELRE,XVALRE,CHARRE,LOGRE,IOBRE) 517 : IF(TYPOBJ.EQ.'FLOTTANT') RH10 = XVALRE 518 : IF(TYPOBJ.EQ.'ENTIER ') RH10 = IVELRE 519 : segdes MTABLE 520 : 521 : 4321 format(6E12.5) 522 : endif 523 : C---------------------------------------------------------- 524 : C write(6,4321) f1,f2,ganc,rmu0,fprg,rh10 525 : C 526 : C ... Boucle sur les éléments dans lesquels on fait le calcul ... 527 : C 528 : 529 : SLON=0.0D0 530 : FAI=0.0D0 531 : ids= idim+1 532 : segact,minte 533 : if(nbpgau.ne.2) then 533 : call erreur(5) 534 : return 535 : endif 536 : * 537 : * NEW 1-ERE BOUCLE SUR LES ELEMENTS POUR TROUVER 538 : * LA LONGUEUR D'INFLUENCE DU RECUL D'ANCRAGE 539 : * 540 : NAM =NBELEM 541 : SEGINI ALTRAV 542 : IAM=0 543 : SUM =0.D0 544 : ***** PRINT *,'IVERS=',IVERS 545 : * 546 : DO 5005 IC=1,NBELEM 547 : 548 : if(ivers) then 549 : C ordre inverse 550 : JC= NBELEM+1-IC 551 : NC3=ipt2.NUM(1,JC) 552 : NC2=ipt2.NUM(2,JC) 553 : IF(JC.EQ.NBELEM) THEN 554 : NC1=NC2 555 : ELSE 556 : NC1=IPT2.NUM(2,JC+1) 557 : ENDIF 558 : else 559 : C ordre normal 560 : JC=IC 561 : NC3=ipt2.NUM(2,JC) 562 : NC2=ipt2.NUM(1,JC) 563 : IF(JC.EQ.1) THEN 564 : NC1=NC2 565 : ELSE 566 : NC1=IPT2.NUM(1,JC-1) 567 : ENDIF 568 : endif 569 : ***** PRINT *,'NC1=',NC1,' NC2=',NC2,' NC3=',NC3 570 : JS1=(NC1-1)*IDS 571 : JS2=(NC2-1)*IDS 572 : JS3=(NC3-1)*IDS 573 : 574 : DO 511 IW=1,IDIM 575 : X1(IW)=XCOOR(JS1+IW) 576 : X2(IW)=XCOOR(JS2+IW) 577 : 511 X3(IW)=XCOOR(JS3+IW) 578 : C --- Distance entre points 579 : DS1=0.0D0 580 : DS2=0.0D0 581 : DO 512 IW=1,IDIM 582 : RL(IW)=X3(IW)-X2(IW) 583 : RS(IW)=X2(IW)-X1(IW) 584 : DS1=DS1+RL(IW)*RL(IW) 585 : 512 DS2=DS2+RS(IW)*RS(IW) 586 : DS1=SQRT(DS1) 587 : DS2=SQRT(DS2) 588 : CS1=0.0D0 589 : IF(DS2.NE.0.D0) THEN 590 : DO 513 IW=1,IDIM 591 : RL(IW)=RL(IW)/DS1 592 : RS(IW)=RS(IW)/DS2 593 : 513 CS1=CS1+RL(IW)*RS(IW) 594 : ELSE 595 : CS1=1.D0 596 : ENDIF 597 : IF(CS1.GT.1.0) CS1=1.0D0 598 : ALFA=ACOS(CS1) 599 : IAM=IAM+1 600 : ANG(IAM)=FAI 601 : DANG(IAM)=ALFA 602 : ACUR(IAM)=SLON 603 : DACUR(IAM)=DS1 604 : SLON=SLON+DS1 605 : FAI=FAI+ALFA 606 : 607 : * PRINT *,'IAM=',IAM, ' ACUR =',ACUR(IAM), 608 : * & ' ANG=',ANG(IAM),' DACUR=',DACUR(IAM),' DANG=',DANG(IAM) 609 : * 610 : IF(SLON.NE.0.D0) THEN 611 : SUM = SUM + FAI/SLON 612 : ENDIF 613 : * 614 : 5005 CONTINUE 615 : ANG(NAM+1)=FAI 616 : ACUR(NAM+1)=SLON 617 : * 618 : SLONT=SLON 619 : FAIT=FAI 620 : XLMBDA=0.D0 621 : * 622 : IF(GANC.EQ.0.D0) GO TO 7999 623 : * 624 : *------------------------------------------------------------ 625 : * CALCUL DE LA LONGUEUR D'INFLUENCE DU RECUL D'ANCRAGE 626 : * LE CAS ECHEANT ( GANC > 0 ) 627 : *------------------------------------------------------------ 628 : * 629 : * ON PREND LES MODULE ET SECTION DU 1-ER ELEMENT 630 : * POUR LA 1-ERE APPROXIMATION DE XLAMBDA 631 : * 632 : MELVAL =IVAMAT 633 : EA = VELCHE(1,1) 634 : MELVAL =IVACAR 635 : SECT1 = VELCHE(1,1) 636 : * write(6,*) ' f1, f2, slont, ps1, sect1, ea,ganc,sum,nbelem,fai' 637 : * write(6,*) f1, f2, slont, ps1, sect1, ea,ganc,sum,nbelem,fai 638 : IF(F1.EQ.0.D0.OR.FAI.LE.1.D-4) THEN 639 : IF(F2.EQ.0.D0) THEN 640 : XLMBDA=SLONT 641 : ELSE 642 : aaa= F2*GANC*EA*SECT1/PS1 643 : bbb = aaa ** 0.5 644 : ccc = 1.-bbb 645 : if( ccc .le.0.) then 645 : call erreur(768) 646 : return 647 : else 648 : * write(6,*) ' aaa,bbb,ccc',aaa,bbb,ccc 649 : XLMBDA = -(LOG(1.D0- 650 : & (F2*GANC*EA*SECT1/PS1)**0.5))/F2 651 : endif 652 : ENDIF 653 : ELSE 654 : ALSURL=SUM/FLOAT(NBELEM) 655 : PP= F1*ALSURL + F2 656 : IF(PP.EQ.0.D0) THEN 657 : XLMBDA=SLONT 658 : ELSE 659 : XLMBDA = SQRT( (GANC*EA*SECT1)/(PS1*PP) ) 660 : ENDIF 661 : * PRINT *,'ALSURL=',ALSURL 662 : * PRINT *,'F2=',F2, 'PP=',PP 663 : ENDIF 664 : * 665 : * TEST SI XLAMBBDA > SLON 666 : * 667 : IF(XLMBDA.GT.SLONT) XLMBDA=SLONT 668 : 669 : * PRINT *,'INITIALISATION DE XLMBDA=',XLMBDA 670 : * 671 : IF(XLMBDA.LT.0.D0) THEN 672 : ***** PRINT *,' ATTENTION XLAMBDA INITIAL EST < 0 ' 672 : CALL ERREUR(460) 673 : SEGSUP ALTRAV 674 : GO TO 9990 675 : ENDIF 676 : * 677 : ITER=0 678 : LAST=0 679 : IDICH=0 680 : * 681 : * ITERATIONS 682 : * 683 : 8000 CONTINUE 684 : ITER=ITER+1 685 : * PRINT *,'ITER = ',ITER 686 : IF(ITER.GT.ITEMAX) THEN 686 : CALL ERREUR(460) 687 : SEGSUP ALTRAV 688 : GO TO 9990 689 : ENDIF 690 : PSL=0.D0 691 : SLON=0.0D0 692 : FAI=0.0D0 693 : IAM=0 694 : * 695 : IF(LAST.EQ.0) THEN 696 : * write(6,*) ' nam + 1',nam+1 697 : * write(6,*) ' xlmbda acur(1) acur(2) ang(1) ang(2) ' 698 : * write(6,*) xlmbda,acur(1), acur(2) ,ang(1),ang(2) 699 : * CALCUL DE L'ANGLE XALFA ASSOCIE A XLMBDA 699 : CALL PRECN0(XLMBDA,ACUR,ANG,NAM+1,ANGBDA,ISUC) 700 : IF(ISUC.EQ.NAM+1) ISUC=NAM 701 : * 702 : ***** PRINT *,'ISUC=',ISUC 703 : IF(ISUC.LT.0) THEN 703 : CALL ERREUR(-ISUC) 704 : SEGSUP ALTRAV 705 : GO TO 9990 706 : ENDIF 707 : 708 : SD=F1*ANGBDA + F2*XLMBDA 709 : DSDDD=F1*DANG(ISUC)/DACUR(ISUC)+F2 710 : * 711 : ELSE 712 : SD=F1*FAIT + F2 * SLONT 713 : ENDIF 714 : * 715 : GG=0.D0 716 : DGDD=0.D0 717 : DO 8005 IC=1,NBELEM 718 : if(ivers) then 719 : JC= NBELEM+1-IC 720 : else 721 : JC=IC 722 : endif 723 : * 724 : IAM=IAM+1 725 : ALFA = DANG(IAM) 726 : DS1 = DACUR(IAM) 727 : 728 : do 8006 iptg=1,nbpgau 729 : 730 : if(ivers) then 731 : ig= nbpgau+1-iptg 732 : else 733 : ig = iptg 734 : endif 735 : 736 : * ---- Récupération des caractéristiques matérielles et géométriques ---- 737 : 738 : melval =ivamat 739 : ea = velche(min(ig,velche(/1)), 740 : & min(JC,velche(/2))) 741 : 742 : melval =ivacar 743 : sect1 = velche(min(ig,velche(/1)), 744 : & min(JC,velche(/2))) 745 : 746 : SABS=SLON + DS1*(1+QSIGAU(IPTG))/2 747 : IF(SABS.GT.XLMBDA) GO TO 8007 748 : 749 : SP=F1*FAI + F2*SABS 750 : IF(LAST.EQ.0) THEN 751 : GG = GG + 752 : & PS1 * (EXP(-SP) - EXP(SP-2.D0*SD))*DS1*0.5D0 753 : & /(EA*SECT1) 754 : 755 : DGDD = DGDD + 756 : & PS1 * (EXP(SP-2.D0*SD))*DSDDD*DS1/(EA*SECT1) 757 : ELSE 758 : GG = GG + PS1 * (EXP(-SP))*DS1*0.5D0 759 : & /(EA*SECT1) 760 : DGDD = DGDD + (EXP(SP-SD))*DS1*0.5D0 761 : & /(EA*SECT1) 762 : ENDIF 763 : 764 : 8006 continue 765 : SLON=SLON+DS1 766 : FAI=FAI+ALFA 767 : 8005 CONTINUE 768 : * 769 : * TEST DE CONVERGENCE 770 : * 771 : 8007 CONTINUE 772 : ***** PRINT *,'GG=',GG, ' GANC=',GANC,' FG =',GG-GANC 773 : ***** PRINT *,'DGDD=', DGDD 774 : 775 : FGG(ITER)=GG-GANC 776 : XLAM(ITER)=XLMBDA 777 : 778 : * 779 : * CAS OU L'EFFET DE L'ANCRAGE DEPASSE LA LONGUEUR 780 : * DU CABLE 781 : * 782 : ***** PRINT *,'LAST=',LAST 783 : IF(LAST.EQ.1) THEN 784 : 785 : IF(ABS(GG-GANC)/GANC.LT.1.D-3) THEN 786 : PSL=0.D0 787 : ELSE 788 : PSL=(GG-GANC)/DGDD 789 : ENDIF 790 : 791 : ***** PRINT *,'PSL=',PSL 792 : IF(PSL.GT.PS1*EXP(-SD)) THEN 793 : ***** PRINT *,' ATTENTION PSL EST TROP GRAND ' 794 : ENDIF 795 : GO TO 7999 796 : ENDIF 797 : 798 : 799 : IF(ABS(GG-GANC)/GANC.LT.1.D-3) GO TO 7999 800 : * 801 : IF(ITER.GE.6 .AND.IDICH.EQ.0.AND. 802 : & FGG(ITER)*FGG(ITER-1).LT.0.D0) THEN 803 : IDICH=1 804 : XLAM1=XLAM(ITER-1) 805 : XLAM2=XLAM(ITER) 806 : FG1=FGG(ITER-1) 807 : FG2=FGG(ITER) 808 : ENDIF 809 : ***** PRINT *,'IDICH=',IDICH 810 : * 811 : IF(IDICH.EQ.0) THEN 812 : XLMBDA=XLMBDA - (GG-GANC)/DGDD 813 : ELSE 814 : ***** PRINT *,'XLAM(ITER)=',XLAM(ITER) 815 : ***** PRINT *, ' FGG(ITER)=',FGG(ITER) 816 : 817 : IF(FG1*FGG(ITER).LT.0.D0) THEN 818 : XLAM2=XLAM(ITER) 819 : FG2=FGG(ITER) 820 : ELSE IF (FG1*FGG(ITER).GT.0.D0) THEN 821 : XLAM1=XLAM(ITER) 822 : FG1=FGG(ITER) 823 : ENDIF 824 : * 825 : ***** PRINT *,'XLAM1=',XLAM1,' FG1=',FG1 826 : ***** PRINT *,'XLAM2=',XLAM2,' FG2=',FG2 827 : DLAM=XLAM2-XLAM1 828 : PROF=FG1/(FG1-FG2) 829 : XLMBDA=XLAM1+PROF*DLAM 830 : ENDIF 831 : * 832 : ***** PRINT *,'NOUVELLE XLMBDA = ', XLMBDA 833 : 834 : IF(XLMBDA.GE.SLONT) THEN 835 : IF(ITER.EQ.ITEMAX-1) THEN 836 : LAST=1 837 : ELSE 838 : XLMBDA=SLONT 839 : ENDIF 840 : ENDIF 841 : * 842 : * si on trouve XLMBDA < 0 , on reinitialise 843 : * 844 : IF(XLMBDA.LT.0.D0) THEN 845 : IF(ITER.GE.2) THEN 846 : XLMBDA=(XLAM(ITER)+XLAM(1))/ITER 847 : ELSE 848 : XLMBDA=XLAM(1)/2.D0 849 : ENDIF 850 : ***** PRINT *,'XLMBDA REINITIALISEE = ', XLMBDA 851 : ENDIF 852 : * 853 : * SORTIE SI IDICH=1 ET XLMBDA CONVERGE 854 : * 855 : IF(IDICH.EQ.1.AND.ITER.EQ.ITEMAX) THEN 856 : IF(XLMBDA.NE.0.D0) THEN 857 : IF(ABS(XLMBDA-XLAM(ITER))/XLMBDA. 858 : & LT.1.D-3) GO TO 7999 859 : ENDIF 860 : ENDIF 861 : * 862 : GO TO 8000 863 : * 864 : * 2-EME BOUCLE SUR LES ELEMENTS 865 : * 866 : 7999 CONTINUE 867 : SLON=0.0D0 868 : FAI=0.0D0 869 : IAM=0 870 : DO 4005 IC=1,NBELEM 871 : 872 : if(ivers) then 873 : C ordre inverse 874 : JC= NBELEM+1-IC 875 : else 876 : C ordre normal 877 : JC=IC 878 : endif 879 : 880 : C ---- ON RECUPERE LES GRANDEURS GEOMETRIQUES ----------- 881 : 882 : IAM=IAM+1 883 : ALFA = DANG(IAM) 884 : DS1 = DACUR(IAM) 885 : 886 : do 12345 iptg=1,nbpgau 887 : 888 : if(ivers) then 889 : ig= nbpgau+1-iptg 890 : else 891 : ig = iptg 892 : endif 893 : 894 : C ---- Récupération des EFFX deja présents ----------- 895 : 896 : IF (IPCHC1.EQ.0) THEN 897 : SINI = 0.D0 898 : ELSE 899 : mptval = ivasi0 900 : MELVAL = IVAL(ipeffx) 901 : SINI =velche(min(ig,velche(/1)), 902 : & min(JC,velche(/2))) 903 : ENDIF 904 : 905 : C ---- Récupération des caractéristiques matérielles et géométriques ---- 906 : 907 : melval =ivamat 908 : ea = velche(min(ig,velche(/1)), 909 : & min(JC,velche(/2))) 910 : 911 : melval =ivacar 912 : sect1 = velche(min(ig,velche(/1)), 913 : & min(JC,velche(/2))) 914 : 915 : C --- Calcul des pertes de précontrainte ------------------- 916 : 917 : ICOMP = 0 917 : call precn1(PS1,ea,f1,f2,ganc,RMU0,FPRG,RH10, 918 : & SLON+DS1*(1+qsigau(iptg))/2,FAI,SINI, 919 : & SECT1,XLMBDA,SD,LAST,PSL,PSOUT,ICOMP) 920 : IF (ICOMP.EQ.1) THEN 920 : CALL ERREUR(768) 921 : goto 9990 922 : RETURN 923 : ENDIF 924 : 925 : C --- On range les résultats 926 : 927 : iret=1 928 : MPTVAL=IVASTR 929 : DO 1700 I=1,NSTRS 930 : MELVAL=IVAL(I) 931 : VELCHE(ig,JC)=PSOUT 932 : 1700 CONTINUE 933 : 934 : 12345 continue 935 : SLON=SLON+DS1 936 : FAI=FAI+ALFA 937 : C write(6,*) 'slon et fai ',slon,fai 938 : 939 : 4005 CONTINUE 940 : SEGSUP ALTRAV 941 : C---------------------- endif sur CERC ou ELEMENTS LINEAIRE 942 : END IF 943 : 944 : C 945 : 9990 CONTINUE 946 : 947 : SEGSUP WRK3 948 : SEGDES IMODEL 949 : IF(IERR.NE.0)THEN 950 : SEGSUP MCHAML 951 : ELSE 952 : SEGDES MCHAML 953 : ENDIF 954 : C 955 : segdes meleme 956 : c 957 : melval = ivacar 958 : segdes melval 959 : melval = ivamat 960 : segdes melval,mcham6,mchel6 961 : 961 : C CALL DTMVAL(IVACAR,1) 962 : 962 : if(IPCHC1.gt.0) call dtmval(ivasi0,1) 963 : C 964 : IF(IERR.NE.0)THEN 964 : CALL DTMVAL(IVASTR,3) 965 : ELSE 965 : CALL DTMVAL(IVASTR,1) 966 : ENDIF 967 : C 968 : IF(MOMATR.NE.0)THEN 969 : NOMID=MOMATR 970 : SEGSUP NOMID 971 : ENDIF 972 : IF(MOCARA.NE.0)THEN 973 : NOMID=MOCARA 974 : SEGSUP NOMID 975 : ENDIF 976 : IF(MOSTRS.NE.0)THEN 977 : NOMID=MOSTRS 978 : if(lsupco)SEGSUP NOMID 979 : ENDIF 980 : C 981 : SEGSUP INFO 982 : if(iret.eq.0) return 983 : C 984 : 500 CONTINUE 985 : c-------- Fin de la boucle sur les zones du MODELE TEMPORAIRE 986 : C 987 : C =========== rangement dans le MCHELM final MCHEL5 988 : if(ifomod.ne.0.and.ifomod.ne.1) then 989 : C les cables standards 990 : segact siezo 991 : C segact mchel5 992 : MCHELM = IPSTRS 993 : segact MCHELM 994 : C 995 : C boucle sur les zones du modele ou champ initial 996 : 997 : C 998 : ibc= 0 999 : do 3010 isous=1,mchel5.imache(/1) 1000 : sielc = iezon(isous) 1001 : segact sielc 1002 : C 1003 : mcham5= mchel5.ichaml(isous) 1004 : segact mcham5 1005 : melva5 =mcham5.ielval(1) 1006 : segact melva5*mod 1007 : C boucle sur les partitions provisoires de la sz 1008 : C 1009 : inel = 0 1010 : do 3020 ik=1,nbcz 1011 : ibc=ibc+1 1012 : mchaml=ichaml(ibc) 1013 : segact mchaml 1014 : melval=ielval(1) 1015 : segact melval 1016 : C 1017 : do iii=1,velche(/2) 1018 : inel = inel+1 1019 : iel=isens(1,inel) 1020 : if(isens(2,inel).eq.1) then 1021 : do ip=1,velche(/1) 1022 : melva5.velche(ip,iel)=velche(ip,iii) 1023 : enddo 1024 : else 1025 : do ip=1,velche(/1) 1026 : melva5.velche(3-ip,iel)=velche(ip,iii) 1027 : enddo 1028 : endif 1029 : enddo 1030 : 3020 continue 1031 : segsup sielc 1032 : segdes melva5,mcham5 1033 : 3010 continue 1033 : call DTCHAM(ipcar2) 1033 : if(ipchc2.ne.0) call DTCHAM(ipchc2) 1034 : segsup ipt5 1035 : else 1036 : C les cerc 1037 : icha1 = MCHEL5 1038 : MCHEL5 = MCHELM 1039 : MCHELM = icha1 1040 : endif 1041 : 333 format(i4,2E12.5) 1042 : C maintenant les destructions d objets temporaires 1042 : call DTCHAM(MCHELM) 1042 : C call DTMODL(ipmodt) 1043 : mmodel = ipmodt 1044 : segsup mmodel 1045 : C 1046 : segdes MCHEL5 1047 : IPSTRS =MCHEL5 1048 : iret = 1 1049 : return 1050 : END 1051 : 1052 : 1053 : 1054 : 1055 : 1056 : 1057 : 1058 : 1059 : 1060 : 1061 : 1062 :
© Cast3M 2003 - All rights reserved.
Disclaimer