1 : C EPSIX SOURCE FANDEUR 13/01/29 21:15:33 7683 2 : subroutine EPSIX (IMODEL,IREPS2,IVADEP,IVAEPS, 3 : & UZDPG,RYDPG,RXDPG,IIPDPG,IRETER) 4 : c 5 : C PROCEDURE UTILISEE DANS LE CAS D'ELEMENTS XFEM 6 : c POUR LE CALCUL DE la deformation 7 : C 8 : C 9 : C********************************************************* 10 : C PARTIE DECLARATIVE 11 : C********************************************************* 12 : 13 : C 14 : IMPLICIT REAL*8(A-H,O-Z) 15 : C 16 : PARAMETER (NDDLMAX=30,NBNIMAX=10) 17 : C 18 : PARAMETER (NBENRMAX=5) 19 : DIMENSION MLRE(NBENRMAX+1) 20 : C 21 : -INC CCOPTIO 22 : -INC SMCOORD 23 : -INC SMMODEL 24 : -INC SMCHAML 25 : -INC SMINTE 26 : -INC SMELEME 27 : -INC SMLREEL 28 : C 29 : POINTEUR MCHEX1.MCHELM,MINT1.MINTE,MINT2.MINTE 30 : C 31 : C Segment (type LISTENTI) contenant les informations sur un element 32 : SEGMENT INFO 33 : INTEGER INFELL(JG) 34 : ENDSEGMENT 35 : c 36 : SEGMENT WRK1 37 : REAL*8 XE(3,NBBB) 38 : REAL*8 XDDL(LRE),XSTRS(LHOOK) 39 : ENDSEGMENT 40 : c 41 : SEGMENT WRK2 42 : REAL*8 SHPWRK(6,NBNO),BGENE(LHOOK,LRE) 43 : c REAL*8 LV7WRK(NBENRMA2,2,6,NBNO) 44 : REAL*8 LV7WRK(NBENRMA2,2,6,NBBB) 45 : ENDSEGMENT 46 : C 47 : SEGMENT MPTVAL 48 : INTEGER IPOS(NS),NSOF(NS) 49 : INTEGER IVAL(NCOSOU) 50 : CHARACTER*16 TYVAL(NCOSOU) 51 : ENDSEGMENT 52 : C 53 : SEGMENT MRACC 54 : INTEGER TLREEL(NBENRMA2,NBI) 55 : ENDSEGMENT 56 : C 57 : SEGMENT MTRACE 58 : REAL*8 TRACE(NBPTEL) 59 : ENDSEGMENT 60 : DIMENSION UDPGE(3) 61 : LOGICAL BDPGE 62 : C 63 : C write (*,*) '############################' 64 : C write (*,*) '##### DEBUT DE EPSIX #####' 65 : C write (*,*) '############################' 66 : C 67 : C********************************************************* 68 : c Introduction du point autour duquel se fait le mouvement 69 : c de la section en defo plane generalisee 70 : C********************************************************* 71 : C En 1D : pas de rotation 72 : BDPGE=.FALSE. 73 : NDPGE=0 74 : XDPGE=0.D0 75 : YDPGE=0.D0 76 : IF (IFOUR.EQ.-3) THEN 77 : BDPGE=.TRUE. 78 : NDPGE=3 79 : UDPGE(1)=UZDPG 80 : UDPGE(2)=RYDPG 81 : UDPGE(3)=RXDPG 82 : SEGACT,MCOORD 83 : IREF=(IIPDPG-1)*(IDIM+1) 84 : XDPGE=XCOOR(IREF+1) 85 : YDPGE=XCOOR(IREF+2) 86 : ELSE IF (IDIM.EQ.1) THEN 87 : IF (IFOUR.EQ. 7 .OR. IFOUR.EQ. 8 .OR. IFOUR.EQ. 9 .OR. 88 : . IFOUR.EQ.10 .OR. IFOUR.EQ.14) THEN 89 : BDPGE=.TRUE. 90 : NDPGE=1 91 : UDPGE(1)=UZDPG 92 : ELSE IF (IFOUR.EQ.11) THEN 93 : BDPGE=.TRUE. 94 : NDPGE=2 95 : UDPGE(1)=UZDPG 96 : UDPGE(2)=RXDPG 97 : ENDIF 98 : ENDIF 99 : C 100 : C 101 : C********************************************************* 102 : c 103 : C RECUPERATION + ACTIVATIONS + VALEURS UTILES 104 : c 105 : C********************************************************* 106 : C SEGACT MMODEL,IMODEL deja activé dans epsi1 107 : c 108 : C++++ Activation au cas ou ++++++++++++++++++++++++++++++ 109 : SEGACT MCOORD 110 : 111 : C++++ Recup + Activation de la geometrie ++++++++++++++++ 112 : MELEME= IMAMOD 113 : c SEGACT MELEME deja activé dans epsi1 114 : 115 : 116 : C++++ RECUP DES INFOS EF ++++++++++++++++++++++++++++++++ 117 : c + OBTENUES PAR ELQUOI DANS RIGI1 PENDANT PHASE 1 118 : C segment INFO deja actif dans RIGI1 119 : c + rigi1 n appelle pas elquoi, c'est modeli qui l'a fait 120 : c mais du coup, on na pas de segment minte 121 : c (car depend de si pt de g pour rigi, pour sigma....) 122 : c c'est + simple de rappeler elquoi ici 123 : MELE = NEFMOD 123 : call elquoi(MELE,0,3,IPINF,IMODEL) 124 : INFO = IPINF 125 : c MELE = INFELL(1) 126 : c NBPGA2= INFELL(2) 127 : c NBPGAU= INFELL(3) 128 : c NBPGAU= INFELL(4) 129 : c ICARA = INFELL(5) 130 : NGAU1 = INFELL(6) 131 : c LW = INFELL(7) 132 : LRE = INFELL(9) 133 : LHOOK = INFELL(10) 134 : MINT1 = INFELL(11) 135 : segact,MINT1 136 : MINT2 = INFELL(12) 137 : if(MINT2.ne.0) segact,MINT2 138 : MFR = INFELL(13) 139 : IELE = INFELL(14) 140 : NDDL = INFELL(15) 141 : NSTRS = INFELL(16) 142 : c write(6,*)'-> EPSIX infell',(infell(iou),iou=1,16) 143 : 144 : c + AUTRES INFOS 145 : C nbre de noeuds par element 146 : NBNN1 = NUM(/1) 147 : C nbre d elements 148 : NBEL1 = NUM(/2) 149 : 150 : c REM: pour se passer du dimensionnement du nbre d'enrichissement dans 151 : c elquoi et le realiser localement , on pourrait ecrire: 152 : c LRE = NDDLMAX*NBNN1 153 : c NDDL= NDDLMAX 154 : 155 : C sous decoupage et points de Gauss de l element geometrique de base 156 : if(MELE.eq.263.or.mele.eq.264) then 157 : NGAU2 = MINT2.POIGAU(/1) 158 : endif 159 : C write(*,*) 'dim de MINT2=6,',(MINT2.SHPTOT(/2)),(MINT2.SHPTOT(/3)) 160 : C write(*,*) 'MINT2',(MINT2.QSIGAU(iou),iou=1,NGAU) 161 : c segdes,MINT2 162 : 163 : 164 : c nbre maxi de fonction de forme par noeud (fonction std comprise) 165 : c NBNI = NDDL/IDIM inutile! 166 : 167 : 168 : C++++ Recup des infos d enrichissement +++++++++++++++++++ 169 : c recup du MCHEX1 d'enrichissement 170 : NOBMO1 = IVAMOD(/1) 171 : if(NOBMO1.ne.0) then 172 : do iobmo1=1,NOBMO1 173 : if((TYMODE(iobmo1)).eq.'MCHAML') then 174 : MCHEX1 = IVAMOD(iobmo1) 175 : segact,MCHEX1 176 : if((MCHEX1.TITCHE).eq.'ENRICHIS') then 177 : MCHAM1 = MCHEX1.ICHAML(1) 178 : segact,MCHAM1 179 : segdes,MCHEX1 180 : goto 1000 181 : endif 182 : segdes,MCHEX1 183 : endif 184 : enddo 185 : write(*,*) 'Le modele est vide (absence d enrichissement)' 186 : * return 187 : else 188 : write(*,*) 'Il n y a pas de MCHEML enrichissement dans le Modele' 189 : * return 190 : endif 191 : 192 : 1000 continue 193 : c niveau d enrichissement(s) du modele (ddls std u exclus) 194 : c NBENR1= 0 si std, 1 si H seul, 2 si H+F1, 3 si H+F1+F2, etc... 195 : if(NOBMO1.ne.0) then 196 : NBENR1= MCHAM1.IELVAL(/1) 197 : else 198 : NBENR1 = 0 199 : endif 200 : c write(*,*) 'niveau d enrichissement(s) du modele',NBENR1 201 : c 202 : C 203 : C 204 : C********************************************************* 205 : C INITIALISATIONS... 206 : C********************************************************* 207 : IRETER = 0 208 : c 209 : c preparation des tables avec: 210 : 211 : if(NBENR1.ne.0) then 212 : do ienr=1,NBENR1 213 : c -le nombre d'inconnues de chaque sous-zone 214 : c determinee depuis le nombre de fonction de forme 215 : c ienr= 1: U+H(1+1=2), 2: U+H+F1(2+4=6), 3: U+H+F1+F2(6+4=10) 216 : nbniJ = 2 + ((ienr-1)*4) 217 : MLRE(1+ienr) = IDIM*NBNN1*nbniJ 218 : enddo 219 : endif 220 : C Tables + longues car 1er indice correspond au fontion de forme std 221 : MLRE(1) = IDIM*NBNN1*1 222 : 223 : if(NBENR1.lt.(NBENRMAX+1)) then 224 : do ienr=(NBENR1+1),(NBENRMAX) 225 : MLRE(1+ienr) = 0 226 : enddo 227 : endif 228 : c 229 : c ...DU SEGMENT WRK1 230 : NBENRMA2 = NBENRMAX 231 : NBBB = NBNN1 232 : SEGINI,WRK1 233 : 234 : c ...DU SEGMENT WRK2 235 : c NBNO = NBNI 236 : NBNO = LRE/IDIM 237 : SEGINI,WRK2 238 : C 239 : c ...DU SEGMENT MRACC 240 : NBENRMA2 = NBENRMAX 241 : NBI = NBNN1 242 : segini,MRACC 243 : C 244 : C du nombre d erreur sur le noms de composantes 245 : NBERR1=0 246 : 247 : 248 : 249 : C********************************************************* 250 : C 251 : C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> BOUCLE SUR LES ELEMENTS 252 : C 253 : DO 2000 J=1,NBEL1 254 : c write(*,*) '===================================' 255 : c write(*,*) '========= EF',J,' /NBEL1 =========' 256 : C 257 : C 258 : C********************************************************* 259 : C POUR CHAQUE ELEMENT, ... 260 : C********************************************************* 261 : C 262 : C++++ ON RECUPERE LES COORDONNEES DES NOEUDS DE L ELEMENT 262 : CALL DOXE(XCOOR,IDIM,NBNN1,NUM,J,XE) 263 : C 264 : c 265 : C++++ NBENRJ = niveau d enrichissement de l element ++++ 266 : C =0 si EF std =1 si U+H =2 si U+H+F1 =3 si U+H+F1+F2 267 : NBENRJ=0 268 : if(NBENR1.ne.0) then 269 : do IENR=1,NBENR1 270 : MELVA1 = MCHAM1.IELVAL(IENR) 271 : segact,MELVA1 272 : do I=1,NBNN1 273 : mlree1 = MELVA1.IELCHE(I,J) 274 : C on en profite pour remplir MRACC table de raccourcis pour cet element 275 : TLREEL(IENR,I) = mlree1 276 : if(mlree1.ne.0) then 277 : NBENRJ = max(NBENRJ,IENR) 278 : C et on active la listreel 279 : segact,mlree1 280 : endif 281 : enddo 282 : segdes,MELVA1 283 : enddo 284 : endif 285 : if(NBENRMA2.gt.NBENR1) then 286 : do IENR2=(NBENR1+1),NBENRMA2 287 : do I=1,NBNN1 288 : TLREEL(IENR2,I) = 0 289 : enddo 290 : enddo 291 : endif 292 : C 293 : c 294 : c++++ quelques indices pour dimensionner au plus juste 295 : c nbre total de ddl de l'élément considéré 296 : NLIGRD = MLRE(1+NBENRJ) 297 : NLIGRP = MLRE(1+NBENRJ) 298 : c nbre fonction de forme=((Ni_std+Ni_enrichi)*nbnoeud)=Ninconnues/idim 299 : NBNI = (MLRE(1+NBENRJ)) / IDIM 300 : 301 : C write(*,*) 'EF',J,' NBENRJ=',NBENRJ, 302 : C &'donc',NLIGRD,' ddls et ',NBNI,' fonctions de forme' 303 : c 304 : C 305 : C++++ ON CALCULE XDDL ++++ 306 : MPTVAL = IVADEP 307 : NCOSOU = IVAL(/1) 308 : C 309 : INITOT = 0 310 : C-->> BOUCLE SUR LES niveaux d'ENRICHISSEMENTS (0:U 1:A 2:BCDE1 3:BCDE2) 311 : DO IENR=0,NBENRJ 312 : *nbre de fonction(s) de ce niveau d'enrichissement (=1 si std ou H, =4 pour F1,2,...) 313 : if(IENR .le. 1) then 314 : NBNIENR = 1 315 : else 316 : NBNIENR = 4 317 : endif 318 : C---->> BOUCLE SUR LES fonctions de forme de ce type d'enrichissement 319 : DO INI=1,NBNIENR 320 : INITOT = INITOT + 1 321 : C------>> BOUCLE SUR LA DIMENSION 322 : DO 2220 KDIM=1,IDIM 323 : ICOMP = (INITOT-1)*IDIM + KDIM 324 : 325 : c --cas ou on n'a pas trouvé assez de composantes-- 326 : if(ICOMP.GT.NCOSOU) GOTO 2221 327 : 328 : MELVAL = IVAL(ICOMP) 329 : c --cas ou on a pas trouvé cette composante dans cette zone du 330 : c chpoint solution devenu mchaml -- 331 : if(MELVAL.eq.0)then 332 : c Avait on besoin de cette composante? 333 : c oui, si c'est une composante obligatoire 334 : if(IENR.eq.0) goto 2991 335 : c oui, si l'un des noeuds est enrichi 336 : do I=1,NBNN1 337 : if(TLREEL(IENR,I).ne.0) goto 2991 338 : enddo 339 : c non, si c'est facultatif et qu'on n'est pas enrichi -> on saute 340 : goto 2220 341 : c ->AVERTISSEMENT puis on saute 342 : 2991 NBERR1=NBERR1+1 343 : if(IIMPI.lt.1) goto 2220 344 : c write(IOIMP,*) 'PB OPERATEUR EPSI :' 345 : write(IOIMP,991) ICOMP,IENR,INI,KDIM 346 : 991 format(2X,'ABSENCE DANS LE CHPOINT DEPLACEMENT DE LA ',I3, 347 : $ 'ieme COMPOSANTE (enrichissement',I3, 348 : $ ', fonction',I3,', direction ',I3, 349 : $ ') NECESSAIRE POUR L UN DES NOEUDS SUIVANTS :') 350 : write(IOIMP,*)' noeuds :',(NUM(iou,J),iou=1,NBNN1) 351 : goto 2220 352 : endif 353 : 354 : C---------->> BOUCLE SUR LES NOEUDS 355 : DO I=1,NBNN1 356 : IQ = ((INITOT-1)*NBNN1*IDIM) + ((I-1)*IDIM) + KDIM 357 : XDDL(IQ) = VELCHE(I,J) 358 : ENDDO 359 : 360 : 2220 CONTINUE 361 : ENDDO 362 : ENDDO 363 : 364 : c --cas normal (toutes les composantes souhaitees etaient presentes)-- 365 : GOTO 2223 366 : 367 : c --cas ou on n'a pas trouvé assez de composantes-- 368 : 2221 CONTINUE 369 : if (IIMPI.ge.1) then 370 : WRITE(IOIMP,2222) J,NCOSOU,ICOMP 371 : 2222 FORMAT(2X,'ATTENTION : ELEMENT ',I6, 372 : & ' LE CHAMP DE DEPLACEMENT CONTIENT ',I3,' COMPOSANTES', 373 : & ' PAR NOEUD AU LIEU DE ',I3,' ATTENDUES') 374 : endif 375 : NDDL=NCOSOU*NBNN1 376 : NBENRJ=IENR 377 : 378 : 2223 CONTINUE 379 : c --cas ou on a une ou des erreurs-- 380 : IF (NBERR1.gt.0.and.J.eq.NBEL1) THEN 381 : write(IOIMP,*) 'OPERATEUR GRAD : ABSENCE DANS LE CHPOINT ', 382 : & 'DEPLACEMENT DE CERTAINES INCONNUES ATTENDUES PAR LE MODELE' 383 : ENDIF 384 : c 385 : c rem: il serait probablement interessant au niveau du tems cpu 386 : c d'utiliser moins de pts de Gauss lorsque l element est élastique 387 : c On pourrait par ex. utiliser MINT2 = infell(12) qui contient 388 : c le segment d'integration de l'EF std (QUA4 par ex.) 389 : * if((NBENRJ.eq.0).and.(MINT2.ne.0)) then 390 : * MINTE = MINT2 391 : * NBPGAU= NGAU2 392 : * else 393 : MINTE = MINT1 394 : NBPGAU= NGAU1 395 : * endif 396 : c 397 : c pour les def quadratiques 398 : ISDJC=0 399 : NBPTEL=NBPGAU 400 : IF (IREPS2.EQ.1) SEGINI MTRACE 401 : c 402 : C 403 : C********************************************************* 404 : C 405 : C>>>>>>>>>> BOUCLE SUR LES POINTS DE GAUSS 406 : C 407 : DO 2500 KGAU=1,NBPGAU 408 : C 409 : C********************************************************* 410 : C Initialisation à 0 411 : C********************************************************* 412 : 413 : c ZERO ne serait-il pas facultatif? 413 : CALL ZERO(SHPWRK,6,NBNO) 414 : XGAU = 0.D0 415 : YGAU = 0.D0 416 : ZGAU = 0.D0 417 : C 418 : i6zz = 3 419 : IF (IDIM.EQ.3) i6zz = 4 420 : C 421 : c do ienr7=1,NBENRMAX 422 : do ienr7=1,NBENRJ 423 : do inod7=1,NBNN1 424 : c do i6=1,6 425 : do i6=1,i6zz 426 : LV7WRK(ienr7,1,i6,inod7) = 0.D0 427 : LV7WRK(ienr7,2,i6,inod7) = 0.D0 428 : enddo 429 : enddo 430 : enddo 431 : 432 : 433 : c********************************************************* 434 : c Calcul des fonction de forme std dans repere local 435 : c********************************************************* 436 : 437 : ccccc BOUCLE SUR LES NOEUDS ccccccccccccccccccccccccccccc 438 : c (et donc sur les Ni std) 439 : DO 2510 I=1,NBNN1 440 : 441 : C++++ Calcul des Ni std 442 : c (rappel: 1:Ni 2:Ni,qsi 3:Ni,eta avec i=1,4) 443 : SHPWRK(1,I) = SHPTOT(1,I,KGAU) 444 : SHPWRK(2,I) = SHPTOT(2,I,KGAU) 445 : SHPWRK(3,I) = SHPTOT(3,I,KGAU) 446 : IF (IDIM.EQ.3) SHPWRK(4,I) = SHPTOT(4,I,KGAU) 447 : 448 : C++++ Calcul des coordonnees dans le repere global 449 : XGAU = XGAU + (SHPWRK(1,I)*XE(1,I)) 450 : YGAU = YGAU + (SHPWRK(1,I)*XE(2,I)) 451 : IF (IDIM.EQ.3) ZGAU = ZGAU + (SHPWRK(1,I)*XE(3,I)) 452 : 453 : 2510 CONTINUE 454 : ccccc fin de BOUCLE SUR LES NOEUDS ccccccccccccccccccccccc 455 : 456 : 457 : 458 : c********************************************************* 459 : c Passage des fonctions de forme std dans repere global 460 : c********************************************************* 461 : 462 : C++++ CALCUL DES Ni,x Ni,y (i=1,4) + CALCUL DE det(J) 462 : CALL JACOBI(XE,SHPWRK,IDIM,NBNN1,DJAC) 463 : c if(J.eq.1.and.KGAU.eq.1) 464 : c &write(*,*) 'Ni(i=1,4)=',(SHPWRK(1,iou),iou=1,NBNN1) 465 : 466 : c********************************************************* 467 : c Si on est pas du tout enrichi on peut sauter une grosse partie 468 : c********************************************************* 469 : if(NBENRJ.eq.0) goto 2999 470 : 471 : c********************************************************* 472 : c Calcul des level set + leurs derivees dans repere global 473 : c********************************************************* 474 : 475 : ccccc BOUCLE SUR LES enrichissements ccccccccccccccccccc 476 : do 2520 ienr=1,NBENRJ 477 : 478 : c MELVA1=MCHAM1.IELVAL(IENR) 479 : c segact,MELVA1 480 : 481 : ccccc BOUCLE SUR LES NOEUDS ccccccccccccccccccccccccccc 482 : DO 2521 I=1,NBNN1 483 : 484 : C++++ Le I eme noeud est-il ienr-enrichi? 485 : mlree1= TLREEL(IENR,I) 486 : if(mlree1.eq.0) goto 2521 487 : 488 : 489 : c Calcul du repere local de fissure(=PSI,PHI) 490 : c (rappel: 1,1:psi 1,2:phi 2,1 psi,x ...etc...) 491 : do 2522 inode=1,NBNN1 492 : c pour le H-enrichissement, on n a pas gardé PSI (inutile) 493 : if(ienr.ne.1) then 494 : c valeur de PSI au inode^ieme noeud 495 : xpsi1 = mlree1.PROG(inode) 496 : c qu on multiplie par la valeur de Ni^std au pt de G considéré 497 : LV7WRK(ienr,1,1,I)= LV7WRK(ienr,1,1,I) 498 : & + (SHPWRK(1,inode)*xpsi1) 499 : LV7WRK(ienr,1,2,I)= LV7WRK(ienr,1,2,I) 500 : & + (SHPWRK(2,inode)*xpsi1) 501 : LV7WRK(ienr,1,3,I)= LV7WRK(ienr,1,3,I) 502 : & + (SHPWRK(3,inode)*xpsi1) 503 : IF (IDIM.EQ.3) LV7WRK(ienr,1,4,I)= LV7WRK(ienr,1,4,I) 504 : & + (SHPWRK(4,inode)*xpsi1) 505 : c valeur de PHI au inode^ieme noeud 506 : xphi1 = mlree1.PROG(NBNN1+inode) 507 : else 508 : xphi1 = mlree1.PROG(inode) 509 : endif 510 : LV7WRK(ienr,2,1,I)= LV7WRK(ienr,2,1,I) 511 : & + (SHPWRK(1,inode)*xphi1) 512 : LV7WRK(ienr,2,2,I)= LV7WRK(ienr,2,2,I) 513 : & + (SHPWRK(2,inode)*xphi1) 514 : LV7WRK(ienr,2,3,I)= LV7WRK(ienr,2,3,I) 515 : & + (SHPWRK(3,inode)*xphi1) 516 : IF (IDIM.EQ.3) LV7WRK(ienr,2,4,I)= LV7WRK(ienr,2,4,I) 517 : & + (SHPWRK(4,inode)*xphi1) 518 : 2522 continue 519 : 520 : 2521 continue 521 : ccccc fin de BOUCLE SUR LES NOEUDS ccccccccccccccccccccccc 522 : 523 : 524 : 2520 CONTINUE 525 : ccccc fin de BOUCLE SUR LES enrichissements cccccccccccccccc 526 : 527 : c on a construit 528 : C LV7WRK(ienr, PSI/PHI, valeur/deriveeparqsi/pareta, iNOEUD) 529 : 530 : 531 : c********************************************************* 532 : c Ajout des fonctions de forme d enrichissement 533 : c + leurs derivees dans repere global 534 : c********************************************************* 534 : CALL SHAPX(XGAU,YGAU,ZGAU,MELE,LV7WRK,NBENRMAX,NBENRJ, 535 : &TLREEL,J,SHPWRK,IRET) 536 : 537 : 538 : c retour a la partie commune aux EF enrichi et non enrichi 539 : 2999 continue 540 : 541 : C********************************************************* 542 : C CALCUL DE B' 543 : C********************************************************* 544 : c ZERO ne serait-il pas facultatif? 544 : c call ZERO(BGENE,LHOOK,NLIGRP) 545 : KB=1 546 : C boucle sur tous les Ni 547 : DO 3001 II=1,NBNI 548 : 549 : BGENE(1,KB) = SHPWRK(2,II) 550 : BGENE(2,KB+1) = SHPWRK(3,II) 551 : BGENE(4,KB) = SHPWRK(3,II) 552 : BGENE(4,KB+1) = SHPWRK(2,II) 553 : 554 : IF(IDIM.EQ.3) THEN 555 : BGENE(3,KB+2)=SHPWRK(4,II) 556 : BGENE(5,KB)=SHPWRK(4,II) 557 : BGENE(5,KB+2)=SHPWRK(2,II) 558 : BGENE(6,KB+1)=SHPWRK(4,II) 559 : BGENE(6,KB+2)=SHPWRK(3,II) 560 : ENDIF 561 : 562 : KB = KB + IDIM 563 : 564 : 3001 CONTINUE 565 : C 566 : c if(J.eq.5.and.KGAU.eq.1) then 567 : c if(KGAU.eq.1) then 568 : c write(*,*) 'BGENE(1,..)=',(BGENE(1,iou),iou=1,2*NBNI) 569 : c write(*,*) 'BGENE(2,..)=',(BGENE(2,iou),iou=1,2*NBNI) 570 : c write(*,*) 'BGENE(6,..)=',(BGENE(6,iou),iou=1,2*NBNI) 571 : c endif 572 : c endif 573 : 574 : 575 : c 576 : 577 : C********************************************************* 578 : C CALCUL DE B.q' 579 : C********************************************************* 580 : 581 : C APPEL A LA PROCEDURE DE CALCUL 581 : CALL BST(BGENE,XDDL,(NBNI*IDIM),LHOOK,XSTRS) 582 : c 583 : c cas de la priâe en compte des termes quadratiques 584 : IF (IREPS2.EQ.1) 584 : & CALL BST2(SHPWRK,XDDL,XE,NBNI,IFOUR,XSTRS,TRACE,KGAU, 585 : & XDPGE,YDPGE,UDPGE,NIFOUR) 586 : 587 : C********************************************************* 588 : C ECRITURE DES DIFFERENTES COMPOSANTES DES DEFORMATIONS 589 : C********************************************************* 590 : MPTVAL = IVAEPS 591 : DO 7000 ICOMP=1,LHOOK 592 : MELVAL = IVAL(ICOMP) 593 : VELCHE(KGAU,J) = XSTRS(ICOMP) 594 : 7000 CONTINUE 595 : C if(KGAU.eq.1) then 596 : C write(*,*) J,KGAU,'EPSI(..)=',(XSTRS(iou),iou=1,LHOOK) 597 : C endif 598 : c 599 : c 600 : 2500 CONTINUE 601 : C FIN DE BOUCLE SUR LES POINTS DE GAUSS <<<<<<<<<<<<<< 602 : C 603 : 604 : * 605 : c quelques suppressions 606 : c (ici element non-incompressible=> pas besoin de MTRACE (cf epsi2) 607 : IF (IREPS2.EQ.1) THEN 608 : SEGSUP MTRACE 609 : ENDIF 610 : 611 : c 612 : c quelques desactivations 613 : do IENR=1,NBENR1 614 : do I=1,NBNN1 615 : mlree1 = TLREEL(IENR,I) 616 : if(mlree1.ne.0) segdes,mlree1 617 : enddo 618 : enddo 619 : c 620 : c 621 : c 622 : 2000 CONTINUE 623 : C FIN DE BOUCLE SUR LES ELEMENTS <<<<<<<<<<<<<<<<<<<<< 624 : c 625 : c 626 : 627 : C********************************************************* 628 : C SUPPRESSION ET DESACTIVATION DE SEGMENTS 629 : C********************************************************* 630 : C 631 : SEGSUP,WRK1,WRK2 632 : SEGSUP,MRACC 633 : 634 : segdes,MINT1 635 : if(MINT2.ne.0) segdes,MINT2 636 : c 637 : C 638 : RETURN 639 : END 640 : 641 : 642 : 643 :
© Cast3M 2003 - All rights reserved.
Disclaimer