1 : C FOFIS1 SOURCE CHAT 11/03/16 21:22:48 6902 2 : SUBROUTINE FOFIS1(IPMODL,IPCHE1,IPCHE2,IPCHE3, 3 : 1 IPCHE4,IPCHP1,IRET) 4 : * 5 : ************************************************************************ 6 : * 7 : * ENTREES : 8 : * _________ 9 : * 10 : * IPMODL = POINTEUR SUR UN MMODEL 11 : * IPCHE1 = POINTEUR SUR UN MCHAML DE CONTRAINTES 12 : * IPCHE2 = POINTEUR SUR UN MCHAML DE GRADIENT 13 : * IPCHE3 = POINTEUR SUR UN MCHAML DE GRADIENT DE FLEXION 14 : * IPCHE4 = POINTEUR SUR UN MCHAML DE CARACTERISTIQUES 15 : * 16 : * SORTIES : 17 : * __________ 18 : * 19 : * IPCHP1 = POINTEUER SUR UN CHPOINT DE FORCES NODALES 20 : * IRET = 1 OU 0 SUIVANT SUCCES OU PAS 21 : * 22 : ************************************************************************ 23 : IMPLICIT INTEGER(I-N) 24 : IMPLICIT REAL*8(A-H,O-Z) 25 : * 26 : -INC CCOPTIO 27 : -INC CCHAMP 28 : -INC SMCHAML 29 : -INC SMCHPOI 30 : -INC SMELEME 31 : -INC SMCOORD 32 : -INC SMMODEL 33 : -INC SMINTE 34 : * 35 : SEGMENT WRK1 36 : REAL*8 XFORC(LRE), XSTRS(NSTRS), XE(3,NBBB) 37 : ENDSEGMENT 38 : * 39 : SEGMENT WRK2 40 : REAL*8 SHPWRK(6,NBNO), GRAD(9) 41 : REAL*8 GRAF(9),BPRIM(NSTRS,LRE) 42 : ENDSEGMENT 43 : * 44 : SEGMENT WRK3 45 : REAL*8 WORK(LW) 46 : ENDSEGMENT 47 : * 48 : SEGMENT WRK4 49 : REAL*8 BPSS(3,3), XEL(3,NBBB), XFOLO(LRE) 50 : ENDSEGMENT 51 : * 52 : SEGMENT MPTVAL 53 : INTEGER IPOS(NS) ,NSOF(NS) 54 : INTEGER IVAL(NCOSOU) 55 : CHARACTER*16 TYVAL(NCOSOU) 56 : ENDSEGMENT 57 : * 58 : SEGMENT NOTYPE 59 : CHARACTER*16 TYPE(NBTYPE) 60 : ENDSEGMENT 61 : * 62 : PARAMETER ( NINF=3 ) 63 : INTEGER INFOS(NINF) 64 : CHARACTER*(NCONCH) CONM 65 : LOGICAL lsupfo,lsupgd,lsupgf,lsupco 66 : * 67 : IRET = 0 68 : IPCHP1 = 0 69 : * 70 : * Verification du sous-type et du lieu support du MCHAML de contrain 71 : * 72 : MCHELM=IPCHE1 73 : SEGACT,MCHELM 74 : IF(TITCHE.NE.'CONTRAINTES')THEN 75 : MOTERR(1:8)='CONTRAIN' 76 : MOTERR(9:16)=' ' 76 : CALL ERREUR(109) 77 : SEGDES,MCHELM 78 : RETURN 79 : ENDIF 80 : SEGDES,MCHELM 80 : CALL QUESUP (IPMODL,IPCHE1,5,0,ISUP1,IRET1) 81 : IF (ISUP1.GT.1) RETURN 82 : * 83 : * Verification du sous-type et du lieu support du MCHAML de gradient 84 : * 85 : MCHELM=IPCHE2 86 : SEGACT,MCHELM 87 : IF(TITCHE.NE.'GRADIENT')THEN 88 : MOTERR(1:8)='GRADIENT' 89 : MOTERR(9:16)=' ' 89 : CALL ERREUR(109) 90 : SEGDES,MCHELM 91 : RETURN 92 : ENDIF 93 : SEGDES,MCHELM 93 : CALL QUESUP (IPMODL,IPCHE2,5,0,ISUP2,IRET2) 94 : IF (ISUP2.GT.1) RETURN 95 : * 96 : * Verification du sous-tyoe et du lieu support du MCHAML 97 : * de gradient de flexion 98 : * 99 : IF (IPCHE3.NE.0) THEN 100 : MCHELM=IPCHE3 101 : SEGACT,MCHELM 102 : IF(TITCHE.NE.'GRADIENT DE FLEXION')THEN 103 : MOTERR(1:8)='GRAFLEXI' 104 : MOTERR(9:16)=' ' 104 : CALL ERREUR(109) 105 : SEGDES,MCHELM 106 : RETURN 107 : ENDIF 108 : SEGDES,MCHELM 108 : CALL QUESUP (IPMODL,IPCHE3,5,0,ISUP3,IRET3) 109 : IF (ISUP3.GT.1) RETURN 110 : ENDIF 111 : * 112 : * Verification du sous-type et du lieu support du MCHAML 113 : * de caracteristiques 114 : * 115 : IF (IPCHE4.NE.0) THEN 116 : MCHELM=IPCHE4 117 : SEGACT,MCHELM 118 : IF(TITCHE.NE.'CARACTERISTIQUES')THEN 119 : MOTERR(1:8)='CARACTER' 120 : MOTERR(9:16)=' ' 120 : CALL ERREUR(109) 121 : SEGDES,MCHELM 122 : RETURN 123 : ENDIF 124 : SEGDES,MCHELM 124 : CALL QUESUP (IPMODL,IPCHE4,5,0,ISUP4,IRET4) 125 : IF (ISUP4.GT.1) RETURN 126 : ENDIF 127 : C_______________________________________________________________________ 128 : C 129 : C ACTIVATION DU MODELE 130 : C_______________________________________________________________________ 131 : C 132 : MMODEL=IPMODL 133 : SEGACT MMODEL 134 : NSOUS=KMODEL(/1) 135 : C 136 : C INITIALISATION DU MCHELM DE FORCES 137 : C 138 : L1=6 139 : N1=NSOUS 140 : N3=6 141 : SEGINI MCHELM 142 : IPCHE5=MCHELM 143 : IFOCHE=IFOUR 144 : TITCHE='FORCES' 145 : C_______________________________________________________________________ 146 : C 147 : C BOUCLE SUR LES SOUS ZONES 148 : C_______________________________________________________________________ 149 : C 150 : DO 500 ISOUS=1,NSOUS 151 : C 152 : IVASTR=0 153 : NSTR=0 154 : IVAGRA=0 155 : NGRAD=0 156 : IVAGRF=0 157 : NGRAF=0 158 : IVACAR=0 159 : NCARR=0 160 : IVAFOR=0 161 : C 162 : C TRAITEMENT DU MODELE 163 : C 164 : IMODEL=KMODEL(ISOUS) 165 : SEGACT IMODEL 166 : CONM=CONMOD 167 : MELE=NEFMOD 168 : IPMAIL=IMAMOD 169 : C 170 : C ACTIVATION DU MELEME 171 : C 172 : MELEME=IPMAIL 173 : SEGACT MELEME 174 : NBNN=NUM(/1) 175 : NBELEM=NUM(/2) 176 : C 177 : C RECOPIE DU MCHELM 178 : C 179 : IMACHE(ISOUS)=IPMAIL 180 : C 181 : C CREATION DU TABLEAU INFOS 182 : C 182 : CALL IDENT(IPMAIL,CONM,IPCHE1,IPCHE2,INFOS,IRTD) 183 : IF (IRTD.EQ.0) GOTO 991 184 : C_______________________________________________________________________ 185 : C 186 : C INFORMATIONS SUR L'{L{MENT FINI 187 : C_______________________________________________________________________ 188 : C 188 : * CALL ELQUOI(MELE,0,3,IPINF,IMODEL) 189 : * IF (IERR.NE.0) GOTO 991 190 : * INFO=IPINF 191 : NBPGS= INFELE(4) 192 : NBPGAU = INFELE(6) 193 : 194 : * MINTE = INFELE(11) 195 : MINTE=infmod(5) 196 : IPMINT= MINTE 197 : MINTE1= INFMOD(8) 198 : NSTRS = INFELE(16) 199 : MFR = INFELE(13) 200 : LW = INFELE(7) 201 : NDDL = INFELE(15) 202 : LRE = INFELE(9) 203 : IPPORE=0 204 : IF(MFR.EQ.33) IPPORE=NBNN 205 : LVAL = (LRE*(LRE+1))/2 206 : NHRM = NIFOUR 207 : C 208 : SEGACT MINTE 209 : NBNO=SHPTOT(/2) 210 : C 211 : C REMPLIR LE TABLEAU DE L'INFORMATION DE MCHAML 212 : C 213 : INFCHE(ISOUS,1)=0 214 : INFCHE(ISOUS,2)=0 215 : INFCHE(ISOUS,3)=NIFOUR 216 : INFCHE(ISOUS,4)=0 217 : INFCHE(ISOUS,5)=0 218 : INFCHE(ISOUS,6)=1 219 : C_______________________________________________________________________ 220 : C 221 : C NOMS DE COMPOSANTES NECESSAIRES ( FORCES ) 222 : C_______________________________________________________________________ 223 : C 224 : if(lnomid(2).ne.0) then 225 : nomid = lnomid(2) 226 : segact nomid 227 : moforc=nomid 228 : nfor=lesobl(/2) 229 : nfac=0 230 : lsupfo=.false. 231 : else 231 : CALL IDFORC(MFR,IFOUR,MOFORC,NFOR,NFAC) 232 : lsupfo=.true. 233 : endif 234 : C 235 : C CREATION DU MCHAML 236 : C 237 : N2=NFOR 238 : SEGINI MCHAML 239 : ICHAML(ISOUS)=MCHAML 240 : NOMID=MOFORC 241 : SEGACT NOMID 242 : DO 110 ICOMP=1,NFOR 243 : NOMCHE(ICOMP)=LESOBL(ICOMP) 244 : TYPCHE(ICOMP)='REAL*8' 245 : 110 CONTINUE 246 : if(lsupfo)SEGSUP NOMID 247 : C_______________________________________________________________________ 248 : C 249 : C NOMS DE COMPOSANTES NECESSAIRES(CONTRAINTES,GRADIENT, 250 : C GRADIENT DE FLEXION ) 251 : C_______________________________________________________________________ 252 : C 253 : if(lnomid(4).ne.0) then 254 : nomid=lnomid(4) 255 : segact nomid 256 : mostrs=nomid 257 : nstr=lesobl(/2) 258 : nfac=lesfac(/2) 259 : lsupco=.false. 260 : else 261 : lsupco=.true. 261 : CALL IDCONT(IMODEL,IFOUR,MOSTRS,NSTR,NFAC) 262 : endif 263 : C 264 : if(lnomid(3).ne.0) then 265 : nomid=lnomid(3) 266 : segact nomid 267 : mograd=nomid 268 : ngrad=lesobl(/2) 269 : nfac=lesfac(/2) 270 : lsupgd=.false. 271 : else 272 : lsupgd=.true. 272 : CALL IDGRAD(MFR,IFOUR,MOGRAD,NGRAD,NFAC) 273 : endif 274 : C 275 : * write(6,*) ' lnomid() ' ,(lnomid(iou),iou=1,12) 276 : if(lnomid(11).ne.0) then 277 : nomid=lnomid(11) 278 : segact nomid 279 : mograf=nomid 280 : ngraf=lesobl(/2) 281 : nfac=lesfac(/2) 282 : lsupgf=.false. 283 : else 284 : lsupgf=.true. 284 : CALL IDGRAF(MFR,IFOUR,MOGRAF,NGRAF,NFAC) 285 : endif 286 : C 287 : C VERIFICATION DE LEUR PRESENCE 288 : C 289 : NBTYPE=1 290 : SEGINI NOTYPE 291 : MOTYPE=NOTYPE 292 : TYPE(1)='REAL*8' 292 : CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOSTRS,MOTYPE,1,INFOS,3,IVASTR) 293 : NOMID=MOSTRS 294 : if(lsupco)SEGSUP NOMID 295 : IF (IERR.NE.0)THEN 296 : SEGSUP NOTYPE 297 : GOTO 510 298 : ENDIF 299 : * 300 : IF (ISUP1.EQ.1) THEN 300 : CALL VALCHE(IVASTR,NSTR,IPMINT,IPPORE) 301 : ENDIF 302 : * 302 : CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOGRAD,MOTYPE,1,INFOS,3,IVAGRA) 303 : NOMID=MOGRAD 304 : * write(6,*) ' lsupgd 1',lsupgd 305 : if(lsupgd)SEGSUP NOMID 306 : IF (IERR.NE.0)THEN 307 : SEGSUP NOTYPE 308 : GOTO 510 309 : ENDIF 310 : * 311 : IF (ISUP2.EQ.1) THEN 311 : CALL VALCHE(IVAGRA,NGRAD,IPMINT,IPPORE) 312 : ENDIF 313 : * 314 : IF(NGRAF.NE.0)THEN 315 : IF(IPCHE3.NE.0)THEN 315 : CALL KOMCHA(IPCHE3,IPMAIL,CONM,MOGRAF,MOTYPE,1,INFOS,3,IVAGRF) 316 : NOMID=MOGRAF 317 : if(lsupgf)SEGSUP NOMID 318 : IF (IERR.NE.0)THEN 319 : SEGSUP NOTYPE 320 : GOTO 510 321 : ENDIF 322 : * 323 : IF (ISUP3.EQ.1) THEN 323 : CALL VALCHE(IVAGRF,NGRAF,IPMINT,IPPORE) 324 : ENDIF 325 : ELSE 326 : MOTERR(1:8)='GRAFLEXI' 327 : MOTERR(9:12)=NOMTP(MELE) 328 : MOTERR(13:20)='FOFISS' 328 : CALL ERREUR(145) 329 : GO TO 510 330 : ENDIF 331 : ENDIF 332 : SEGSUP NOTYPE 333 : C_____________________________________________________________________ 334 : 335 : * TRAITEMENT DES CHAMPS DE CARACTERISTIQUES * 336 : C____________________________________________________________________ 337 : C 338 : NBROBL=0 339 : NBRFAC=0 340 : MOCARA=0 341 : IVECT=0 342 : NOMID=0 343 : ** write(6,*) ' mfr ifour ipche4 ngraf ipche3 ' 344 : * $ ,mfr,ifour,ipche4, ngraf, ipche3 345 : * write(6,*) ' lsupgd 2',lsupgd 346 : * 347 : * EPAISSEUR DANS LE CAS MASSIF EN CONTRAINTES PLANES 348 : * 349 : IF((MFR.EQ.1.OR.MFR.EQ.33).AND.IFOUR.EQ.-2. 350 : + AND.IPCHE4.NE.0)THEN 351 : NBROBL=0 352 : NBRFAC=1 353 : SEGINI NOMID 354 : MOCARA=NOMID 355 : LESFAC(1)='DIM3' 356 : * 357 : NBTYPE=1 358 : SEGINI NOTYPE 359 : MOTYPE=NOTYPE 360 : TYPE(1)='REAL*8' 361 : * 362 : * EPAISSEUR ET EXCENTREMENT DANS LE CAS DES COQUES 363 : * 364 : ELSEIF (MFR.EQ.3.OR.MFR.EQ.5.OR.MFR.EQ.9) THEN 365 : NBROBL=1 366 : IF(MFR.EQ.3.AND.IFOUR.EQ.-2) THEN 367 : NBRFAC=2 368 : ELSE 369 : NBRFAC=1 370 : ENDIF 371 : SEGINI NOMID 372 : MOCARA=NOMID 373 : LESOBL(1)='EPAI' 374 : LESFAC(1)='EXCE' 375 : IF(MFR.EQ.3.AND.IFOUR.EQ.-2) LESFAC(2)='DIM3' 376 : * 377 : NBTYPE=1 378 : SEGINI NOTYPE 379 : MOTYPE=NOTYPE 380 : TYPE(1)='REAL*8' 381 : * 382 : * SECTION POUR LES BARRES 383 : * 384 : ELSE IF (MFR.EQ.27) THEN 385 : NBROBL=1 386 : SEGINI NOMID 387 : MOCARA=NOMID 388 : LESOBL(1)='SECT' 389 : * 390 : NBTYPE=1 391 : SEGINI NOTYPE 392 : MOTYPE=NOTYPE 393 : TYPE(1)='REAL*8' 394 : * 395 : * CARACTERISTIQUES POUR LES POUTRES 396 : * 397 : ELSE IF (MFR.EQ.7 ) THEN 398 : NBROBL=4 399 : NBRFAC=3 400 : SEGINI NOMID 401 : MOCARA=NOMID 402 : LESOBL(1)='TORS' 403 : LESOBL(2)='INRY' 404 : LESOBL(3)='INRZ' 405 : LESOBL(4)='SECT' 406 : LESFAC(1)='SECY' 407 : LESFAC(2)='SECZ' 408 : LESFAC(3)='VECT' 409 : IVECT=1 410 : * 411 : NBTYPE=7 412 : SEGINI NOTYPE 413 : MOTYPE=NOTYPE 414 : TYPE(1)='REAL*8' 415 : TYPE(2)='REAL*8' 416 : TYPE(3)='REAL*8' 417 : TYPE(4)='REAL*8' 418 : TYPE(5)='REAL*8' 419 : TYPE(6)='REAL*8' 420 : TYPE(7)='POINTEURPOINT ' 421 : * 422 : * CARACTERISTIQUES POUR LES TUYAUX 423 : * 424 : ELSE IF (MFR.EQ.13) THEN 425 : NBROBL=2 426 : NBRFAC=2 427 : SEGINI NOMID 428 : MOCARA=NOMID 429 : LESOBL(1)='EPAI' 430 : LESOBL(2)='RAYO' 431 : LESFAC(1)='RACO' 432 : LESFAC(2)='VECT' 433 : IVECT=1 434 : * 435 : NBTYPE=4 436 : SEGINI NOTYPE 437 : MOTYPE=NOTYPE 438 : TYPE(1)='REAL*8' 439 : TYPE(2)='REAL*8' 440 : TYPE(3)='REAL*8' 441 : TYPE(4)='POINTEURPOINT ' 442 : * 443 : * CARACTERISTIQUES POUR LES LINESPRING 444 : * 445 : ELSE IF (MFR.EQ.15) THEN 446 : NBROBL=5 447 : SEGINI NOMID 448 : MOCARA=NOMID 449 : LESOBL(1)='EPAI' 450 : LESOBL(2)='FISS' 451 : LESOBL(3)='VX ' 452 : LESOBL(4)='VY ' 453 : LESOBL(5)='VZ ' 454 : * 455 : NBTYPE=1 456 : SEGINI NOTYPE 457 : MOTYPE=NOTYPE 458 : TYPE(1)='REAL*8' 459 : * 460 : * CARACTERISTIQUES POUR LES TUYAUX FISSURES 461 : * 462 : ELSE IF (MFR.EQ.17) THEN 463 : NBROBL=9 464 : SEGINI NOMID 465 : MOCARA=NOMID 466 : LESOBL(1)='RAYO' 467 : LESOBL(2)='EPAI' 468 : LESOBL(3)='VX ' 469 : LESOBL(4)='VY ' 470 : LESOBL(5)='VZ ' 471 : LESOBL(6)='VXF ' 472 : LESOBL(7)='VYF ' 473 : LESOBL(8)='VZF ' 474 : LESOBL(9)='ANGL' 475 : * 476 : NBTYPE=1 477 : SEGINI NOTYPE 478 : MOTYPE=NOTYPE 479 : TYPE(1)='REAL*8' 480 : * 481 : * CARACTERISTIQUES DES ELEMENTS HOMOGENEISES 482 : * 483 : ELSE IF (MFR.EQ.37) THEN 484 : IF(IFOUR.EQ.1.OR.IFOUR.EQ.0) THEN 485 : NBROBL=4 486 : SEGINI NOMID 487 : MOCARA=NOMID 488 : LESOBL(1)='SCEL' 489 : LESOBL(2)='SFLU' 490 : LESOBL(3)='EPS ' 491 : LESOBL(4)='XINE' 492 : ELSE 493 : NBROBL=3 494 : SEGINI NOMID 495 : MOCARA=NOMID 496 : LESOBL(1)='SCEL' 497 : LESOBL(2)='SFLU' 498 : LESOBL(3)='EPS ' 499 : ENDIF 500 : * 501 : NBTYPE=1 502 : SEGINI NOTYPE 503 : MOTYPE=NOTYPE 504 : TYPE(1)='REAL*8' 505 : ENDIF 506 : 507 : * 508 : IF (MOCARA.NE.0) THEN 509 : IF (IPCHE4.NE.0) THEN 510 : * 510 : CALL KOMCHA(IPCHE4,IPMAIL,CONM,MOCARA,MOTYPE,1, 511 : 1 INFOS,3,IVACAR) 512 : SEGSUP NOTYPE 513 : IF (IERR.NE.0) GOTO 9990 514 : IF (IVECT.EQ.1) THEN 515 : MPTVAL=IVACAR 516 : IF (IVAL(NBROBL+NBRFAC).EQ.0) THEN 517 : * 518 : * MOT CLE VECT EN CAS DE CONVERSION 519 : * 520 : IVECT=2 521 : NOMID=MOCARA 522 : SEGACT NOMID 523 : NBRFAC=NBRFAC+2 524 : SEGADJ NOMID 525 : MOCARA=NOMID 526 : LESFAC(NBRFAC-2)='VX ' 527 : LESFAC(NBRFAC-1)='VY ' 528 : LESFAC(NBRFAC )='VZ ' 529 : * 530 : NBTYPE=1 531 : SEGINI NOTYPE 532 : MOTYPE=NOTYPE 533 : TYPE(1)='REAL*8' 534 : * 534 : CALL KOMCHA(IPCHE4,IPMAIL,CONM,MOCARA,MOTYPE,1, 535 : 1 INFOS,3,IVACAR) 536 : SEGSUP NOTYPE 537 : IF (IERR.NE.0) GOTO 510 538 : ENDIF 539 : ENDIF 540 : ELSE 541 : MOTERR(1:8)='CARACTER' 542 : MOTERR(9:12)=NOMTP(MELE) 543 : MOTERR(13:20)='FOFISS ' 543 : CALL ERREUR(145) 544 : SEGSUP NOMID 545 : NCARA=0 546 : NCARF=0 547 : MOCARA=0 548 : GOTO 510 549 : ENDIF 550 : NCARA=NBROBL 551 : NCARF=NBRFAC 552 : NCARR=NCARA+NCARF 553 : * 554 : IF (ISUP4.EQ.1) THEN 554 : CALL VALCHE(IVACAR,NCARR,IPMINT,IPPORE) 555 : IF(IERR.NE.0)THEN 556 : SEGSUP NOMID 557 : ISUP4=0 558 : GOTO 510 559 : ENDIF 560 : ENDIF 561 : * write(6,*) ' lsupgd 3 ' , lsupgd 562 : SEGSUP NOMID 563 : * write(6,*) ' lsupgd 4 ' , lsupgd , nomid 564 : ENDIF 565 : 566 : NCARA=NBROBL 567 : NCARF=NBRFAC 568 : NCARR=NCARA+NCARF 569 : C 570 : C RECHERCHE DES TAILLES DE MELVAL 571 : C 572 : N1EL=NBELEM 573 : N1PTEL=NBNN 574 : NBPTEL=N1PTEL 575 : NEL =N1EL 576 : C 577 : C CREATION DU MELVAL DE FORCES 578 : C 579 : NS=1 580 : NCOSOU=NFOR 581 : SEGINI MPTVAL 582 : IVAFOR=MPTVAL 583 : DO 100 ICOMP=1,NFOR 584 : N2PTEL=0 585 : N2EL=0 586 : SEGINI MELVAL 587 : IELVAL(ICOMP)=MELVAL 588 : IVAL(ICOMP)=MELVAL 589 : 100 CONTINUE 590 : C 591 : C======================================================================= 592 : C NUMERO DES ETIQUETTES : 593 : C ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT 594 : C DANS LA ZONE SPECIFIQUE A CHAQUE ELEMENT COMMENCANT PAR : 595 : C 5 CONTINUE 596 : C ELEMENT 5 ETIQUETTES 1005 2005 3005 4005 ... 597 : C 44 CONTINUE 598 : C ELEMENT 44 ETIQUETTES 1044 2044 3044 4044 ... 599 : C======================================================================= 600 : GOTO (99,99,99, 4,99, 4,99, 4,99, 4,99,99,99, 4, 4, 4, 4,99,99,99, 601 : 1 99,99, 4, 4, 4, 4,99,99,99,99,99,99,99,99,99,99,99,99,99,99, 602 : 2 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99, 603 : 3 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99, 604 : 4 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99),MELE 605 : C 606 : C GOTO (99,99,99, 4,99, 4,99, 4,99, 4,99,99,99, 4, 4, 4, 4,99,99,99, 607 : C 1 99,99, 4, 4, 4, 4,27,28,29,30,99,99,99,99,99,99,99,99,99,99, 608 : C 2 41,29,99,44,99,99,99,99,49,30,51,99,99,99,99,41,99,99,99,99, 609 : C 3 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99, 610 : C 4 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99),MELE 611 : C 612 : 99 CONTINUE 613 : MOTERR(1:4)=NOMTP(MELE) 614 : MOTERR(5:12)='FOFISS' 614 : CALL ERREUR(86) 615 : GOTO 510 616 : C 617 : C SECTEUR DE CALCUL POUR LES ELEMENTS MASSIFS 618 : C 619 : 4 CONTINUE 620 : DIM3=1.D0 621 : NBNO=NBNN 622 : NBBB=NBNN 623 : SEGINI WRK1,WRK2 624 : I195=0 625 : I259=0 626 : DO 3004 IB=1,NBELEM 627 : C 628 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB 629 : C 629 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 630 : C 631 : C MISE A 0 DES FORCES 632 : C 632 : CALL ZERO(XFORC,1,LRE) 633 : C 634 : C BOUCLE SUR LES POINTS DE GAUSS 635 : C 636 : ISDJC=0 637 : DO 5004 IGAU=1,NBPGAU 638 : C 639 : C RECUPERATION DE L'EPAISSEUR 640 : C 641 : IF (IFOUR.EQ.-2)THEN 642 : MPTVAL=IVACAR 643 : IF (IVACAR.NE.0) THEN 644 : MELVAL=IVAL(1) 645 : IF (MELVAL.NE.0) THEN 646 : IGMN=MIN(IGAU,VELCHE(/1)) 647 : IBMN=MIN(IB,VELCHE(/2)) 648 : DIM3=VELCHE(IGMN,IBMN) 649 : ELSE 650 : DIM3=1.D0 651 : ENDIF 652 : ENDIF 653 : ENDIF 654 : C 655 : C ***************** 656 : C ON CHERCHE LES GRADIENTS 657 : 658 : MPTVAL=IVAGRA 659 : DO 1104 ICOMP=1,9 660 : 661 : MELVAL=IVAL(ICOMP) 662 : IBMN=MIN(IB,VELCHE(/2)) 663 : IGMN=MIN(IGAU,VELCHE(/1)) 664 : GRAD(ICOMP)=VELCHE(IGMN,IBMN) 665 : 1104 CONTINUE 666 : C ***************** 666 : CALL BPRIMA(IGAU,MELE,MFR,NBNN,LRE,IFOUR,NSTRS,NHRM, 667 : 1 DIM3,XE,SHPTOT,SHPWRK,GRAD,BPRIM,DJAC) 668 : IF(DJAC.LT.0.) ISDJC=ISDJC+1 669 : IF(DJAC.EQ.0.) THEN 670 : INTERR(1) = IB 670 : CALL ERREUR(259) 671 : GOTO 9904 672 : ENDIF 673 : DJAC=ABS(DJAC)*POIGAU(IGAU) 674 : C 675 : C ON CHERCHE LES CONTRAINTES 676 : C 677 : MPTVAL=IVASTR 678 : DO 6004 ICOMP=1,NSTR 679 : MELVAL=IVAL(ICOMP) 680 : IBMN=MIN(IB,VELCHE(/2)) 681 : IGMN=MIN(IGAU,VELCHE(/1)) 682 : XSTRS(ICOMP)=VELCHE(IGMN,IBMN) 683 : 6004 CONTINUE 684 : C 685 : C CALCUL DE BPRIM*SIGMA 686 : C 686 : CALL BSIG(BPRIM,XSTRS,NSTRS,LRE,DJAC,XFORC) 687 : 5004 CONTINUE 688 : IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN 689 : INTERR(1) = IB 689 : CALL ERREUR(195) 690 : GOTO 9904 691 : ENDIF 692 : C 693 : C ON RANGE XFORC DANS MELVAL 694 : C 695 : IE=0 696 : MPTVAL=IVAFOR 697 : DO 7004 IGAU=1,NBNN 698 : DO 7004 ICOMP=1,NFOR 699 : IE=IE+1 700 : MELVAL=IVAL(ICOMP) 701 : IBMN=MIN(IB ,VELCHE(/2)) 702 : VELCHE(IGAU,IBMN)=XFORC(IE) 703 : 7004 CONTINUE 704 : 3004 CONTINUE 705 : 706 : 9904 CONTINUE 707 : SEGSUP WRK1,WRK2 708 : GOTO 510 709 : C ------------------------------------------------------------------ 710 : C ELEMENT COQ3 (NON) | | | | | | | | | | | | | | | | | | | 711 : C 712 : ********************************************************************* 713 : * ATTENTION LORS DU BRANCHEMENT IL FAUT PASSER AUX NOUVEAUX 714 : * CHAMELEMS COMME POUR LES ELEMENTS MASSIF 715 : ********************************************************************* 716 : * 27 CONTINUE 717 : * NBBB=NBNN 718 : * LW=151 719 : * SEGINI WRK1,WRK3 720 : * DO 3027 IB=1,NBELEM 721 : * IBMN1=MIN(IB,NEL1) 722 : * IBMN4=MIN(IB,NEL4) 723 : *C 724 : *C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB 725 : *C 725 : * CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 726 : *C 727 : *C ON REACTUALISE LA GEOMETRIE 728 : *C 729 : * IF(IRT4.EQ.0) GOTO 8027 730 : * DO 4027 IC=1,3 731 : * DO 4027 ID=1,3 732 : * XE(ID,IC)=XE(ID,IC)+MELVA3.VELCHA(IC,ID,IB) 733 : * 4027 CONTINUE 734 : * 8027 CONTINUE 735 : *C 736 : *C MISE A ZERO DES FORCES INTERNES 737 : *C 737 : * CALL ZERO(XFORC,1,LRE) 738 : *C 739 : *C ON CHERCHE LES EPAISSEURS ET ON MOYENNE 740 : * 741 : * EPAIST=XZER 742 : * DO 5027 IC=1,NBPTE4 743 : * EPAIST=EPAIST+MELVA4.VELCHA(IC,1,IBMN4) 744 : *5027 CONTINUE 745 : * EPAIST=EPAIST/NBPTE4 746 : * **************** 747 : * ON CHERCHE LES GRADIENTS ET GRAFLEXIS 748 : * 749 : * DO 1127 IC=1,9 750 : * GRAD(IC)=MELVA2.VELCHA(1,IC,IBMN1) 751 : *1127 CONTINUE 752 : * IF (IRT5.EQ.0) GO TO 1327 753 : * DO 1227 IC=1,9 754 : * GRAF(IC)=MELVA5.VELCHA(1,IC,IBMN1) 755 : *1227 CONTINUE 756 : *1327 CONTINUE 757 : * **************** 758 : * ON CHERCHE LES CONTRAINTES 759 : * 760 : * DO 7027 IC=1,NCOEL1 761 : * XSTRS(IC)=MELVA1.VELCHA(1,IC,IBMN1) 762 : * 7027 CONTINUE 763 : *C 764 : *C ON CALCULE B*SIGMA 765 : *C 765 : * CALL BSIGCO(EPAIST,XE,XSTRS,XFORC,WORK,WORK,WORK(82),WORK(88), 766 : * * WORK(92),WORK(119),WORK(128),WORK(134),WORK(143),WORK(143), 767 : * * WORK(146),WORK(149)) 768 : *C 769 : *C RANGEMENT DANS MELVAL 770 : *C 771 : * IE=0 772 : * DO 9027 IC=1,NBNN 773 : * DO 9027 ID=1,6 774 : * IE=IE+1 775 : * VELCHA(IC,ID,IB)=XFORC(IE) 776 : * 9027 CONTINUE 777 : * 3027 CONTINUE 778 : * SEGSUP WRK1,WRK3 779 : * GOTO 510 780 : *C 781 : *C ELEMENT DKT (NON) 782 : *C 783 : ********************************************************************* 784 : * ATTENTION LORS DU BRANCHEMENT IL FAUT PASSER AUX NOUVEAUX 785 : * CHAMELEMS COMME POUR LES ELEMENTS MASSIF 786 : ********************************************************************* 787 : * 28 CONTINUE 788 : * NBNO=NBNN 789 : * NBBB=NBNN 790 : * SEGINI WRK1,WRK2,WRK3,WRK4 791 : * DO 3028 IB=1,NBELEM 792 : * IBMN1=MIN(IB,NEL1) 793 : * IBMN4=MIN(IB,NEL4) 794 : *C 795 : *C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB 796 : *C 796 : * CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 797 : *C 798 : *C ON REACTUALISE LA GEOMETRIE 799 : *C 800 : * IF(IRT4.EQ.0) GOTO 8028 801 : * DO 4028 IC=1,NBPTE3 802 : * DO 4028 ID=1,3 803 : * XE(ID,IC)=XE(ID,IC)+MELVA3.VELCHA(IC,ID,IB) 804 : * 4028 CONTINUE 805 : * 8028 CONTINUE 806 : *C 807 : *C MISE A ZERO DES FORCES INTERNES 808 : *C 808 : * CALL ZERO(XFORC,1,LRE) 809 : *C 809 : * CALL VPAST(XE,BPSS) 810 : *C BPSS STOCKE LA MATRICE DE PASSAGE 810 : * CALL VCORLC (XE,XEL,BPSS) 810 : * CALL TRPOSE(BPSS) 811 : *C 812 : *C ON CHERCHE LES EPAISSEURS ET ON MOYENNE 813 : *C 814 : * EPAIST=XZER 815 : * DO 5028 IC=1,NBPTE4 816 : * EPAIST=EPAIST+MELVA4.VELCHA(IC,1,IBMN4) 817 : * 5028 CONTINUE 818 : * EPAIST=EPAIST/NBPTE4 819 : *C 820 : *C BOUCLE SUR LES POINTS DE GAUSS 821 : *C 822 : * DO 6028 IGAU=1,NBPGAU 823 : 824 : * IGMN1=MIN(IGAU,NBPTE1) 825 : *C ******************* 826 : *C ON CHERCHE LES GRADIENTS ET GRAFLEXIS 827 : *C 828 : * DO 1028 IC=1,9 829 : * GRAD(IC)=MELVA2.VELCHA(IGMN1,IC,IBMN1) 830 : * 1028 CONTINUE 831 : * IF (IRT5.EQ.0) GO TO 1328 832 : * DO 1228 IC=1,9 833 : * GRAF(IC)=MELVA5.VELCHA(IGMN1,IC,IBMN1) 834 : * 1228 CONTINUE 835 : * 1328 CONTINUE 836 : *C ******************* 836 : * CALL BPRIMA(IGAU,MELE,MFR,NBNO,LRE,IFOUR,NSTRS,0, 837 : * 1 XEL,SHPTOT,SHPWRK,GRAD,BPRIM,DJAC) 838 : * DJAC=DJAC*POIGAU(IGAU) 839 : *C 840 : *C ON CHERCHE LES CONTRAINTES 841 : *C 842 : * DO 7028 IC=1,NCOEL1 843 : * XSTRS(IC)=MELVA1.VELCHA(IGMN1,IC,IBMN1) 844 : * 7028 CONTINUE 845 : *C 846 : *C ON CALCULE BPRIM*SIGMA 847 : *C 847 : * CALL BSIG(BPRIM,XSTRS,NSTRS,LRE,DJAC,XFORC) 848 : * 6028 CONTINUE 849 : *C 850 : *C TRAITEMENT DE XFORC ET RANGEMENT DANS MELVAL 851 : *C 852 : * EPA=EPAIST*EPAIST/6. 853 : * DO 1128 IC=1,3 854 : * IE=(IC-1)*6 855 : * XFORC(IE+1)=EPAIST*XFORC(IE+1) 856 : * XFORC(IE+2)=EPAIST*XFORC(IE+2) 857 : * XFORC(IE+3)= EPA*XFORC(IE+3) 858 : * XFORC(IE+4)= EPA*XFORC(IE+4) 859 : * XFORC(IE+5)= EPA*XFORC(IE+5) 860 : * 1128 CONTINUE 860 : * CALL MATVEC(XFORC,XFOLO,BPSS,6) 861 : * IE=0 862 : * DO 9028 IC=1,NBNN 863 : * DO 9028 ID=1,6 864 : * IE=IE+1 865 : * VELCHA(IC,ID,IB)=XFOLO(IE) 866 : * 9028 CONTINUE 867 : * 3028 CONTINUE 868 : * SEGSUP WRK1,WRK2,WRK3,WRK4 869 : * GOTO 510 870 : *C 871 : *C ELEMENT POUTRE (NON) 872 : *C 873 : ********************************************************************* 874 : * ATTENTION LORS DU BRANCHEMENT IL FAUT PASSER AUX NOUVEAUX 875 : * CHAMELEMS COMME POUR LES ELEMENTS MASSIF 876 : ********************************************************************* 877 : * 29 CONTINUE 878 : * NBBB=NBNN 879 : * SEGINI WRK1,WRK3 880 : * DO 3029 IB=1,NBELEM 881 : * IBMN1=MIN(IB,NEL1) 882 : * IBMN4=MIN(IB,NEL4) 883 : *C 884 : *C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENTIB 885 : *C 885 : * CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 886 : *C 887 : *C ON REACTUALISE LA GEOMETRIE 888 : *C 889 : * IF(IRT4.EQ.0) GO TO 8029 890 : * DO 4029 IC=1,NBPTE3 891 : * DO 4029 ID=1,IDIM 892 : * XE(ID,IC)=XE(ID,IC)+MELVA3.VELCHA(IC,ID,IB) 893 : *4029 CONTINUE 894 : *C 895 : *C IL FAUDRAIT AUSSI MODIFIER LE VECTEUR LOCAL DE LA POUTRE 896 : *C 897 : *8029 CONTINUE 898 : *C 899 : *C MISE A ZERO DES FORCES INTERNES 900 : *C 900 : * CALL ZERO(XFORC,1,LRE) 901 : *C 902 : *C ON CHERCHE LES CARACTERISTIQUES DE L ELEMENT IB 903 : *C 904 : * DO 6029 IC=1,ICARA 905 : * WORK(IC)=MELVA4.VELCHA(1,IC,IBMN4) 906 : *6029 CONTINUE 907 : *C 908 : *C CAS DES TUYAUX - ON CALCULE LES CARACTERISTIQUES DE LA POUTRE 909 : *C EQUIVALENTE (NON) 910 : *C 910 : * IF(MELE.EQ.42) CALL TUYCAR(WORK,KERRE,0) 911 : *C 912 : *C ON CHERCHE LES CONTRAINTES - ON LES MET DANS WORK 913 : *C 914 : * IE=9 915 : * DO 7029 ID=1,NBPTE1 916 : * DO 7029 IC=1,NCOEL1 917 : * IE=IE+1 918 : * WORK(IE)=MELVA1.VELCHA(ID,IC,IBMN1) 919 : *7029 CONTINUE 920 : *C 921 : *C ON CALCULE LES FORCES INTERNES 922 : *C 922 : * CALL POUBSG(XFORC,WORK,XE,WORK(10),WORK(22),KERRE) 923 : * IF(KERRE.EQ.0) GO TO 5029 924 : * INTERR(1)=IA 925 : * INTERR(2)=IB 926 : * SEGSUP WRK1,WRK3 926 : * CALL ERREUR(128) 927 : * GO TO 9990 928 : 929 : *5029 CONTINUE 930 : *C 931 : *C RANGEMENT DANS MELVAL 932 : *C 933 : * IE=0 934 : * DO 9029 ID=1,NBPTEL 935 : * DO 9029 IC=1,NCOELE 936 : * IE=IE+1 937 : * VELCHA(ID,IC,IB)=XFORC(IE) 938 : *9029 CONTINUE 939 : *029 CONTINUE 940 : * SEGSUP WRK1,WRK3 941 : * GO TO 510 942 : * 943 : * ELEMENTS LISP ET LISM (NON) 944 : ********************************************************************* 945 : * ATTENTION LORS DU BRANCHEMENT IL FAUT PASSER AUX NOUVEAUX 946 : * CHAMELEMS COMME POUR LES ELEMENTS MASSIF 947 : ********************************************************************* 948 : * 949 : * 30 CONTINUE 950 : * NBBB=NBNN 951 : * SEGINI WRK1,WRK3,WRK4 952 : * DO 3030 IB=1,NBELEM 953 : * IBMN1=MIN(IB,NEL1) 954 : * IBMN4=MIN(IB,NEL4) 955 : *C 956 : *C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB 957 : *C 957 : * CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 958 : *C 959 : *C ON REACTUALISE LA GEOMETRIE 960 : *C 961 : * IF(IRT4.EQ.1) THEN 962 : * DO 4030 IC=1,3 963 : * DO 4030 ID=1,3 964 : * XE(ID,IC)=XE(ID,IC)+MELVA3.VELCHA(IC,ID,IB) 965 : * 4030 CONTINUE 966 : * ENDIF 967 : *C 968 : *C MISE A ZERO DES FORCES INTERNES 969 : *C 969 : * CALL ZERO(XFORC,1,LRE) 970 : *C 971 : *C ON CHERCHE LES CONTRAINTES 972 : *C 973 : * IE=0 974 : * DO 7030 IC=1,NBPGAU 975 : * ICMN1=MIN(IC,NBPTE1) 976 : * DO 7030 ID=1,NCOEL1 977 : * IE=IE+1 978 : * WORK(IE)=MELVA1.VELCHA(ICMN1,ID,IBMN1) 979 : * 7030 CONTINUE 980 : *C 981 : *C ON CHERCHE LES CARACTERISTIQUES 982 : *C 983 : * DO 6030 IC=1,NBPGAU 984 : * ICMN4=MIN(IC,NBPTE4) 985 : * DO 6030 ID=1,NCOEL4 986 : * IE=IE+1 987 : * WORK(IE)=MELVA4.VELCHA(ICMN4,ID,IBMN4) 988 : * 6030 CONTINUE 989 : *C 990 : *C ON CALCULE B*SIGMA 991 : *C 992 : * ICNT=NBPGAU*NSTRS+1 992 : * CALL LISPBS(WORK(1),WORK(ICNT),POIGAU,SHPTOT, 993 : * 1 NBPGAU,NBNO,XE,XFOLO,BPSS,XFORC) 994 : *C 995 : *C RANGEMENT DANS MELVAL 996 : *C 997 : * IE=0 998 : * DO 9030 IC=1,NBNN 999 : * DO 9030 ID=1,6 1000 : * IE=IE+1 1001 : * VELCHA(IC,ID,IB)=XFORC(IE) 1002 : * 9030 CONTINUE 1003 : * 3030 CONTINUE 1004 : * SEGSUP WRK1,WRK3,WRK4 1005 : * GOTO 510 1006 : *C 1007 : *C ELEMENT COQ8 COQ6 (NON) 1008 : *C 1009 : ********************************************************************* 1010 : * ATTENTION LORS DU BRANCHEMENT IL FAUT PASSER AUX NOUVEAUX 1011 : * CHAMELEMS COMME POUR LES ELEMENTS MASSIF 1012 : ********************************************************************* 1013 : * 41 CONTINUE 1014 : * NBBB=NBNN 1015 : * SEGINI WRK1,WRK3 1016 : * SEGACT MINTE1 1017 : * NBPGA1=MINTE1.SHPTOT(/3) 1018 : * NBN1 =MINTE1.SHPTOT(/2) 1019 : *C 1020 : *C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS 1021 : *C 1022 : * I240=0 1023 : * I241=0 1024 : * DO 3041 IB=1,NBELEM 1025 : * IBMN1=MIN(IB,NEL1) 1026 : * IBMN4=MIN(IB,NEL4) 1027 : *C 1028 : *C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB 1029 : *C 1029 : * CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 1030 : *C 1031 : *C ON REACTUALISE LA GEOMETRIE 1032 : *C 1033 : * IF(IRT4.EQ.1) THEN 1034 : * DO 4041 IC=1,3 1035 : * DO 4041 ID=1,3 1036 : * XE(ID,IC)=XE(ID,IC)+MELVA3.VELCHA(IC,ID,IB) 1037 : * 4041 CONTINUE 1038 : * ENDIF 1039 : *C 1040 : *C MISE A ZERO DES FORCES INTERNES 1041 : *C 1041 : * CALL ZERO(XFORC,1,LRE) 1042 : *C 1043 : *C ON CHERCHE LES EPAISSEURS ET ON MOYENNE 1044 : *C 1045 : * EPAIST=XZER 1046 : * DO 5041 IC=1,NBPTE4 1047 : * EPAIST=EPAIST+MELVA4.VELCHA(IC,1,IBMN4) 1048 : * 5041 CONTINUE 1049 : * EPAIST=EPAIST/DBLE(NBPTE4) 1049 : * CALL ZERO(XFORC,1,LRE) 1050 : *C 1051 : *C ON CHERCHE LES CONTRAINTES 1052 : *C 1053 : * IE=1 1054 : * DO 7041 IC=1,NBPGAU 1055 : * DO 7041 ID=1,NSTRS 1056 : * WORK(IE)=MELVA1.VELCHA(IC,ID,IBMN1) 1057 : * IE=IE+1 1058 : * 7041 CONTINUE 1059 : *C 1060 : *C ON CALCULE B*SIGMA 1061 : *C 1061 : * CALL COQ8BS(XE,NBNN,NBPGAU,LRE,NSTRS,EPAIST,DZEGAU,POIGAU, 1062 : * * SHPTOT,MINTE1.SHPTOT,WORK(1),XFORC,IRRT) 1063 : * IF(IRRT.EQ.0) I241=IB 1064 : * IF(IRRT.EQ.-1) I240=IB 1065 : *C 1066 : *C RANGEMENT DANS MELVAL 1067 : *C 1068 : * IE=0 1069 : * DO 9041 IC=1,NBNN 1070 : * DO 9041 ID=1,6 1071 : * IE=IE+1 1072 : * VELCHA(IC,ID,IB)=XFORC(IE) 1073 : * 9041 CONTINUE 1074 : * 3041 CONTINUE 1075 : * SEGSUP WRK1,WRK3 1076 : * SEGDES MINTE1 1077 : * IF(I241.NE.0) INTERR(1)=I241 1077 : * IF(I241.NE.0) CALL ERREUR(241) 1078 : * IF(I240.NE.0) INTERR(1)=I240 1078 : * IF(I240.NE.0) CALL ERREUR(240) 1079 : * IF(I241.NE.0.OR.I240.NE.0)GO TO 9990 1080 : * GOTO 510 1081 : *C 1082 : *C ELEMENT COQ2 (NON) 1083 : *C 1084 : ********************************************************************* 1085 : * ATTENTION LORS DU BRANCHEMENT IL FAUT PASSER AUX NOUVEAUX 1086 : * CHAMELEMS COMME POUR LES ELEMENTS MASSIF 1087 : ********************************************************************* 1088 : * 44 CONTINUE 1089 : * DIM3=1.D0 1090 : * NBNO=NBNN 1091 : * NBBB=NBNN 1092 : * SEGINI WRK1,WRK2 1093 : * I255=0 1094 : * I256=0 1095 : * DO 3044 IB=1,NBELEM 1096 : * IBMN1=MIN(IB,NEL1) 1097 : * IBMN4=MIN(IB,NEL4) 1098 : *C 1099 : *C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB 1100 : *C 1100 : * CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 1101 : *C 1102 : *C ON REACTUALISE LA GEOMETRIE 1103 : *C 1104 : * IF(IRT4.EQ.1) THEN 1105 : * DO 4044 IC=1,NBPTE3 1106 : * DO 4044 ID=1,IDIM 1107 : * XE(ID,IC)=XE(ID,IC)+MELVA3.VELCHA(IC,ID,IB) 1108 : * 4044 CONTINUE 1109 : * ENDIF 1110 : *C 1111 : *C MISE A ZERO DES FORCES INTERNES 1112 : *C 1112 : * CALL ZERO(XFORC,1,LRE) 1113 : *C 1114 : *C ON CHERCHE L EPAISSEUR DE L ELEMENT IB 1115 : *C 1116 : * EPAIST=MELVA4.VELCHA(1,1,IBMN4) 1117 : * EPA=EPAIST*EPAIST/6.D0 1118 : * 1119 : *C 1120 : *C BOUCLE SUR LES POINTS DE GAUSS 1121 : *C 1122 : * DO 6044 IGAU=1,NBPGAU 1123 : * IGMN1=MIN(IGAU,NBPTE1) 1124 : * MPTVAL=IVACAR 1125 : * MELVAL=IVAL(2) 1126 : * IF (MELVAL.NE.0) THEN 1127 : * IGMN=MIN(IGAU ,VELCHE(/1)) 1128 : * IBMN=MIN(IB ,VELCHE(/2)) 1129 : * EXCEN =VELCHE(IGMN,IBMN) 1130 : * ELSE 1131 : * EXCEN=0.D0 1132 : * ENDIF 1133 : * IF(IFOUR.EQ.-2) THEN 1134 : * MELVAL=IVAL(3) 1135 : * IF (MELVAL.NE.0) THEN 1136 : * IGMN=MIN(IGAU ,VELCHE(/1)) 1137 : * IBMN=MIN(IB ,VELCHE(/2)) 1138 : * DIM3=VELCHE(IGMN,IBMN) 1139 : * ELSE 1140 : * DIM3=1.D0 1141 : * ENDIF 1142 : * ENDIF 1142 : * CALL BCOQ2(BGENE,NSTRS,DJAC,IGAU,IFOUR,XE,NHRM,QSIGAU,POIGAU, 1143 : * . EXCEN,DIM3,IRRT,XDPGE,YDPGE) 1144 : * IF(IRRT.EQ.1) I255=IB 1145 : * IF(IRRT.EQ.2) I256=IB 1146 : *C 1147 : *C ON CHERCHE LES CONTRAINTES - ON LES MET DANS XSTRS 1148 : *C 1149 : * DO 7044 IC=1,NCOEL1 1150 : * XSTRS(IC)=MELVA1.VELCHA(IGMN1,IC,IBMN1) 1151 : * 7044 CONTINUE 1152 : * NCO1 = NCOEL1/2 1153 : * DO 8044 IC=1,NCO1 1154 : * XSTRS(IC )=XSTRS(IC )*EPAIST 1155 : * XSTRS(IC+NCO1)=XSTRS(IC+NCO1)*EPA 1156 : * 8044 CONTINUE 1157 : *C 1158 : *C ON CALCULE B*SIGMA 1159 : *C 1159 : * CALL BSIG(BGENE,XSTRS,NSTRS,LRE,DJAC,XFORC) 1160 : * 6044 CONTINUE 1161 : *C 1162 : *C TRAITEMENT DE XFORC ET RANGEMENT DANS MELVAL 1163 : *C 1164 : * IF(IFOUR.GT.0) THEN 1165 : * DO 9044 IC=1,2 1166 : * IE=(IC-1)*4 1167 : * VELCHA(IC,1,IB)= XFORC(IE+1) 1168 : * VELCHA(IC,2,IB)= XFORC(IE+2) 1169 : * VELCHA(IC,3,IB)= XFORC(IE+3) 1170 : * VELCHA(IC,4,IB)= XFORC(IE+4) 1171 : * 9044 CONTINUE 1172 : * ELSE IF(IFOUR.LE.0) THEN 1173 : * DO 9944 IC=1,2 1174 : * IE=(IC-1)*3 1175 : * VELCHA(IC,1,IB)= XFORC(IE+1) 1176 : * VELCHA(IC,2,IB)= XFORC(IE+2) 1177 : * VELCHA(IC,3,IB)= XFORC(IE+3) 1178 : * 9944 CONTINUE 1179 : * ENDIF 1180 : * 3044 CONTINUE 1181 : * SEGSUP WRK1,WRK2 1182 : * IF(I255.NE.0) THEN 1183 : * INTERR(1)=I255 1183 : * CALL ERREUR(255) 1184 : * ENDIF 1185 : * IF(I256.NE.0) THEN 1186 : * INTERR(1)=I256 1186 : * CALL ERREUR(256) 1187 : * ENDIF 1188 : * IF(I255.NE.0.OR.I256.NE.0)GO TO 9990 1189 : * GOTO 510 1190 : *C 1191 : *C ELEMENT COQ4 (NON) 1192 : *C 1193 : ********************************************************************* 1194 : * ATTENTION LORS DU BRANCHEMENT IL FAUT PASSER AUX NOUVEAUX 1195 : * CHAMELEMS COMME POUR LES ELEMENTS MASSIF 1196 : ********************************************************************* 1197 : * 49 CONTINUE 1198 : * IG1=0 1199 : * NBNO=NBNN 1200 : * NBBB=NBNN 1201 : * SEGINI WRK1,WRK2,WRK4 1202 : * DO 3049 IB=1,NBELEM 1203 : * IBMN1=MIN(IB,NEL1) 1204 : * IBMN4=MIN(IB,NEL4) 1205 : *C 1206 : *C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB 1207 : *C 1207 : * CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 1208 : *C 1209 : *C ON REACTUALISE LA GEOMETRIE 1210 : *C 1211 : * IF(IRT4.EQ.1) THEN 1212 : * DO 4049 IC=1,NBPTE3 1213 : * DO 4049 ID=1,IDIM 1214 : * XE(ID,IC)=XE(ID,IC)+MELVA3.VELCHA(IC,ID,IB) 1215 : * 4049 CONTINUE 1216 : * ENDIF 1217 : *C 1218 : *C MISE A ZERO DES FORCES INTERNES 1219 : *C 1219 : * CALL ZERO(XFORC,1,LRE) 1220 : *C 1221 : *C RIFERIMENTO LOCALE 1222 : *C 1222 : * CALL CQ4LOC(XE,XEL,BPSS,IERT,0) 1222 : * CALL TRPOSE(BPSS) 1223 : *C 1224 : *C ON CHERCHE L EPAISSEUR DE L ELEMENT IB 1225 : *C 1226 : * EPAIST=MELVA4.VELCHA(1,1,IBMN4) 1227 : *C 1228 : *C BOUCLE SUR LES POINTS DE GAUSS 1229 : *C 1230 : * DO 6049 IGAU=1,NBPGAU 1231 : * IGMN1=MIN(IGAU,NBPTE1) 1231 : * CALL BCOQ4(IGAU,XEL,SHPTOT,SHPWRK,BGENE,DJAC,IERT,0) 1232 : * IF (IERT.NE.0) IG1=IB 1233 : *C 1234 : *C ON CHERCHE LES CONTRAINTES - ON LES MET DANS WORK 1235 : *C 1236 : * DO 7049 IC=1,NCOEL1 1237 : * XSTRS(IC)=MELVA1.VELCHA(IGMN1,IC,IBMN1) 1238 : * 7049 CONTINUE 1239 : *C 1240 : *C ON CALCULE B*SIGMA 1241 : *C 1242 : * DJAC=DJAC*POIGAU(IGAU) 1242 : * CALL BSIG(BGENE,XSTRS,NSTRS,LRE,DJAC,XFORC) 1243 : * 6049 CONTINUE 1244 : *C 1245 : *C TRAITEMENT DE XFORC ET RANGEMENT DANS MELVAL 1246 : *C 1247 : * EPA=EPAIST*EPAIST/6.D0 1248 : * DO 8049 IC=1,4 1249 : * IE=(IC-1)*6 1250 : * XFORC(IE+1)=EPAIST*XFORC(IE+1) 1251 : * XFORC(IE+2)=EPAIST*XFORC(IE+2) 1252 : * XFORC(IE+3)=EPAIST*XFORC(IE+3) 1253 : * XFORC(IE+4)= EPA*XFORC(IE+4) 1254 : * XFORC(IE+5)= EPA*XFORC(IE+5) 1255 : * XFORC(IE+6)= EPA*XFORC(IE+6) 1256 : * 8049 CONTINUE 1256 : * CALL MATVEC(XFORC,XFOLO,BPSS,8) 1257 : * IE=0 1258 : * DO 9049 IC=1,4 1259 : * DO 9049 ID=1,6 1260 : * IE=IE+1 1261 : * VELCHA(IC,ID,IB)=XFOLO(IE) 1262 : * 9049 CONTINUE 1263 : * 3049 CONTINUE 1264 : * SEGSUP WRK1,WRK2,WRK4 1265 : * IF(IG1.NE.0) THEN 1266 : * INTERR(1)=IG1 1266 : * CALL ERREUR (321) 1267 : * GO TO 9990 1268 : * ENDIF 1269 : * GOTO 510 1270 : *C 1271 : *C ELEMENT COF3 (NON) 1272 : *C 1273 : ********************************************************************* 1274 : * ATTENTION LORS DU BRANCHEMENT IL FAUT PASSER AUX NOUVEAUX 1275 : * CHAMELEMS COMME POUR LES ELEMENTS MASSIF 1276 : ********************************************************************* 1277 : * 51 CONTINUE 1278 : * NBNO=NBNN 1279 : * NBBB=NBNN 1280 : * SEGINI WRK1,WRK2 1281 : * DO 3051 IB=1,NBELEM 1282 : * IBMN1=MIN(IB,NEL1) 1283 : * IBMN4=MIN(IB,NEL4) 1284 : *C 1285 : *C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB 1286 : *C 1286 : * CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 1287 : *C 1288 : *C ON REACTUALISE LA GEOMETRIE 1289 : *C 1290 : * IF(IRT4.EQ.1) THEN 1291 : * DO 4051 IC=1,NBPTE3 1292 : * DO 4051 ID=1,IDIM 1293 : * XE(ID,IC)=XE(ID,IC)+MELVA3.VELCHA(IC,ID,IB) 1294 : * 4051 CONTINUE 1295 : * ENDIF 1296 : *C 1297 : *C MISE A ZERO DES FORCES INTERNES 1298 : *C 1298 : * CALL ZERO(XFORC,1,LRE) 1299 : *C 1300 : *C ON CHERCHE L EPAISSEUR DE L ELEMENT IB 1301 : *C 1302 : * EPAIST=MELVA4.VELCHA(1,1,IBMN4) 1303 : *C 1304 : *C BOUCLE SUR LES POINTS DE GAUSS 1305 : *C 1306 : * DO 6051 IGAU=1,NBPGAU 1307 : * IGMN1=MIN(IGAU,NBPTE1) 1307 : * CALL BCOF3(BGENE,DJAC,IGAU,IFOUR,XE,NHRM,QSIGAU,POIGAU,IRRT) 1308 : *C 1309 : *C ON CHERCHE LES CONTRAINTES - ON LES MET DANS WORK 1310 : *C 1311 : * DO 7051 IC=1,NCOEL1 1312 : * XSTRS(IC)=MELVA1.VELCHA(IGMN1,IC,IBMN1) 1313 : * 7051 CONTINUE 1314 : *C 1315 : *C ON CALCULE B*SIGMA 1316 : *C 1316 : * CALL BSIG(BGENE,XSTRS,NSTRS,LRE,DJAC,XFORC) 1317 : * 6051 CONTINUE 1318 : *C 1319 : *C TRAITEMENT DE XFORC ET RANGEMENT DANS MELVAL 1320 : *C 1321 : * EPA=EPAIST*EPAIST/6.D0 1322 : * DO 9051 IC=1,2 1323 : * IE=(IC-1)*4 1324 : * VELCHA(IC,1,IB)=EPAIST*XFORC(IE+1) 1325 : * VELCHA(IC,2,IB)=EPAIST*XFORC(IE+2) 1326 : * VELCHA(IC,3,IB)=EPAIST*XFORC(IE+3) 1327 : * VELCHA(IC,4,IB)= EPA*XFORC(IE+4) 1328 : * 9051 CONTINUE 1329 : * 3051 CONTINUE 1330 : * SEGSUP WRK1,WRK2 1331 : * GOTO 510 1332 : C | | | | | | | | | | | | | | 1333 : C --------------------------------------------------------------- 1334 : C_______________________________________________________________________ 1335 : C 1336 : C DESACTIVATION DES SEGMENTS PROPRES A LA ZONE GEOMETRIQUE ISOUS 1337 : C_______________________________________________________________________ 1338 : C 1339 : 510 CONTINUE 1340 : C 1341 : IF (ISUP1.EQ.1) THEN 1341 : CALL DTMVAL(IVASTR,3) 1342 : ELSE 1342 : CALL DTMVAL(IVASTR,1) 1343 : ENDIF 1344 : * 1345 : IF (ISUP2.EQ.1) THEN 1345 : CALL DTMVAL(IVAGRA,3) 1346 : ELSE 1346 : CALL DTMVAL(IVAGRA,1) 1347 : ENDIF 1348 : * 1349 : IF (ISUP3.EQ.1) THEN 1349 : CALL DTMVAL(IVAGRF,3) 1350 : ELSE 1350 : CALL DTMVAL(IVAGRF,1) 1351 : ENDIF 1352 : * 1353 : IF (ISUP4.EQ.1) THEN 1353 : CALL DTMVAL(IVACAR,3) 1354 : ELSE 1354 : CALL DTMVAL(IVACAR,1) 1355 : ENDIF 1356 : * 1357 : IF (IERR.NE.0) THEN 1357 : CALL DTMVAL(IVAFOR,3) 1358 : SEGSUP MCHAML 1359 : ELSE 1359 : CALL DTMVAL(IVAFOR,1) 1360 : SEGDES MCHAML 1361 : ENDIF 1362 : 1363 : SEGDES,MINTE 1364 : 991 CONTINUE 1365 : SEGDES MELEME,IMODEL 1366 : * 1367 : IF (IERR.NE.0) GOTO 9990 1368 : * 1369 : 500 CONTINUE 1370 : C_______________________________________________________________________ 1371 : C 1372 : C TRANSFORMATION DU CHAMELEM EN CHPOINT 1373 : C_______________________________________________________________________ 1374 : C 1375 : IRET = 1 1375 : CALL CHAMPO(IPCHE5,0,IPCHP1,IRET) 1376 : C ATTRIBUTION D'UNE NATURE DISCRETE 1376 : CALL DTCHAM(IPCHE5) 1377 : IF (IRET.EQ.1) THEN 1378 : MCHPOI = IPCHP1 1379 : SEGACT MCHPOI 1380 : NAT = MAX ( JATTRI(/1) , 1 ) 1381 : NSOUPO = IPCHP(/1) 1382 : SEGADJ MCHPOI 1383 : JATTRI(1) = 2 1384 : SEGDES MCHPOI 1385 : ENDIF 1386 : C 1387 : SEGDES MMODEL 1388 : RETURN 1389 : * 1390 : * ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR 1391 : * 1392 : 9990 CONTINUE 1393 : IRET=0 1394 : SEGDES MMODEL 1395 : SEGSUP MCHELM 1396 : 1397 : RETURN 1398 : END 1399 : 1400 : 1401 :
© Cast3M 2003 - All rights reserved.
Disclaimer