1 : C KTANGA SOURCE CHAT 11/03/16 21:26:27 6902 2 : 3 : SUBROUTINE KTANGA(IPMOD0,IPCHE1,IPCHE2,IPCHE3,XPREC,DTPS,IKTSYM, 4 : & IPRIGI) 5 : 6 : *======================================================================= 7 : *= CALCUL DE LA MATRICE DE RIGIDITE TANGENTE = 8 : *======================================================================= 9 : *= Entrees : = 10 : *= --------- = 11 : *= IPMOD0 pointeur sur le mmodel = 12 : *= IPCHE1 pointeur sur le mchaml de contraintes = 13 : *= IPCHE2 pointeur sur le mchaml de variables internes = 14 : *= IPCHE3 pointeur sur le mchaml de caracteristiques = 15 : *= XPREC flottant precision = 16 : *= DTPS flottant pas de temps (modeles visco-plastiques) = 17 : *= IKTSYM =1 si matrice symetrique en sortie, =0 sinon = 18 : *======================================================================= 19 : *= Sortie : = 20 : *= -------- = 21 : *= IPRIGI pointeur sur matrice rigidite (=0 en cas d'erreur) = 22 : *======================================================================= 23 : *= Passage aux nouveaux chamelems par jm campenon le 05/91 = 24 : *= Mise a niveau FD/OF en 2009 = 25 : *======================================================================= 26 : 27 : IMPLICIT INTEGER(I-N) 28 : IMPLICIT REAL*8(A-H,O-Z) 29 : 30 : -INC CCOPTIO 31 : -INC CCHAMP 32 : -INC CCGEOME 33 : 34 : -INC SMCHAML 35 : -INC SMCOORD 36 : -INC SMELEME 37 : -INC SMINTE 38 : -INC SMLREEL 39 : -INC SMMODEL 40 : -INC SMRIGID 41 : 42 : INTEGER OOOVAL 43 : 44 : SEGMENT WRK1 45 : REAL*8 DDHOOK(NSTRS,NSTRS),DDHOMU(NSTRS,NSTRS), 46 : & REL(LRE,LRE),XE(3,NBBB) 47 : ENDSEGMENT 48 : * 49 : SEGMENT WRK2 50 : REAL*8 SHPWRK(6,NBNO),BGENE(NSTRS,LRE) 51 : ENDSEGMENT 52 : * 53 : SEGMENT WRK3 54 : REAL*8 WORK(LW) 55 : ENDSEGMENT 56 : * 57 : SEGMENT WRK4 58 : REAL*8 BPSS(3,3),XEL(3,NBBB) 59 : ENDSEGMENT 60 : * 61 : SEGMENT WRK5 62 : INTEGER NTRAC1,NTRAC2 63 : ENDSEGMENT 64 : 65 : * POUR LES MATERIAUX a "TROPIE" (PASSAGE DE LA MATRICE DE ROTATION) 66 : SEGMENT WTRAV 67 : REAL*8 TXR(IDIM,IDIM) 68 : ENDSEGMENT 69 : 70 : SEGMENT INFO 71 : INTEGER INFELL(JG) 72 : ENDSEGMENT 73 : 74 : SEGMENT NOTYPE 75 : CHARACTER*16 TYPE(NBTYPE) 76 : ENDSEGMENT 77 : 78 : SEGMENT MPTVAL 79 : INTEGER IPOS(NS),NSOF(NS) 80 : INTEGER IVAL(NCOSOU) 81 : CHARACTER*16 TYVAL(NCOSOU) 82 : ENDSEGMENT 83 : 84 : C- Nombre de points maximal pour stocker une courbe de traction 85 : PARAMETER (LTRAC=2*75) 86 : 87 : * INTTYP correspond au type de points d'integration utilise par KTAN 88 : PARAMETER ( INTTYP=3 ) 89 : 90 : DIMENSION TRAC(LTRAC) 91 : DIMENSION CRIGI(12),CMASS(12) 92 : DIMENSION A(4,60),BB(3,60) 93 : * Petit tableau des "couleurs" des relations de conformite 94 : DIMENSION LCOLOR(6) 95 : DATA LCOLOR / 1, 3, 6, 10, 16, 24 / 96 : 97 : CHARACTER*8 CMATE 98 : CHARACTER*(NCONCH) CONM 99 : PARAMETER ( NINF=3 ) 100 : INTEGER INFOS(NINF) 101 : LOGICAL lsupdp,lsupfo,lsupco,lsupva,lsupma, 102 : & BDPGE,ldpge,BPLAN,BMATE 103 : 104 : *======================================================================* 105 : *= 1 - INITIALISATIONS ET VERIFICATIONS =* 106 : *======================================================================* 107 : IPRIGI=0 108 : KERRE=0 109 : * Modele "deroule" (uniquement "MECANIQUE", "LIQUIDE" ou "POREUX") 109 : CALL PIMODL(IPMOD0,IPMODL) 110 : IF (IPMODL.EQ.0) RETURN 111 : * Verification du support du mchaml de CONTRAINTES 111 : CALL REDUAF(IPCHE1,IPMOD0,IPCH_Z,0,IRET,KERRE) 111 : IF (IRET.NE.1) CALL ERREUR(KERRE) 112 : IF (IERR.NE.0) GOTO 550 113 : IPCHE1=IPCH_Z 113 : CALL QUESUP(IPMODL,IPCHE1,INTTYP,0,ISUPCO,IRET) 114 : IF (ISUPCO.GT.1) GOTO 550 115 : * Verification du support du mchaml de VARIABLES INTERNES 115 : CALL REDUAF(IPCHE2,IPMOD0,IPCH_Z,0,IRET,KERRE) 115 : IF (IRET.NE.1) CALL ERREUR(KERRE) 116 : IF (IERR.NE.0) GOTO 550 117 : IPCHE2=IPCH_Z 117 : CALL QUESUP(IPMODL,IPCHE2,INTTYP,0,ISUPVA,IRET) 118 : IF (ISUPVA.GT.1) GOTO 550 119 : * Verification du support du mchaml de CARACTERISTIQUES 119 : CALL REDUAF(IPCHE3,IPMOD0,IPCH_Z,0,IRET,KERRE) 119 : IF (IRET.NE.1) CALL ERREUR(KERRE) 120 : IF (IERR.NE.0) GOTO 550 121 : IPCHE3=IPCH_Z 121 : CALL QUESUP(IPMODL,IPCHE3,INTTYP,0,ISUPMA,IRET) 122 : IF (ISUPMA.GT.1) GOTO 550 123 : * Activation du modele 124 : MMODEL=IPMODL 125 : SEGACT,MMODEL 126 : NSOUS=KMODEL(/1) 127 : * Initialisations de l'objet RIGIDITE "matrice tangente" 128 : NRIGEL=NSOUS 129 : SEGINI,MRIGID 130 : IPRIGI=MRIGID 131 : MTYMAT='RIGIDITE' 132 : ICHOLE=0 133 : IFORIG=IFOUR 134 : IMGEO1=0 135 : IMGEO2=0 136 : ISUPEQ=0 137 : NHRM=NIFOUR 138 : * Indicateur de mode de calcul en 2D plan 139 : BPLAN = IFOUR.EQ.-2 .OR. IFOUR.EQ.-1 .OR. IFOUR.EQ.-3 140 : * Initialisations dans le cas des deformations planes generalisees 141 : IF (IFOUR.EQ.-3) THEN 142 : NDPGE = 3 143 : BDPGE = .TRUE. 144 : ELSE IF (IFOUR.EQ.11) THEN 145 : NDPGE = 2 146 : BDPGE = .TRUE. 147 : ELSE IF (IFOUR.EQ. 7.OR.IFOUR.EQ. 8.OR.IFOUR.EQ. 9.OR. 148 : & IFOUR.EQ.10.OR.IFOUR.EQ.14) THEN 149 : NDPGE = 1 150 : BDPGE = .TRUE. 151 : ELSE 152 : NDPGE = 0 153 : BDPGE = .FALSE. 154 : ENDIF 155 : XDPGE = 0.D0 156 : YDPGE = 0.D0 157 : 158 : *======================================================================* 159 : *= 2 - BOUCLE SUR LES SOUS-ZONES DU MODELE (Fin = etiquette 500) =* 160 : *======================================================================* 161 : ISOU = 0 162 : * 163 : DO 500 ISOUS=1,NSOUS 164 : * 165 : IMODEL=KMODEL(ISOUS) 166 : SEGACT,IMODEL 167 : IPMOD1=IMODEL 168 : *----------------------------------------------------------------------- 169 : *- 2.1 - Intialisations et activations de segments 170 : *----------------------------------------------------------------------- 171 : MELE = NEFMOD 172 : IPMAIL = IMAMOD 173 : * 174 : IPINF = 0 175 : * Cas particulier des relations de conformites 176 : IF (MELE.EQ.22) GOTO 5001 177 : * Verifications sur la formulation 178 : CONM = CONMOD 179 : * NFOR = FORMOD(/2) 180 : * NMAT = MATMOD(/2) 180 : * CALL NOMATE(FORMOD,NFOR,MATMOD,NMAT,CMATE,MATE,MAPL) 181 : CMATE = CMATEE 182 : MATE = IMATEE 183 : MAPL = INATUU 184 : IF (CMATE.EQ.' ') THEN 185 : KERRE=251 185 : CALL ERREUR(KERRE) 186 : GOTO 551 187 : ENDIF 188 : BMATE = (CMATE.EQ.'UNIDIREC').OR.(CMATE.EQ.'ORTHOTRO').OR. 189 : & (CMATE.EQ.'ANISOTRO') 190 : * Information sur l'element fini 191 : IF (INFMOD(/1).LT.2+INTTYP) THEN 191 : CALL ELQUOI(MELE,0,INTTYP,IPINF,IPMOD1) 192 : IF (IERR.NE.0) THEN 193 : KERRE=-ABS(IERR) 194 : GOTO 551 195 : ENDIF 196 : INFO=IPINF 197 : NBGS=INFELL(4) 198 : C* ICARA=INFELL(5) 199 : NBPGAU=INFELL(6) 200 : LW =INFELL(7) 201 : IPORE=INFELL(8) 202 : LRE =INFELL(9) 203 : LHOOK=INFELL(10) 204 : MFR =INFELL(13) 205 : IELE =INFELL(14) 206 : NDDL =INFELL(15) 207 : C* NSTRS=INFELL(16) 208 : IPMINT=INFELL(11) 209 : IPMIN1=INFELL(12) 210 : SEGSUP,INFO 211 : ELSE 212 : NBGS =INFELE(4) 213 : C* ICARA=INFELE(5) 214 : NBPGAU=INFELE(6) 215 : LW =INFELE(7) 216 : IPORE=INFELE(8) 217 : LRE =INFELE(9) 218 : LHOOK=INFELE(10) 219 : MFR =INFELE(13) 220 : IELE =INFELE(14) 221 : NDDL =INFELE(15) 222 : C* NSTRS=INFELE(16) 223 : IPMINT=INFMOD(2+INTTYP) 224 : IPMIN1=INFMOD(8) 225 : ENDIF 226 : ldpge=BDPGE 227 : IF (MFR.EQ.35.OR.MFR.EQ.53) ldpge=.FALSE. 228 : * Activation du segment d'integration MINTE=IPMINT 229 : MINTE=IPMINT 230 : IF (MELE.NE.260) SEGACT,MINTE 231 : * 232 : IF (MFR.EQ.57.OR.MFR.EQ.59) THEN 233 : IPPORE = NBNNE(NUMGEO(MELE)) 234 : IF (IFOUR.EQ.1.OR.IFOUR.EQ.-3) THEN 235 : LHOOK=6 236 : ELSE 237 : LHOOK=4 238 : ENDIF 239 : ELSE IF (MFR.EQ.33) THEN 240 : IPPORE = NBNNE(NUMGEO(MELE)) 241 : ELSE 242 : IPPORE = 0 243 : ENDIF 244 : * Coordonnees du point support des deformations planes generalisees 245 : IF (ldpge) THEN 246 : IREF=(IPDPGE-1)*(IDIM+1) 247 : XDPGE=XCOOR(IREF+1) 248 : YDPGE=XCOOR(IREF+2) 249 : ENDIF 250 : *----------------------------------------------------------------------- 251 : *- 2.2 - Preparation des objets resultats DESCR et XMATRI 252 : *----------------------------------------------------------------------- 253 : * Si necessaire PARTITIONNEMENT du segment XMATRI 254 : 5001 CONTINUE 255 : LTRK=OOOVAL(1,4) 256 : IF (LTRK.EQ.0) LTRK=OOOVAL(1,1) 257 : IPT1=IPMAIL 258 : SEGACT,IPT1 259 : NBNN1 =IPT1.NUM(/1) 260 : NBELE1=IPT1.NUM(/2) 261 : IF (MELE.EQ.22) LRE=NBNN1 262 : * Traitements particuliers pour penalisation milieu poreux 263 : IDECAP = 0 264 : IF (MELE.GE.79.AND.MELE.LE.83) THEN 265 : IDECAP = 1 266 : LRE = LRE + 2*NBNN1 - IPORE 267 : ELSE IF (MELE.GE.108.AND.MELE.LE.110) THEN 268 : IDECAP=1 269 : LRE = LRE + (3*NBNN1 - IPORE)/2 - NBSOM(IELE) 270 : ELSE IF (MELE.GE.173.AND.MELE.LE.177) THEN 271 : IDECAP=2 272 : LRE = LRE + (2*NBNN1 - IPORE)*IDECAP 273 : ELSE IF (MELE.GE.178.AND.MELE.LE.182) THEN 274 : IDECAP=3 275 : LRE = LRE + (2*NBNN1 - IPORE)*IDECAP 276 : ENDIF 277 : * Ajout a la taille en mots de la matrice des infos du segment 278 : LSEG=LRE*LRE*NBELE1 + 16 279 : NBLPRT=(LSEG-1)/LTRK+1 280 : NBLMAX=(NBELE1-1)/NBLPRT+1 281 : NBLPRT=(NBELE1-1)/NBLMAX+1 282 : * write(ioimp,*) ' ktanga nblprt nblmax ',NBLPRT,NBLMAX,NBELE1 283 : MELEME=IPT1 284 : * Boucle (5000) de PARTITIONNEMENT du segment XMATRI 285 : DO 5000 IPRT = 1,NBLPRT 286 : ISOU=ISOU+1 287 : IF (ISOU.GT.IRIGEL(/2)) THEN 288 : NRIGEL=ISOU 289 : SEGADJ,MRIGID 290 : ENDIF 291 : IF (NBLPRT.GT.1) THEN 292 : JPRT=(IPRT-1)*NBLMAX 293 : SEGACT,IPT1 294 : NBSOUS=0 295 : NBREF=0 296 : NBNN=NBNN1 297 : NBELEM=MIN(NBLMAX,NBELE1-JPRT) 298 : * write(ioimp,*) ' creation segment ',nbnn,nbelem 299 : SEGINI,MELEME 300 : ITYPEL=IPT1.ITYPEL 301 : DO I=1,NBELEM 302 : IB=I+JPRT 303 : DO J=1,NBNN 304 : NUM(J,I)=IPT1.NUM(J,IB) 305 : ENDDO 306 : ICOLOR(I)=IPT1.ICOLOR(I) 307 : ENDDO 308 : ENDIF 309 : IPMAIL=MELEME 310 : * Fin du traitement particulier en cas de PARTITIONNEMENT du XMATRI 311 : * Quelques initialisations suite au partionnement 312 : IPDSCR = 0 313 : IPMADG = 0 314 : IPMATR = 0 315 : IRIGE7 = 0 316 : * 317 : NMATR = 0 318 : NMATF = 0 319 : IVAMAT = 0 320 : NCARA = 0 321 : NCARF = 0 322 : IVACAR = 0 323 : NVARI = 0 324 : NVARF = 0 325 : IVARI = 0 326 : IVACON = 0 327 : * Activation du MELEME support des rigidites 328 : MELEME=IPMAIL 329 : SEGACT,MELEME 330 : NBNN =NUM(/1) 331 : NBELEM=NUM(/2) 332 : * Cas particulier des relations de conformites 333 : IF (MELE.EQ.22) GOTO 22 334 : * Modification du MELEME pour les deformations planes generalisees 335 : IF (ldpge) THEN 336 : NBNA=NBNN 337 : NBNN=NBNA+1 338 : NBREF=0 339 : NBSOUS=0 340 : SEGINI,IPT2 341 : IPT2.ITYPEL=28 342 : DO I=1,NBELEM 343 : DO J=1,NBNA 344 : IPT2.NUM(J,I)=NUM(J,I) 345 : ENDDO 346 : IPT2.NUM(NBNN,I)=IPDPGE 347 : IPT2.ICOLOR(I)=ICOLOR(I) 348 : ENDDO 349 : SEGDES,IPT2 350 : IPMAGD=IPT2 351 : ENDIF 352 : * Recherche des noms d'inconnues primales et duales 353 : IF (LNOMID(1).NE.0) THEN 354 : lsupdp=.FALSE. 355 : NOMID=LNOMID(1) 356 : SEGACT,NOMID 357 : MODEPL=NOMID 358 : NDEPL=LESOBL(/2) 359 : ELSE 360 : lsupdp=.TRUE. 360 : CALL IDDEPL(MFR,IFOUR,MODEPL,NDEPL,ndum) 361 : NOMID=MODEPL 362 : SEGACT,NOMID 363 : ENDIF 364 : IF (LNOMID(2).NE.0) THEN 365 : lsupfo=.FALSE. 366 : NOMID=LNOMID(2) 367 : SEGACT,NOMID 368 : MOFORC=NOMID 369 : NFORC=LESOBL(/2) 370 : ELSE 371 : lsupfo=.TRUE. 371 : CALL IDFORC(MFR,IFOUR,MOFORC,NFORC,ndum) 372 : NOMID=MOFORC 373 : SEGACT,NOMID 374 : ENDIF 375 : IF (NDEPL.EQ.0.OR.NFORC.EQ.0.OR.NDEPL.NE.NFORC) THEN 376 : KERRE=5 377 : GOTO 515 378 : ENDIF 379 : * Initialisation du segment DESCR 380 : NLIGRP = LRE 381 : NLIGRD = LRE 382 : SEGINI,DESCR 383 : IPDSCR=DESCR 384 : * Remplissage du segment DESCRipteur 385 : NCOMP = NDEPL 386 : NBNNS = NBNN 387 : IF (MFR.EQ.33.OR.MFR.EQ.57.OR.MFR.EQ.59) THEN 388 : NCOMP = NDEPL-IDECAP 389 : ENDIF 390 : IF (ldpge) THEN 391 : NCOMP = NDEPL-NDPGE 392 : NBNNS = NBNN-1 393 : ENDIF 394 : IF (MFR.EQ.19.OR.MFR.EQ.21) NBNNS=NBNN/2 395 : IDDL=1 396 : * Cas du macro-element 397 : IF (MFR.EQ.61)THEN 398 : DO i=1,3 399 : NOELEP(i )=1 400 : NOELEP(i+3)=3 401 : ENDDO 402 : NOELEP(7)=2 403 : NOELEP(8)=2 404 : DO i=1,LRE 405 : NOELED(i)=NOELEP(i) 406 : ENDDO 407 : NOMID=MODEPL 408 : DO i=1,3 409 : LISINC(i )=LESOBL(i) 410 : LISINC(i+3)=LESOBL(i) 411 : ENDDO 412 : LISINC(7)=LESOBL(4) 413 : LISINC(8)=LESOBL(5) 414 : NOMID=MOFORC 415 : DO i=1,3 416 : LISDUA(i )=LESOBL(i) 417 : LISDUA(i+3)=LESOBL(i) 418 : ENDDO 419 : LISDUA(7)=LESOBL(4) 420 : LISDUA(8)=LESOBL(5) 421 : * Cas general 422 : ELSE 423 : * Erreur dans les dimensions de DESCR (mode de calcul incorrect) 424 : IF (NBNNS*NCOMP.GT.NLIGRD) THEN 425 : KERRE=717 426 : GOTO 515 427 : ENDIF 428 : NDUM=NBNNS 429 : IF (MELE.GE.108.AND.MELE.LE.110) THEN 430 : NFAC=(3*NBNN-IPORE)/2 431 : NDUM=MIN(NBNNS,NFAC) 432 : ENDIF 433 : DO INOEUD=1,NDUM 434 : DO ICOMP=1,NCOMP 435 : NOELEP(IDDL)=INOEUD 436 : NOELED(IDDL)=INOEUD 437 : NOMID=MODEPL 438 : LISINC(IDDL)=LESOBL(ICOMP) 439 : NOMID=MOFORC 440 : LISDUA(IDDL)=LESOBL(ICOMP) 441 : IDDL=IDDL+1 442 : ENDDO 443 : ENDDO 444 : ENDIF 445 : * Cas particulier des deformations planes generalisees 446 : IF (ldpge) THEN 447 : DO ICOMP=(NDPGE-1),0,-1 448 : NOELEP(IDDL)=NBNN 449 : NOELED(IDDL)=NBNN 450 : NOMID=MODEPL 451 : LISINC(IDDL)=LESOBL(NDEPL-ICOMP) 452 : NOMID=MOFORC 453 : LISDUA(IDDL)=LESOBL(NFORC-ICOMP) 454 : IDDL=IDDL+1 455 : ENDDO 456 : ENDIF 457 : * Cas particulier des milieux poreux (pression aux sommets en 1er) 458 : IF (MFR.EQ.33) THEN 459 : DO INOEUD=1,NBSOM(IELE) 460 : NOELEP(IDDL)=IBSOM(NSPOS(IELE)+INOEUD-1) 461 : NOELED(IDDL)=NOELEP(IDDL) 462 : NOMID=MODEPL 463 : LISINC(IDDL)=LESOBL(NDEPL) 464 : NOMID=MOFORC 465 : LISDUA(IDDL)=LESOBL(NDEPL) 466 : IDDL=IDDL+1 467 : ENDDO 468 : IF (MELE.GE.79.AND.MELE.LE.83) THEN 469 : DO 1105 INOEUD=1,NBNN 470 : DO i=1,NBSOM(IELE) 471 : IF (INOEUD.EQ.IBSOM(NSPOS(IELE)+i-1)) GOTO 1105 472 : ENDDO 473 : NOELEP(IDDL)=INOEUD 474 : NOELED(IDDL)=INOEUD 475 : NOMID=MODEPL 476 : LISINC(IDDL)=LESOBL(NDEPL) 477 : NOMID=MOFORC 478 : LISDUA(IDDL)=LESOBL(NDEPL) 479 : IDDL=IDDL+1 480 : 1105 CONTINUE 481 : ELSE IF (MELE.GE.108.AND.MELE.LE.110) THEN 482 : DO INOEUD=NFAC+1,NBNN 483 : NOELEP(IDDL)=INOEUD 484 : NOELED(IDDL)=INOEUD 485 : NOMID=MODEPL 486 : LISINC(IDDL)=LESOBL(NDEPL) 487 : NOMID=MOFORC 488 : LISDUA(IDDL)=LESOBL(NDEPL) 489 : IDDL=IDDL+1 490 : ENDDO 491 : DO 1110 INOEUD=1,NFAC 492 : DO i=1,NBSOM(IELE) 493 : IF(INOEUD.EQ.IBSOM(NSPOS(IELE)+i-1)) GOTO 1110 494 : ENDDO 495 : NOELEP(IDDL)=INOEUD 496 : NOELED(IDDL)=INOEUD 497 : NOMID=MODEPL 498 : LISINC(IDDL)=LESOBL(NDEPL) 499 : NOMID=MOFORC 500 : LISDUA(IDDL)=LESOBL(NDEPL) 501 : IDDL=IDDL+1 502 : 1110 CONTINUE 503 : ENDIF 504 : ELSE IF (MFR.EQ.57.OR.MFR.EQ.59) THEN 505 : IF (MELE.GE.173.AND.MELE.LE.182) THEN 506 : DO IPR=1,IDECAP 507 : NDECAP = NDEPL-IDECAP+IPR 508 : DO INOEUD=1,NBSOM(IELE) 509 : NOELEP(IDDL)=IBSOM(NSPOS(IELE)+INOEUD-1) 510 : NOELED(IDDL)=NOELEP(IDDL) 511 : NOMID=MODEPL 512 : LISINC(IDDL)=LESOBL(NDECAP) 513 : NOMID=MOFORC 514 : LISDUA(IDDL)=LESOBL(NDECAP) 515 : IDDL=IDDL+1 516 : ENDDO 517 : DO 1205 INOEUD=1,NBNN 518 : DO i=1,NBSOM(IELE) 519 : IF (INOEUD.EQ.IBSOM(NSPOS(IELE)+i-1)) GOTO 1205 520 : ENDDO 521 : NOELEP(IDDL)=INOEUD 522 : NOELED(IDDL)=INOEUD 523 : NOMID=MODEPL 524 : LISINC(IDDL)=LESOBL(NDECAP) 525 : NOMID=MOFORC 526 : LISDUA(IDDL)=LESOBL(NDECAP) 527 : IDDL=IDDL+1 528 : 1205 CONTINUE 529 : ENDDO 530 : ENDIF 531 : * Cas des elements raccord 532 : ELSE IF (MFR.EQ.19.OR.MFR.EQ.21) THEN 532 : CALL IDDEPL(MFR+1000,IFOUR,MODPL,NDEPL,ndum) 533 : NOMID=MODPL 534 : SEGACT,NOMID 534 : CALL IDFORC(MFR+1000,IFOUR,MOFRC,NFORC,ndum) 535 : NOMID=MOFRC 536 : SEGACT,NOMID 537 : DO INOEUD=NBNNS+1,NBNN 538 : DO ICOMP=1,NDEPL 539 : NOELEP(IDDL)=INOEUD 540 : NOELED(IDDL)=INOEUD 541 : NOMID=MODPL 542 : LISINC(IDDL)=LESOBL(ICOMP) 543 : NOMID=MOFRC 544 : LISDUA(IDDL)=LESOBL(ICOMP) 545 : IDDL=IDDL+1 546 : ENDDO 547 : ENDDO 548 : NOMID=MODPL 549 : SEGSUP,NOMID 550 : NOMID=MOFRC 551 : SEGSUP,NOMID 552 : ENDIF 553 : * Initialisation du segment XMATRI contenant les matrices elementaires 554 : * de la sous-zone (NBELEM = nombre d'elements dans la sous-zone =MELEME) 555 : NELRIG=NBELEM 556 : SEGINI,XMATRI 557 : IPMATR=XMATRI 558 : * Quelques donnes utiles pour le segment MRIGID 559 : IF (ldpge) THEN 560 : ** MELEME=IPMAIL <- MELEME segment actif et pointe tjs sur IPMAIL 561 : NBNN=NUM(/1) 562 : ELSE 563 : IPMAGD=IPMAIL 564 : ENDIF 565 : IF (MAPL.EQ.35.OR.MAPL.EQ.54.OR.MAPL.EQ.56.OR.MAPL.EQ.111) THEN 566 : IRIGE7=2 567 : ELSE IF (MFR.EQ.57.OR.MFR.EQ.59) THEN 568 : IRIGE7=2 569 : ELSE 570 : IRIGE7=0 571 : ENDIF 572 : * En cas de rendement IRIGE7=2 (cf. RIGI1.ESO) 573 : *----------------------------------------------------------------------- 574 : *- 2.3 - Analyse des champs par element fournis en entree 575 : *----------------------------------------------------------------------- 576 : * Creation du tableau infos (contraintes, variables internes) 576 : CALL IDENT(IPMAIL,CONM,IPCHE2,IPCHE1,INFOS,IRET) 577 : IF (IRET.EQ.0) THEN 578 : KERRE=-ABS(IERR) 579 : GOTO 515 580 : ENDIF 581 : * Recherche des noms de composantes du champ de CONTRAINTEs 582 : IF (LNOMID(4).NE.0) THEN 583 : lsupco=.false. 584 : NOMID=LNOMID(4) 585 : SEGACT,NOMID 586 : MOCONT=NOMID 587 : NSTRS=LESOBL(/2) 588 : C* NFAC=LESFAC(/2) 589 : ELSE 590 : lsupco=.true. 590 : CALL IDCONT(IPMOD1,IFOUR,MOCONT,NSTRS,NFAC) 591 : ENDIF 592 : * Type des composantes 593 : NBTYPE=1 594 : SEGINI,NOTYPE 595 : TYPE(1)='REAL*8' 596 : MOTYPE=NOTYPE 597 : * Verification de leur presence 597 : CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOCONT,MOTYPE,1,INFOS,3,IVACON) 598 : SEGSUP,NOTYPE 599 : NOMID=MOCONT 600 : IF (lsupco) SEGSUP,NOMID 601 : IF (IERR.NE.0) THEN 602 : KERRE=-ABS(IERR) 603 : GOTO 515 604 : ENDIF 605 : IF (ISUPCO.EQ.1) THEN 605 : CALL VALCHE(IVACON,NSTRS,IPMINT,IPPORE) 606 : IF (IERR.NE.0) THEN 607 : ISUPCO=0 608 : KERRE=-ABS(IERR) 609 : GOTO 515 610 : ENDIF 611 : ENDIF 612 : * Recherche des noms de composantes du champ des variables internes 613 : IF (LNOMID(10).NE.0) THEN 614 : lsupva=.false. 615 : NOMID=LNOMID(10) 616 : SEGACT,NOMID 617 : MOVARI=NOMID 618 : NVARI=LESOBL(/2) 619 : NVARF=LESFAC(/2) 620 : ELSE 621 : lsupva=.true. 621 : CALL IDVARI(MFR,IPMOD1,MOVARI,NVARI,NVARF) 622 : ENDIF 623 : IF (MOVARI.EQ.0) THEN 624 : KERRE=76 625 : MOTERR(1:4)='VARI' 626 : MOTERR(5:8)=NOMTP(MELE) 627 : GOTO 515 628 : ENDIF 629 : NVART=NVARI+NVARF 630 : * Type des composantes 631 : NBTYPE=1 632 : SEGINI,NOTYPE 633 : TYPE(1)='REAL*8' 634 : IF (CMATE.EQ.'SECTION') TYPE(1)='POINTEURMCHAML ' 635 : MOTYPE=NOTYPE 636 : * Verification de leur presence 636 : CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOVARI,MOTYPE,1,INFOS,3,IVARI) 637 : SEGSUP,NOTYPE 638 : NOMID=MOVARI 639 : IF (lsupva) SEGSUP,NOMID 640 : IF (IERR.NE.0) THEN 641 : KERRE=-ABS(IERR) 642 : GOTO 515 643 : ENDIF 644 : IF (ISUPVA.EQ.1) THEN 644 : CALL VALCHE(IVARI,NVART,IPMINT,IPPORE) 645 : IF (IERR.NE.0) THEN 646 : ISUPVA=0 647 : KERRE=-ABS(IERR) 648 : GOTO 515 649 : ENDIF 650 : ENDIF 651 : * Creation du tableau infos (variables internes, caracteristiques) 651 : CALL IDENT(IPMAIL,CONM,IPCHE2,IPCHE3,INFOS,IRET) 652 : IF (IRET.EQ.0) THEN 653 : KERRE=-ABS(IERR) 654 : GOTO 515 655 : ENDIF 656 : * Recuperation des noms de composantes de caracteristiques materielles 657 : * Sauf cas particulier MOTYPE = segment NBTYPE=1 et TYPE(1)='REAL*8' 658 : NBTYPE=1 659 : SEGINI,NOTYPE 660 : TYPE(1)='REAL*8' 661 : MOTYPE=NOTYPE 662 : NBROBL=0 663 : NBRFAC=0 664 : NOMID=0 665 : lsupma=.TRUE. 666 : * Element de barre et Acier Unidirirectionnel 667 : IF (MAPL.EQ.40.AND.MFR.EQ.27) THEN 668 : NBROBL=1 669 : SEGINI,NOMID 670 : LESOBL(1)='YOUN' 671 : ELSE IF (MFR.EQ.7.AND.CMATE.EQ.'SECTION') THEN 672 : NBROBL=2 673 : NBRFAC=1 674 : SEGINI,NOMID 675 : LESOBL(1)='MODS' 676 : LESOBL(2)='MATS' 677 : LESFAC(1)='MAHO' 678 : NBTYPE=3 679 : SEGADJ,NOTYPE 680 : TYPE(1)='POINTEURMMODEL ' 681 : TYPE(2)='POINTEURMCHAML ' 682 : TYPE(3)='POINTEURLISTREEL' 683 : * Cas POI1 -- MODAL -- MFR=26 ==> pas traite dans la suite 684 : ELSE IF (MFR.EQ.26) THEN 685 : NBROBL=3 686 : SEGINI,NOMID 687 : LESOBL(1)='FREQ' 688 : LESOBL(2)='MASS' 689 : LESOBL(3)='DEFO' 690 : NBTYPE=3 691 : SEGADJ,NOTYPE 692 : TYPE(1)='REAL*8' 693 : TYPE(2)='REAL*8' 694 : TYPE(3)='POINTEURCHPOINT' 695 : * Cas POI1 -- STATIQUE -- MFR=28 ==> pas traite dans la suite 696 : ELSE IF (MFR.EQ.28) THEN 697 : NBROBL=3 698 : SEGINI,NOMID 699 : LESOBL(1)='DEFO' 700 : LESOBL(2)='RIDE' 701 : LESOBL(3)='MADE' 702 : TYPE(1)='POINTEURCHPOINT' 703 : * Cas Orthotrope, Anisotrope et Unidirectionnel 704 : ELSE IF (BMATE) THEN 705 : * Materiau Unidirirectionnel 706 : C*? IF (FORMOD(/1).EQ.'MECANIQUE'.AND.CMATE.EQ.'UNIDIREC') THEN 707 : IF (CMATE.EQ.'UNIDIREC') THEN 708 : IF (MFR.EQ.1.AND.IDIM.EQ.3) THEN 709 : NBROBL=7 710 : SEGINI,NOMID 711 : LESOBL(1)='YOUN' 712 : LESOBL(2)='V1X ' 713 : LESOBL(3)='V1Y ' 714 : LESOBL(4)='V1Z ' 715 : LESOBL(5)='V2X ' 716 : LESOBL(6)='V2Y ' 717 : LESOBL(7)='V2Z ' 718 : ELSE 719 : NBROBL=3 720 : SEGINI,NOMID 721 : LESOBL(1)='YOUN' 722 : LESOBL(2)='V1X ' 723 : LESOBL(3)='V1Y ' 724 : ENDIF 725 : * Materiau orthotrope plastique 'ECROUIS_DECOU' 726 : ELSE IF (CMATE.EQ.'ORTHOTRO'.AND.MAPL.EQ.67) THEN 727 : NBROBL=6 728 : SEGINI,NOMID 729 : LESOBL(1)='YG1 ' 730 : LESOBL(2)='YG2 ' 731 : LESOBL(3)='NU12' 732 : LESOBL(4)='G12 ' 733 : LESOBL(5)='V1X ' 734 : LESOBL(6)='V1Y ' 735 : * Autres Materiaux orthotropes et anisotropes 736 : ELSE 737 : IF (LNOMID(6).NE.0) THEN 738 : lsupma=.FALSE. 739 : NOMID=LNOMID(6) 740 : SEGACT,NOMID 741 : NBROBL=LESOBL(/2) 742 : NBRFAC=LESFAC(/2) 743 : ELSE 743 : CALL IDMATR(MFR,IPMOD1,MOMATR,NBROBL,NBRFAC) 744 : ENDIF 745 : * Cas particulier : Mistral (10 composantes = listes de réels) 746 : IF (MAPL.EQ.94) THEN 747 : NBTYPE=NBROBL+NBRFAC 748 : SEGADJ,NOTYPE 749 : DO i=1,NBTYPE 750 : TYPE(i)='REAL*8' 751 : ENDDO 752 : NLDEB=NBROBL-9 753 : DO i=NLDEB,NBROBL 754 : TYPE(i)='POINTEURLISTREEL' 755 : ENDDO 756 : ENDIF 757 : ENDIF 758 : * Materiaux ISOTROPEs 759 : ELSE IF (CMATE.EQ.'ISOTROPE') THEN 760 : IF (MFR.EQ.35) THEN 761 : IF (MAPL.EQ.35) THEN 762 : NBROBL=4 763 : SEGINI,NOMID 764 : LESOBL(1)='KS ' 765 : LESOBL(2)='KN ' 766 : LESOBL(3)='PHI ' 767 : LESOBL(4)='MU ' 768 : ELSE 769 : NBROBL=2 770 : SEGINI,NOMID 771 : LESOBL(1)='KS ' 772 : LESOBL(2)='KN ' 773 : ENDIF 774 : * Element joint cisaillement 2D 775 : ELSE IF (MFR.EQ.53) THEN 776 : NBROBL=1 777 : SEGINI,NOMID 778 : LESOBL(1)='KS ' 779 : * Elements POREUX isotropes 780 : ELSE IF (FORMOD(1).EQ.'POREUX') THEN 781 : IF (MELE.GE.79.AND.MELE.LE.83) THEN 782 : NBROBL=4 783 : SEGINI,NOMID 784 : LESOBL(1)='YOUN' 785 : LESOBL(2)='NU ' 786 : LESOBL(3)='COB ' 787 : LESOBL(4)='MOB ' 788 : ELSE IF (MELE.GE.108.AND.MELE.LE.110) THEN 789 : NBROBL=4 790 : SEGINI,NOMID 791 : LESOBL(1)='KS ' 792 : LESOBL(2)='KN ' 793 : LESOBL(3)='COB ' 794 : LESOBL(4)='MOB ' 795 : ELSE IF (MELE.GE.173.AND.MELE.LE.177) THEN 796 : NBROBL=10 797 : SEGINI,NOMID 798 : LESOBL(1)='YOUN' 799 : LESOBL(2)='NU ' 800 : LESOBL(3)='COP1' 801 : LESOBL(4)='COP2' 802 : LESOBL(5)='CPP1' 803 : LESOBL(6)='CPP2' 804 : LESOBL(7)='KK11' 805 : LESOBL(8)='KK12' 806 : LESOBL(9)='KK21' 807 : LESOBL(10)='KK22' 808 : ELSE IF (MELE.GE.178.AND.MELE.LE.182) THEN 809 : NBROBL=17 810 : SEGINI,NOMID 811 : LESOBL(1)='YOUN' 812 : LESOBL(2)='NU ' 813 : LESOBL(3)='COP1' 814 : LESOBL(4)='COP2' 815 : LESOBL(5)='COP3' 816 : LESOBL(6)='CPP1' 817 : LESOBL(7)='CPP2' 818 : LESOBL(8)='CPP3' 819 : LESOBL(9)='KK11' 820 : LESOBL(10)='KK12' 821 : LESOBL(11)='KK13' 822 : LESOBL(12)='KK21' 823 : LESOBL(13)='KK22' 824 : LESOBL(14)='KK23' 825 : LESOBL(15)='KK31' 826 : LESOBL(16)='KK32' 827 : LESOBL(17)='KK33' 828 : ENDIF 829 : ELSE IF (MAPL.EQ.1) THEN 830 : NBROBL=3 831 : SEGINI,NOMID 832 : LESOBL(1)='YOUN' 833 : LESOBL(2)='NU ' 834 : LESOBL(3)='SIGY' 835 : ELSE IF (MAPL.EQ.2.OR.MAPL.EQ.14) THEN 836 : NBROBL=2 837 : NBRFAC=2 838 : SEGINI,NOMID 839 : LESOBL(1)='YOUN' 840 : LESOBL(2)='NU ' 841 : LESFAC(1)='SIGF' 842 : LESFAC(2)='TRAC' 843 : NBTYPE=4 844 : SEGADJ,NOTYPE 845 : TYPE(1)='REAL*8' 846 : TYPE(2)='REAL*8' 847 : TYPE(3)='REAL*8' 848 : TYPE(4)='POINTEUREVOLUTIO' 849 : ELSE IF (MAPL.EQ.3) THEN 850 : NBROBL=4 851 : SEGINI,NOMID 852 : LESOBL(1)='YOUN' 853 : LESOBL(2)='NU ' 854 : LESOBL(3)='LTR ' 855 : LESOBL(4)='LCS ' 856 : ELSE IF (MAPL.EQ.4) THEN 857 : NBROBL=4 858 : SEGINI,NOMID 859 : LESOBL(1)='YOUN' 860 : LESOBL(2)='NU ' 861 : LESOBL(3)='SIGY' 862 : LESOBL(4)='H ' 863 : ELSE IF (MAPL.EQ.5) THEN 864 : NBROBL=3 865 : SEGINI,NOMID 866 : LESOBL(1)='YOUN' 867 : LESOBL(2)='NU ' 868 : LESOBL(3)='TRAC' 869 : NBTYPE=3 870 : SEGADJ,NOTYPE 871 : TYPE(1)='REAL*8' 872 : TYPE(2)='REAL*8' 873 : TYPE(3)='POINTEUREVOLUTIO' 874 : * Modele Drucker Prager 875 : ELSE IF (MAPL.EQ.15) THEN 876 : NBROBL=11 877 : SEGINI,NOMID 878 : LESOBL(1) ='YOUN' 879 : LESOBL(2) ='NU ' 880 : LESOBL(3) ='ETA ' 881 : LESOBL(4) ='MU ' 882 : LESOBL(5) ='KL ' 883 : LESOBL(6) ='GAMM' 884 : LESOBL(7) ='DELT' 885 : LESOBL(8) ='ALFA' 886 : LESOBL(9) ='BETA' 887 : LESOBL(10)='K ' 888 : LESOBL(11)='H ' 889 : * Modele visco-plastique parfait 890 : ELSE IF (MAPL.EQ.43) THEN 891 : NBROBL=5 892 : SEGINI,NOMID 893 : LESOBL(1)='YOUN' 894 : LESOBL(2)='NU ' 895 : LESOBL(3)='SIGY' 896 : LESOBL(4)='N ' 897 : LESOBL(5)='K ' 898 : * Modele Betocyclique 899 : ELSE IF (MAPL.EQ.54) THEN 900 : NBROBL=13 901 : SEGINI,NOMID 902 : LESOBL(1)='YOUN' 903 : LESOBL(2)='NU ' 904 : LESOBL(3)='HHH1' 905 : LESOBL(4)='FTPE' 906 : LESOBL(5)='FCPE' 907 : LESOBL(6)='FTGR' 908 : LESOBL(7)='FCGR' 909 : LESOBL(8)='EPSO' 910 : LESOBL(9)='WOR0' 911 : LESOBL(10)='LCAT' 912 : LESOBL(11)='LCAC' 913 : LESOBL(12)='TREV' 914 : LESOBL(13)='COEV' 915 : NBTYPE=13 916 : SEGADJ,NOTYPE 917 : DO i=1,NBTYPE 918 : TYPE(i)='REAL*8' 919 : ENDDO 920 : TYPE(12)='POINTEUREVOLUTIO' 921 : TYPE(13)='POINTEUREVOLUTIO' 922 : * Rotating Crack 923 : ELSE IF (MAPL.EQ.55) THEN 924 : NBROBL=6 925 : SEGINI,NOMID 926 : LESOBL(1)='YOUN' 927 : LESOBL(2)='NU ' 928 : LESOBL(3)='FTRA' 929 : LESOBL(4)='EPSR' 930 : LESOBL(5)='FRES' 931 : LESOBL(6)='BETA' 932 : * BCN-MRS-Lade (MAPL=111) 933 : ELSE IF (MAPL.EQ.111) THEN 934 : NBROBL=20 935 : SEGINI,NOMID 936 : LESOBL(1)='YOUN' 937 : LESOBL(2)='NU ' 938 : LESOBL(3)='PC ' 939 : LESOBL(4)='PA ' 940 : LESOBL(5)='QA ' 941 : LESOBL(6)='EXPM' 942 : LESOBL(7)='E ' 943 : LESOBL(8)='K1 ' 944 : LESOBL(9)='K2 ' 945 : LESOBL(10)='ETAB' 946 : LESOBL(11)='EXPV' 947 : LESOBL(12)='EPSI' 948 : LESOBL(13)='N ' 949 : LESOBL(14)='CCON' 950 : LESOBL(15)='EXPL' 951 : LESOBL(16)='PCAP' 952 : LESOBL(17)='EXPR' 953 : LESOBL(18)='CCAP' 954 : LESOBL(19)='PHI ' 955 : LESOBL(20)='ALP ' 956 : * BCN-J2 (MAPL=112) 957 : ELSE IF (MAPL.EQ.112) THEN 958 : NBROBL=6 959 : SEGINI,NOMID 960 : LESOBL(1)='YOUN' 961 : LESOBL(2)='NU ' 962 : LESOBL(3)='SIG0' 963 : LESOBL(4)='SIGI' 964 : LESOBL(5)='KISO' 965 : LESOBL(6)='VELO' 966 : * BCN-Rounded Hyperbolic Mohr-Coulomb (MAPL=113) 967 : ELSE IF (MAPL.EQ.113) THEN 968 : NBROBL=4 969 : SEGINI,NOMID 970 : LESOBL(1)='YOUN' 971 : LESOBL(2)='NU ' 972 : LESOBL(3)='COHE' 973 : LESOBL(4)='PHI ' 974 : * Autres modeles ISOTROPEs : elasticite 975 : ELSE 976 : NBROBL=2 977 : SEGINI,NOMID 978 : LESOBL(1)='YOUN' 979 : LESOBL(2)='NU ' 980 : ENDIF 981 : * Autres cas ? 982 : ELSE 983 : IF (LNOMID(6).NE.0) THEN 984 : lsupma=.FALSE. 985 : NOMID=LNOMID(6) 986 : SEGACT,NOMID 987 : NBROBL=LESOBL(/2) 988 : NBRFAC=LESFAC(/2) 989 : ELSE 989 : CALL IDMATR(MFR,IPMOD1,MOMATR,NBROBL,NBRFAC) 990 : ENDIF 991 : IF (CMATE.EQ.'SECTION') THEN 992 : NBTYPE=3 993 : SEGADJ,NOTYPE 994 : TYPE(1)='POINTEURMMODEL' 995 : TYPE(2)='POINTEURMCHAML' 996 : TYPE(3)='POINTEURLISTREEL' 997 : ENDIF 998 : ENDIF 999 : MOMATR=NOMID 1000 : IF (MOMATR.EQ.0) THEN 1001 : SEGSUP,NOTYPE 1002 : KERRE=591 1003 : GOTO 515 1004 : ENDIF 1004 : CALL KOMCHA(IPCHE3,IPMAIL,CONM,MOMATR,MOTYPE,1,INFOS,3,IVAMAT) 1005 : SEGSUP,NOTYPE 1006 : IF (lsupma) SEGSUP,NOMID 1007 : IF (IERR.NE.0) THEN 1008 : KERRE=-ABS(IERR) 1009 : GOTO 515 1010 : ENDIF 1011 : NMATR=NBROBL 1012 : NMATF=NBRFAC 1013 : NMATT=NMATR+NMATF 1014 : IF (ISUPMA.EQ.1) THEN 1014 : CALL VALCHE(IVAMAT,NMATT,IPMINT,IPPORE) 1015 : IF (IERR.NE.0) THEN 1016 : ISUPMA=0 1017 : KERRE=-ABS(IERR) 1018 : GOTO 515 1019 : ENDIF 1020 : ENDIF 1021 : * Recuperation des noms de composantes de caracteristiques geometriques 1022 : * Sauf cas particulier MOTYPE = segment NBTYPE=1 et TYPE(1)='REAL*8' 1023 : NBTYPE=1 1024 : SEGINI,NOTYPE 1025 : TYPE(1)='REAL*8' 1026 : MOTYPE=NOTYPE 1027 : NBROBL=0 1028 : NBRFAC=0 1029 : NOMID=0 1030 : IVECT=0 1031 : * Massif ou certains elements poreux en contraintes planes 1032 : IF ( (MFR.EQ.1 .OR. MFR.EQ.31 .OR. 1033 : & (MELE.GE.79.AND.MELE.LE.83) .OR. 1034 : & (MELE.GE.173.AND.MELE.LE.182) ) 1035 : & .AND. IFOUR.EQ.-2 ) THEN 1036 : NBRFAC=1 1037 : SEGINI,NOMID 1038 : LESFAC(1)='DIM3' 1039 : * Cas des coques 1040 : ELSE IF (MFR.EQ.3 .OR. MFR.EQ.5 .OR. MFR.EQ.9) THEN 1041 : NBROBL=1 1042 : IF (MFR.EQ.3.AND.IFOUR.EQ.-2) THEN 1043 : NBRFAC=3 1044 : ELSE 1045 : NBRFAC=2 1046 : ENDIF 1047 : SEGINI,NOMID 1048 : LESOBL(1)='EPAI' 1049 : LESFAC(1)='EXCE' 1050 : IF (MFR.EQ.3.AND.IFOUR.EQ.-2) LESFAC(2)='DIM3' 1051 : LESFAC(NBRFAC)='CALF' 1052 : * Donnees pour les poutres 1053 : ELSE IF (MFR.EQ.7) THEN 1054 : IF (CMATE.NE.'SECTION' ) THEN 1055 : IF (BPLAN) THEN 1056 : NBRFAC=1 1057 : NBROBL=2 1058 : SEGINI,NOMID 1059 : LESOBL(1)='SECT' 1060 : LESOBL(2)='INRZ' 1061 : LESFAC(1)='SECY' 1062 : ELSE 1063 : NBROBL=4 1064 : NBRFAC=3 1065 : SEGINI,NOMID 1066 : LESOBL(1)='TORS' 1067 : LESOBL(2)='INRY' 1068 : LESOBL(3)='INRZ' 1069 : LESOBL(4)='SECT' 1070 : LESFAC(1)='SECY' 1071 : LESFAC(2)='SECZ' 1072 : LESFAC(3)='VECT' 1073 : IVECT=1 1074 : NBTYPE=7 1075 : SEGADJ,NOTYPE 1076 : TYPE(1)='REAL*8' 1077 : TYPE(2)='REAL*8' 1078 : TYPE(3)='REAL*8' 1079 : TYPE(4)='REAL*8' 1080 : TYPE(5)='REAL*8' 1081 : TYPE(6)='REAL*8' 1082 : TYPE(7)='POINTEURPOINT ' 1083 : ENDIF 1084 : ELSE 1085 : NBRFAC=1 1086 : SEGINI,NOMID 1087 : LESFAC(1)='VECT' 1088 : IVECT=1 1089 : TYPE(1)='POINTEURPOINT ' 1090 : ENDIF 1091 : C Donnees pour les TUYAUX 1092 : ELSE IF (MFR.EQ.13) THEN 1093 : NBROBL=2 1094 : NBRFAC=4 1095 : SEGINI,NOMID 1096 : LESOBL(1)='EPAI' 1097 : LESOBL(2)='RAYO' 1098 : LESFAC(1)='RACO' 1099 : LESFAC(2)='PRES' 1100 : LESFAC(3)='CISA' 1101 : LESFAC(4)='VECT' 1102 : IVECT=1 1103 : NBTYPE=6 1104 : SEGADJ,NOTYPE 1105 : TYPE(1)='REAL*8' 1106 : TYPE(2)='REAL*8' 1107 : TYPE(3)='REAL*8' 1108 : TYPE(4)='REAL*8' 1109 : TYPE(5)='REAL*8' 1110 : TYPE(6)='POINTEURPOINT ' 1111 : C Donnees pour le LINESPRING 1112 : ELSE IF (MFR.EQ.15) THEN 1113 : NBROBL=5 1114 : SEGINI,NOMID 1115 : LESOBL(1)='EPAI' 1116 : LESOBL(2)='FISS' 1117 : LESOBL(3)='VX ' 1118 : LESOBL(4)='VY ' 1119 : LESOBL(5)='VZ ' 1120 : C Donnees pour le TUYAU FISSURE 1121 : ELSE IF (MFR.EQ.17) THEN 1122 : NBROBL=9 1123 : SEGINI,NOMID 1124 : LESOBL(1)='RAYO' 1125 : LESOBL(2)='EPAI' 1126 : LESOBL(3)='VX ' 1127 : LESOBL(4)='VY ' 1128 : LESOBL(5)='VZ ' 1129 : LESOBL(6)='VXF ' 1130 : LESOBL(7)='VYF ' 1131 : LESOBL(8)='VZF ' 1132 : LESOBL(9)='ANGL' 1133 : * Section pour les barres - uniaxial 1134 : ELSE IF (MFR.EQ.27 .AND. CMATE.NE.'NODAL') THEN 1135 : NBROBL=1 1136 : SEGINI,NOMID 1137 : LESOBL(1)='SECT' 1138 : * Elements homogeneises 1139 : ELSE IF (MFR.EQ.37) THEN 1140 : IF (IFOUR.EQ.1.OR.IFOUR.EQ.0.OR.IFOUR.EQ.2) THEN 1141 : NBROBL=5 1142 : SEGINI,NOMID 1143 : LESOBL(1)='SCEL' 1144 : LESOBL(2)='SFLU' 1145 : LESOBL(3)='EPS ' 1146 : LESOBL(4)='SECT' 1147 : LESOBL(5)='INRZ ' 1148 : ELSE 1149 : NBROBL=3 1150 : SEGINI,NOMID 1151 : LESOBL(1)='SCEL' 1152 : LESOBL(2)='SFLU' 1153 : LESOBL(3)='EPS ' 1154 : ENDIF 1155 : * Element TUYO 1156 : ELSE IF (MFR.EQ.39) THEN 1157 : NBROBL=2 1158 : NBRFAC=3 1159 : SEGINI,NOMID 1160 : LESOBL(1)='EPAI' 1161 : LESOBL(2)='RAYO' 1162 : LESFAC(1)='RACO' 1163 : LESFAC(2)='PRES' 1164 : LESFAC(3)='VECT' 1165 : IVECT=1 1166 : NBTYPE=5 1167 : SEGADJ,NOTYPE 1168 : TYPE(1)='REAL*8' 1169 : TYPE(2)='REAL*8' 1170 : TYPE(3)='REAL*8' 1171 : TYPE(4)='REAL*8' 1172 : TYPE(5)='POINTEURPOINT ' 1173 : * Element tuyau acoustique pure 1174 : ELSE IF (MFR.EQ.41) THEN 1175 : NBROBL=1 1176 : NBRFAC=1 1177 : SEGINI,NOMID 1178 : LESOBL(1)='RAYO' 1179 : LESFAC(1)='RACO' 1180 : * Donnees pour les barres excentrees 1181 : ELSE IF (MFR.EQ.49) THEN 1182 : NBROBL=6 1183 : SEGINI,NOMID 1184 : LESOBL(1)='SECT' 1185 : LESOBL(2)='EXCZ' 1186 : LESOBL(3)='EXCY' 1187 : LESOBL(4)='VX ' 1188 : LESOBL(5)='VY ' 1189 : LESOBL(6)='VZ ' 1190 : * Donnees geometriques pour l'element LIA2 de liaison a 2 noeuds 1191 : ELSE IF (MFR.EQ.51) THEN 1192 : NBROBL=9 1193 : SEGINI,NOMID 1194 : LESOBL(1)='RLUX' 1195 : LESOBL(2)='RLUY' 1196 : LESOBL(3)='RLUZ' 1197 : LESOBL(4)='RLRX' 1198 : LESOBL(5)='RLRY' 1199 : LESOBL(6)='RLRZ' 1200 : LESOBL(7)='VX ' 1201 : LESOBL(8)='VY ' 1202 : LESOBL(9)='VZ ' 1203 : * Elements de JOINTs GENE 1204 : ELSE IF (MFR.EQ.55) THEN 1205 : NBRFAC=1 1206 : SEGINI,NOMID 1207 : LESFAC(1)='EPAI' 1208 : * Macro element (element CIFL) 1209 : ELSE IF (MFR.EQ.61)THEN 1210 : NBROBL=2 1211 : SEGINI,NOMID 1212 : LESOBL(1)='SECT' 1213 : LESOBL(2)='INRZ' 1214 : ENDIF 1215 : * dans RIGI1.ESO : ajout de composantes facultatives pour le rendement 1216 : MOCARA=NOMID 1217 : NCARA=NBROBL 1218 : NCARF=NBRFAC 1219 : NCART=NCARA+NCARF 1220 : IF (MOCARA.NE.0) THEN 1220 : CALL KOMCHA(IPCHE3,IPMAIL,CONM,MOCARA,MOTYPE,1,INFOS,3,IVACAR) 1221 : SEGSUP,NOTYPE,NOMID 1222 : IF (IERR.NE.0) THEN 1223 : KERRE=-ABS(IERR) 1224 : GOTO 515 1225 : ENDIF 1226 : IF (ISUPMA.EQ.1) THEN 1226 : CALL VALCHE(IVACAR,NCART,IPMINT,IPPORE) 1227 : IF (IERR.NE.0) THEN 1228 : ISUPMA=0 1229 : KERRE=-ABS(IERR) 1230 : GOTO 515 1231 : ENDIF 1232 : ENDIF 1233 : ELSE 1234 : SEGSUP,NOTYPE 1235 : ENDIF 1236 : 1237 : * dans RIGI1.ESO : 1) utilisation de la densite pour ponderer la prop 1238 : * de phase si besoin, 2) MFR = 63, elements XFEM traites par RIGIXR 1239 : 1240 : *----------------------------------------------------------------------- 1241 : *- 2.4 - Calcul de la matrice tangente selon le type d'element 1242 : *----------------------------------------------------------------------- 1243 : * 1244 : * 20 elements par ligne du GOTO 1245 : GOTO (99,99,99, 4,99, 4,99, 4,99, 4,99,12,99, 4, 4, 4, 4,12,12,99, 1246 : 1 99,22, 4, 4, 4, 4,27,28,29,30,99,99,99,99,35,35,35,35,35,35, 1247 : 2 27,42,43,27,42,46,12,35,27,30,99,99,35,35,12,27,99,99,99,99, 1248 : 3 99,99,99,99,99,99,99,99, 4, 4, 4, 4, 4,99,99,99,99,99,35,35, 1249 : 4 35,35,35,84,85,86,42,42,99,99,99,42,27,12,46,42,42,42,99,99, 1250 : 5 99,99,99,99,99,99,99,35,35,35,35,35,35,35,35,35,35,35,35,35, 1251 : 6 35,35,42,42,42,42,42,99,99,99,99,99,99,99,99,99,99,99,99,99, 1252 : 7 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,42,99,99,99, 1253 : 8 99,99,99,99,99,99,99,42,42,42,42,42, 4, 4, 4, 4, 4, 4, 4, 4, 1254 : 9 4, 4, 4, 4,99,99,99,99,99,99,99,99, 4, 4,99,99,99,99,99,99) 1255 : & ,MELE 1256 : IF (MELE.EQ.258.OR.MELE.EQ.260) GOTO 42 1257 : * Erreur : Element fini non encore implemente 1258 : 99 CONTINUE 1259 : KERRE=86 1260 : MOTERR(1:4)=NOMTP(MELE) 1261 : MOTERR(5:12)='KTANGA ' 1262 : GOTO 510 1263 : *----------------------------------------------------------------------- 1264 : *-> Elements MASSIFs 1265 : *----------------------------------------------------------------------- 1266 : 4 CONTINUE 1267 : NBNO=NBNN 1268 : NBBB=NBNN 1269 : SEGINI,WRK1,WRK2 1270 : IF (BMATE) THEN 1271 : SEGINI,WTRAV 1272 : NLG=NUMGEO(MELE) 1273 : ENDIF 1273 : IF (MAPL.EQ.5 .OR. MAPL.EQ.54) CALL ZDANUL(TRAC,LTRAC) 1274 : IF (MAPL.EQ.54) SEGINI,WRK5 1275 : * Preparation a la recuperation de l'epaisseur 1276 : MVALEP=0 1277 : DIM3=1.D0 1278 : IF (IFOUR.EQ.-2) THEN 1279 : IF (IVACAR.NE.0) THEN 1280 : MPTVAL=IVACAR 1281 : MVALEP=IVAL(1) 1282 : IF (MVALEP.GT.0) THEN 1283 : MELVAL=MVALEP 1284 : NELEP=VELCHE(/2) 1285 : NPGEP=VELCHE(/1) 1286 : ENDIF 1287 : ENDIF 1288 : ENDIF 1289 : * Boucle sur les elements de la sous-zone ISOU 1290 : DO 3004 IB=1,NBELEM 1291 : * Recuperation des coordonnees des noeuds de l'element IB 1291 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 1292 : * Calcul de la matrice de changement de repere (materiau a "tropie") 1293 : IF (BMATE) THEN 1293 : CALL RESHPT(1,NBNN,NLG,MELE,0,IPMIN2,IRT1) 1294 : MINTE2=IPMIN2 1295 : SEGACT,MINTE2 1296 : NBSH=MINTE2.SHPTOT(/2) 1296 : CALL RLOCAL(XE,MINTE2.SHPTOT,NBSH,NBNN,TXR) 1297 : SEGDES,MINTE2 1298 : IF (NBSH.EQ.-1) THEN 1299 : KERRE=525 1300 : GOTO 8004 1301 : ENDIF 1302 : ENDIF 1303 : * Mise a zero de la matrice de rigidite elementaire (IB) 1303 : CALL ZERO(REL,LRE,LRE) 1304 : * Cas des elements incompressibles : termes de la matrice B-BARRE 1305 : IF (MFR.EQ.31) THEN 1305 : CALL BBCALC(XE,MELE,NBNN,IDIM,NBPGAU,POIGAU, 1306 : & QSIGAU,ETAGAU,DZEGAU,NSTRS, 1307 : & LRE,IFOUR,A,BB,NHRM,SHPTOT,SHPWRK,XDPGE,YDPGE) 1308 : ENDIF 1309 : * Boucle sur les points de Gauss de l'element IB 1310 : ISDJC=0 1311 : DO 4004 IGAU=1,NBPGAU 1312 : * Recuperation de l'epaisseur si donnee 1313 : IF (MVALEP.GT.0) THEN 1314 : MELVAL=MVALEP 1315 : IBMN=MIN(IB ,NELEP) 1316 : IGMN=MIN(IGAU,NPGEP) 1317 : DIM3=VELCHE(IGMN,IBMN) 1318 : ENDIF 1319 : * Calcul de la matrice B et du jacobien DJAC au point de Gauss IGAU 1319 : CALL BMATST(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU, 1320 : & MELE,MFR,NBNN,LRE,IFOUR,NSTRS,NHRM,DIM3, 1321 : & XE,SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE) 1322 : IF (DJAC.EQ.0.) THEN 1323 : KERRE=259 1324 : INTERR(1)=IB 1325 : GOTO 8004 1326 : ENDIF 1327 : IF (DJAC.LT.0.) ISDJC=ISDJC+1 1328 : DJAC=ABS(DJAC)*POIGAU(IGAU) 1329 : C En cas d'elements incompressibles : BGENE selon la methode B-BARRE 1330 : IF (MFR.EQ.31) THEN 1330 : CALL BBAR(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU, 1331 : & MELE,NBNN,LRE,IFOUR,NSTRS,XE,DJAC,A,BB,BGENE) 1332 : ENDIF 1333 : 1334 : IRET=0 1335 : * Recuperation des proprietes materielles utiles selon le modele 1336 : MPTVAL=IVAMAT 1337 : IF (MAPL.EQ.5) THEN 1338 : MELVAL=IVAL(1) 1339 : IBMN=MIN(IB ,VELCHE(/2)) 1340 : IGMN=MIN(IGAU,VELCHE(/1)) 1341 : YYYY=VELCHE(IGMN,IBMN) 1342 : MELVAL=IVAL(3) 1343 : IBMN=MIN(IB ,IELCHE(/2)) 1344 : IGMN=MIN(IGAU,IELCHE(/1)) 1345 : IMMM=IELCHE(IGMN,IBMN) 1345 : CALL COTRA1(IMMM,YYYY,LTRAC,TRAC,NTRAC,KERRE) 1346 : ELSE IF (MAPL.EQ.54) THEN 1347 : MELVAL=IVAL(12) 1348 : IBMN=MIN(IB ,IELCHE(/2)) 1349 : IGMN=MIN(IGAU,IELCHE(/1)) 1350 : ITREV=IELCHE(IGMN,IBMN) 1351 : MELVAL=IVAL(13) 1352 : IBMN=MIN(IB ,IELCHE(/2)) 1353 : IGMN=MIN(IGAU,IELCHE(/1)) 1354 : ICOEV=IELCHE(IGMN,IBMN) 1355 : IPOS1=1 1355 : CALL COTRAB(ITREV,TRAC,LTRAC,IPOS1,0,NPOINT,KERRE) 1356 : IF (KERRE.NE.0) THEN 1357 : INTERR(1)=IB 1358 : INTERR(2)=IGAU 1359 : MOTERR(1:4)=NOMTP(MELE) 1360 : GOTO 8004 1361 : ENDIF 1362 : NTRAC1=NPOINT/2 1363 : IPOS2=IPOS1+NPOINT 1363 : CALL COTRAB(ICOEV,TRAC,LTRAC,IPOS2,0,NPOINT,KERRE) 1364 : NTRAC2=NPOINT/2 1365 : IRET=WRK5 1366 : ENDIF 1367 : IF (KERRE.NE.0) THEN 1368 : INTERR(1)=IB 1369 : INTERR(2)=IGAU 1370 : MOTERR(1:4)=NOMTP(MELE) 1371 : GOTO 8004 1372 : ENDIF 1373 : IF (BMATE) IRET=WTRAV 1374 : * Contribution du pt de Gauss IGAU a la matrice tangente elementaire 1374 : CALL DOHOT1(IVAMAT,NMATT,IVACON,NSTRS,IVARI,NVART,TRAC, 1375 : & LTRAC,IGAU,IB,MATE,MAPL,XPREC,DTPS,IFOUR, 1376 : & LHOOK,DDHOOK,IRET) 1377 : IF (IRET.NE.1) THEN 1378 : IF (IRET.EQ.-1) THEN 1379 : KERRE=275 1380 : INTERR(1)=IB 1381 : INTERR(2)=IGAU 1382 : MOTERR(1:4)=NOMTP(MELE) 1383 : C* ELSE IF (IRET.EQ.0) THEN 1384 : ELSE 1385 : KERRE=328 1386 : INTERR(1)=IFOUR 1387 : MOTERR(1:8)=NOMAT(MATE) 1388 : MOTERR(9:12)=NOMAC(MAPL) 1389 : MOTERR(13:20)=NOMFR(MFR) 1390 : ENDIF 1391 : GOTO 8004 1392 : ENDIF 1393 : IF (IRIGE7.EQ.2) THEN 1393 : CALL BDBSTS(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL) 1394 : ELSE 1394 : CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL) 1395 : ENDIF 1396 : 4004 CONTINUE 1397 : * Fin de la boucle sur les points de Gauss 1398 : IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN 1399 : KERRE=195 1400 : INTERR(1)=IB 1401 : GOTO 8004 1402 : ENDIF 1403 : * Remplissage de la matrice de rigidite elementaire (RE(.,.,IB)) 1404 : IF (IRIGE7.EQ.2)THEN 1404 : CALL REMPMS(REL,LRE,RE(1,1,IB)) 1405 : ELSE 1405 : CALL REMPMT(REL,LRE,RE(1,1,IB)) 1406 : ENDIF 1407 : 3004 CONTINUE 1408 : * Fin de la boucle sur les elements 1409 : * Etiquette de gestion des erreurs 1410 : 8004 CONTINUE 1411 : * Menage local 1412 : SEGSUP,WRK1,WRK2 1413 : IF (MAPL.EQ.54) SEGSUP,WRK5 1414 : IF (BMATE) SEGSUP,WTRAV 1415 : GOTO 510 1416 : *----------------------------------------------------------------------- 1417 : *-> Elements de raccord liquide-solide : 1418 : * RAC2 LIA3 LIA4 RACO LICO LIC4 (MELE = 12 18 19 47 55 94) 1419 : * => Elements SANS RIGIDITE (elastique & tangente) 1420 : *----------------------------------------------------------------------- 1421 : 12 CONTINUE 1422 : C Les matrices elementaires sont nulles et ont ete mises a zero lors de 1423 : C l'initialisation du segment XMATRI ! 1424 : GOTO 510 1425 : *----------------------------------------------------------------------- 1426 : *-> Element de type "Relations de conformites" (MELE=22) 1427 : * Matrice TANGENTE = Matrice de RIGIDITE (ELASTIQUE) (cf. RIGI1) 1428 : *----------------------------------------------------------------------- 1429 : 22 CONTINUE 1430 : IF (ITYPEL.NE.22) THEN 1431 : KERRE=977 1432 : GOTO 510 1433 : ENDIF 1434 : * Petite verification sur le nom de la composante mise en relation 1435 : NEXIST=0 1436 : NOMID=LNOMID(1) 1437 : SEGACT,NOMID 1438 : DO i=1,LNOMDD 1439 : IF (NOMDD(i).EQ.LESOBL(1)) NEXIST = I 1440 : ENDDO 1441 : SEGDES,NOMID 1442 : IF (NEXIST.EQ.0) THEN 1443 : KERRE=837 1444 : GOTO 510 1445 : ENDIF 1446 : NLIGRD=NUM(/1) 1447 : NLIGRP=NLIGRD 1448 : * Initialisations et remplissage du segment DESCRipteur 1449 : SEGINI,DESCR 1450 : IPDSCR=DESCR 1451 : NOELEP(1)=1 1452 : NOELED(1)=1 1453 : LISINC(1)='LX ' 1454 : LISDUA(1)='FLX ' 1455 : DO i=2,NLIGRD 1456 : NOELEP(i)=i 1457 : NOELED(i)=i 1458 : LISINC(i)=NOMDD(NEXIST) 1459 : LISDUA(i)=NOMDU(NEXIST) 1460 : ENDDO 1461 : * Definition du segment XMATRI contenant toutes les matrices elementaires 1462 : * identiques en tout element/point de la sous-zone 1463 : IDEBUT = LCOLOR(ICOLOR(1)) - 3 1464 : NELRIG=NUM(/2) 1465 : SEGINI,XMATRI 1466 : IPMATR=XMATRI 1467 : DO i=1,NELRIG 1468 : RE(1,2,i)=-1. 1469 : RE(2,1,i)=-1. 1470 : DO j=3,NLIGRD 1471 : RE(1,j,i)=XCOEFF(IDEBUT+j) 1472 : RE(j,1,i)=RE(1,j,i) 1473 : ENDDO 1474 : ENDDO 1475 : IRIGE7=0 1476 : GOTO 510 1477 : *----------------------------------------------------------------------- 1478 : *-> Elements COQ3 COQ8 COQ2 COQ4 COQ6 DST (MELE = 27 41 44 49 56 93) 1479 : *-> Cas particulier : DKT elastique (MELE = 28 avec MAPL = 0) 1480 : * Matrice TANGENTE = RIGIDITE ELASTIQUE (Appel a RIGI3) 1481 : *----------------------------------------------------------------------- 1482 : 27 CONTINUE 1483 : C Coque integree ou non ? 1484 : NPINT=0 1485 : IF (INFMOD(/1).NE.0) NPINT=INFMOD(1) 1486 : MPTVAL=IVAMAT 1487 : NBGMAT = 0 1488 : NELMAT = 0 1489 : IF (CMATE.EQ.'SECTION') THEN 1490 : DO i=1,IVAL(/1) 1491 : IF (IVAL(i).NE.0)THEN 1492 : MELVAL=IVAL(i) 1493 : NBGMAT=MAX(NBGMAT,IELCHE(/1)) 1494 : NELMAT=MAX(NELMAT,IELCHE(/2)) 1495 : ENDIF 1496 : ENDDO 1497 : ELSE 1498 : DO i=1,IVAL(/1) 1499 : IF (IVAL(i).NE.0) THEN 1500 : MELVAL=IVAL(i) 1501 : NBGMAT=MAX(NBGMAT,VELCHE(/1)) 1502 : NELMAT=MAX(NELMAT,VELCHE(/2)) 1503 : ENDIF 1504 : ENDDO 1505 : ENDIF 1506 : IIPDPG = IPDPGE 1506 : CALL RIGI3(MATE,MELE,IPMAIL,IPMINT,IPMIN1,NBPGAU,LRE,NSTRS, 1507 : & IVAMAT,IVACAR,CMATE,MFR,NBGMAT,NELMAT,1,LHOOK, 1508 : & NMATT,LW,NPINT,IPMATR,IIPDPG) 1509 : IF (IERR.NE.0) KERRE=-ABS(IERR) 1510 : GOTO 510 1511 : *----------------------------------------------------------------------- 1512 : *-> Element DKT (MELE = 28) 1513 : *----------------------------------------------------------------------- 1514 : 28 CONTINUE 1515 : IF (MAPL.EQ.0) GOTO 27 1516 : NBNO=NBNN 1517 : NBBB=NBNN 1518 : SEGINI,WRK1,WRK2,WRK4 1518 : IF (MAPL.EQ.5) CALL ZDANUL(TRAC,LTRAC) 1519 : * Preparation a la recuperation de caracteristiques geometriques 1520 : MPTVAL=IVACAR 1521 : EXCEN=0.D0 1522 : MVALEX=IVAL(2) 1523 : IF (MVALEX.GT.0) THEN 1524 : MELVAL=MVALEX 1525 : NELEX=VELCHE(/2) 1526 : NPGEX=VELCHE(/1) 1527 : ENDIF 1528 : CALFA=0.666666666666666666666666666666666666666666666D0 1529 : MVALCA=IVAL(NCART) 1530 : IF (MVALCA.GT.0) THEN 1531 : MELVAL=MVALCA 1532 : NELCA=VELCHE(/2) 1533 : NPGCA=VELCHE(/1) 1534 : ENDIF 1535 : * Boucle sur les elements de la sous-zone ISOU 1536 : DO 3028 IB=1,NBELEM 1537 : * Recuperation des coordonnees des noeuds de l'element IB 1537 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 1538 : * Passage dans le repere local de l'element 1538 : CALL VPAST(XE,BPSS) 1538 : CALL VCORLC(XE,XEL,BPSS) 1539 : * Mise a zero de la matrice de rigidite elementaire (IB) 1539 : CALL ZERO(REL,LRE,LRE) 1540 : * Boucle sur les points de Gauss de l'element IB 1541 : DO 4028 IGAU=1,NBPGAU 1542 : * Recuperation des caracteristiques geometriques 1543 : MPTVAL=IVACAR 1544 : MELVAL=IVAL(1) 1545 : IBMN=MIN(IB ,VELCHE(/2)) 1546 : IGMN=MIN(IGAU,VELCHE(/1)) 1547 : EPAIST=VELCHE(IGMN,IBMN) 1548 : IF (MVALEX.GT.0) THEN 1549 : MELVAL=MVALEX 1550 : IBMN=MIN(IB ,NELEX) 1551 : IGMN=MIN(IGAU,NPGEX) 1552 : EXCEN=VELCHE(IGMN,IBMN) 1553 : ENDIF 1554 : IF (MVALCA.GT.0) THEN 1555 : MELVAL=MVALCA 1556 : IBMN=MIN(IB ,NELCA) 1557 : IGMN=MIN(IGAU,NPGCA) 1558 : CALFA=VELCHE(IGMN,IBMN) 1559 : ENDIF 1560 : * Calcul de la matrice B et du jacobien DJAC au point de Gauss IGAU 1560 : CALL BMAT28(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU, 1561 : & MELE,MFR,NBNO,LRE,IFOUR,NSTRS,0,1.D0,XEL, 1562 : & SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE) 1563 : DJAC=DJAC*POIGAU(IGAU) 1564 : * Modification de la matrice B en cas d'excentrement non nul 1565 : IF (ABS(EXCEN).GT.0.) THEN 1566 : DO i=1,3 1567 : k=i+3 1568 : DO j=1,LRE 1569 : BGENE(i,j)=BGENE(i,j)+EXCEN*BGENE(k,j) 1570 : ENDDO 1571 : ENDDO 1572 : ENDIF 1573 : * Recuperation des proprietes materielles utiles selon le modele 1574 : IF (MAPL.EQ.5) THEN 1575 : MPTVAL=IVAMAT 1576 : MELVAL=IVAL(1) 1577 : IBMN=MIN(IB ,VELCHE(/2)) 1578 : IGMN=MIN(IGAU,VELCHE(/1)) 1579 : YYYY=VELCHE(IGMN,IBMN) 1580 : MELVAL=IVAL(3) 1581 : IBMN=MIN(IB ,IELCHE(/2)) 1582 : IGMN=MIN(IGAU,IELCHE(/1)) 1583 : IMMM=IELCHE(IGMN,IBMN) 1583 : CALL COTRA1(IMMM,YYYY,LTRAC,TRAC,NTRAC,KERRE) 1584 : IF (KERRE.NE.0) THEN 1585 : INTERR(1)=IB 1586 : INTERR(2)=IGAU 1587 : MOTERR(1:4)=NOMTP(MELE) 1588 : GOTO 8028 1589 : ENDIF 1590 : ENDIF 1591 : * DOHOT3 se chargera de convertir les efforts generalises (IVACON) 1592 : * et les variables internes generalisees (IVARI) en contraintes et 1593 : * variables internes "locales" 1594 : * Contribution du pt de Gauss IGAU a la matrice tangente elementaire 1594 : CALL DOHOT3(IVAMAT,NMATT,IVACON,NSTRS,IVARI,NVART, 1595 : & TRAC,LTRAC,CALFA,EPAIST,IGAU,IB,MATE,MAPL, 1596 : & XPREC,DTPS,IFOUR,LHOOK,DDHOOK,IRET) 1597 : IF (IRET.NE.1) THEN 1598 : IF (IRET.EQ.-1) THEN 1599 : KERRE=275 1600 : INTERR(1)=IB 1601 : INTERR(2)=IGAU 1602 : MOTERR(1:4)=NOMTP(MELE) 1603 : C* ELSE IF (IRET.EQ.0) THEN 1604 : ELSE 1605 : KERRE=328 1606 : INTERR(1)=IFOUR 1607 : MOTERR(1:8)=NOMAT(MATE) 1608 : MOTERR(9:12)=NOMAC(MAPL) 1609 : MOTERR(13:20)=NOMFR(MFR) 1610 : ENDIF 1611 : GOTO 8028 1612 : ENDIF 1612 : CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL) 1613 : 4028 CONTINUE 1614 : * Fin de la boucle sur les points de Gauss 1615 : * Calcul de la matrice tangente elementaire (IB) 1616 : REL( 6, 6)=REL(5,5)*1.D-7 1617 : REL(12,12)=REL(6,6) 1618 : REL(18,18)=REL(6,6) 1618 : CALL TRANSK(REL,BPSS,LRE,3,1) 1619 : * Remplissage de la matrice de rigidite elementaire (RE(.,.,IB)) 1619 : CALL REMPMT(REL,LRE,RE(1,1,IB)) 1620 : 3028 CONTINUE 1621 : * Fin de la boucle sur les elements 1622 : * Etiquette de gestion des erreurs 1623 : 8028 CONTINUE 1624 : * Menage local 1625 : SEGSUP,WRK1,WRK2,WRK4 1626 : GOTO 510 1627 : *----------------------------------------------------------------------- 1628 : *-> Element POUTre (MELE=29) 1629 : *-> Cas particulier : Element TIMO avec materiau ISOTROPE (MELE=84) 1630 : *----------------------------------------------------------------------- 1631 : 29 CONTINUE 1632 : NBBB=NBNN 1633 : SEGINI,WRK1,WRK3 1634 : * Boucle sur les elements de la sous-zone ISOU 1635 : DO 3029 IB=1,NBELEM 1636 : * Recuperation des coordonnees des noeuds de l'element IB 1636 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 1637 : * Recuperation des caracteristiques geometriques (stockees dans WORK) 1638 : MPTVAL=IVACAR 1639 : DO IC=1,NCART-1 1640 : r_z=0. 1641 : IF (IVAL(IC).NE.0) THEN 1642 : MELVAL=IVAL(IC) 1643 : IBMN=MIN(IB,VELCHE(/2)) 1644 : DO IGAU=1,NBNN 1645 : IGMN=MIN(IGAU,VELCHE(/1)) 1646 : r_z=r_z+VELCHE(IGMN,IBMN) 1647 : ENDDO 1648 : r_z=r_z/NBNN 1649 : ENDIF 1650 : WORK(IC)=r_z 1651 : ENDDO 1652 : IF (IVECT.EQ.1) THEN 1653 : IF (IVAL(NCART).NE.0) THEN 1654 : MELVAL=IVAL(NCART) 1655 : IBMN=MIN(IB,IELCHE(/2)) 1656 : IREF=(IELCHE(1,IBMN)-1)*(IDIM+1) 1657 : DO i=1,IDIM 1658 : WORK(NCART+i-1)=XCOOR(IREF+i) 1659 : ENDDO 1660 : ELSE 1661 : DO i=NCART,NCART+IDIM-1 1662 : WORK(i)=0.D0 1663 : ENDDO 1664 : ENDIF 1665 : ELSE 1666 : WORK(NCART)=0. 1667 : ENDIF 1668 : * Recuperation des caracteristiques elastiques (stockees dans WORK) 1669 : MPTVAL=IVAMAT 1670 : MELVAL=IVAL(1) 1671 : IBMN=MIN(IB ,VELCHE(/2)) 1672 : YOUNG=VELCHE(1,IBMN) 1673 : MELVAL=IVAL(2) 1674 : IBMN=MIN(IB ,VELCHE(/2)) 1675 : XNU=VELCHE(1,IBMN) 1676 : CISAIL=0.5*YOUNG/(1.+XNU) 1677 : IF (BPLAN) THEN 1678 : WORK(4)=YOUNG 1679 : WORK(5)=CISAIL 1680 : ELSE 1681 : WORK(10)=YOUNG 1682 : WORK(11)=CISAIL 1683 : ENDIF 1684 : * Modification de caracteristiques (INRY ou SECZ) selon les modeles 1685 : MPTVAL=IVARI 1686 : IF (MAPL.EQ.57.OR.MAPL.EQ.59) THEN 1687 : MELVAL=IVAL(2) 1688 : IBMN=MIN(IB,VELCHE(/2)) 1689 : WORK(2)=VELCHE(1,IBMN)/YOUNG 1690 : ELSE IF(MAPL.EQ.58.OR.MAPL.EQ.60) THEN 1691 : MELVAL=IVAL(2) 1692 : IBMN=MIN(IB,VELCHE(/2)) 1693 : WORK(6)=VELCHE(1,IBMN)/CISAIL 1694 : ENDIF 1695 : * Calcul de la rigidite elementaire tangente (IB) 1696 : IF (MELE.EQ.84) THEN 1697 : IF (BPLAN) THEN 1697 : CALL TIMRI2(REL,LRE,WORK,XE,WORK(12),IRET) 1698 : ELSE 1698 : CALL TIMRIG(REL,LRE,WORK,XE,WORK(12),IRET) 1699 : ENDIF 1700 : ELSE 1701 : IF (BPLAN) THEN 1701 : CALL POURI2(REL,LRE,WORK,XE,WORK(12),IRET) 1702 : ELSE 1702 : CALL POURIG(REL,LRE,WORK,XE,WORK(12),IRET) 1703 : ENDIF 1704 : ENDIF 1705 : IF (IRET.NE.0) THEN 1706 : IF (IRET.EQ.1) KERRE=128 1707 : IF (IRET.EQ.2) KERRE=138 1708 : INTERR(1)=ISOUS 1709 : INTERR(2)=IB 1710 : GOTO 8029 1711 : ENDIF 1712 : * Remplissage de la matrice de rigidite elementaire (RE(.,.,IB) 1712 : CALL REMPMT(REL,LRE,RE(1,1,IB)) 1713 : 3029 CONTINUE 1714 : * Fin de la boucle sur les elements 1715 : * Etiquette de gestion des erreurs 1716 : 8029 CONTINUE 1717 : * Menage local 1718 : SEGSUP,WRK1,WRK3 1719 : GOTO 510 1720 : *----------------------------------------------------------------------- 1721 : *-> Elements linespring LISP et LISM en nonlineaire (MELE = 30 50) 1722 : *----------------------------------------------------------------------- 1723 : 30 CONTINUE 1724 : IF (MAPL.EQ.0) GOTO 42 1725 : NBBB=NBNN 1726 : SEGINI,WRK1,WRK3 1727 : * Boucle sur les elements de la sous-zone ISOU 1728 : DO 3030 IB=1,NBELEM 1729 : * Recuperation des coordonnees des noeuds de l'element IB 1729 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 1730 : IE=1 1731 : * Recuperation des proprietes materielles (stockees dans WORK) 1732 : IE1=IE 1733 : MPTVAL=IVAMAT 1734 : DO IC=1,NBPGAU 1735 : DO i=1,2 1736 : MELVAL=IVAL(i) 1737 : IGMN=MIN(IC,VELCHE(/1)) 1738 : IBMN=MIN(IB,VELCHE(/2)) 1739 : WORK(IE)=VELCHE(IGMN,IBMN) 1740 : IE=IE+1 1741 : ENDDO 1742 : DO i=3,4 1743 : WORK(IE)=0.D0 1744 : IE=IE+1 1745 : ENDDO 1746 : MELVAL=IVAL(3) 1747 : IGMN=MIN(IC,VELCHE(/1)) 1748 : IBMN=MIN(IB,VELCHE(/2)) 1749 : WORK(IE)=VELCHE(IGMN,IBMN) 1750 : IE=IE+1 1751 : ENDDO 1752 : * Recuperation des contraintes (stockees dans WORK) 1753 : IE2=IE 1754 : MPTVAL=IVACON 1755 : DO IC=1,NBGS 1756 : DO i=1,NSTRS 1757 : MELVAL=IVAL(i) 1758 : IGMN=MIN(IC,VELCHE(/1)) 1759 : IBMN=MIN(IB ,VELCHE(/2)) 1760 : WORK(IE)=VELCHE(IGMN,IBMN) 1761 : IE=IE+1 1762 : ENDDO 1763 : ENDDO 1764 : * Recuperation des caracteristiques geometriques (stockees dans WORK) 1765 : IE3=IE 1766 : MPTVAL=IVACAR 1767 : DO IC=1,NBPGAU 1768 : DO i=1,NCART 1769 : MELVAL=IVAL(i) 1770 : IGMN=MIN(IC,VELCHE(/1)) 1771 : IBMN=MIN(IB,VELCHE(/2)) 1772 : WORK(IE)=VELCHE(IGMN,IBMN) 1773 : IE=IE+1 1774 : ENDDO 1775 : ENDDO 1776 : * Recuperation des variables internes (stockees dans WORK) 1777 : IE4=IE 1778 : MPTVAL=IVARI 1779 : DO IC=1,NBGS 1780 : DO i=1,NVART 1781 : MELVAL=IVAL(i) 1782 : IGMN=MIN(IC,VELCHE(/1)) 1783 : IBMN=MIN(IB,VELCHE(/2)) 1784 : WORK(IE)=VELCHE(IGMN,IBMN) 1785 : IE=IE+1 1786 : ENDDO 1787 : ENDDO 1788 : IE5=IE+1 1789 : * Calcul de la rigidite elementaire tangente (IB) 1789 : CALL LISPKT(XE,WORK(IE1),WORK(IE2),WORK(IE3),WORK(IE4),NSTRS, 1790 : & NBGS,NBPGAU,MELE,XPREC,WORK(IE5),REL,I70,I157, 1791 : & I158,IRET,KERRE) 1792 : IF (IRET.EQ.-1.OR.KERRE.NE.0) THEN 1793 : KERRE=270 1794 : IF (IRET.EQ.-1) KERRE=275 1795 : INTERR(1)=IB 1796 : INTERR(2)=1 1797 : MOTERR(1:4)=NOMTP(MELE) 1798 : GOTO 8030 1799 : ENDIF 1800 : IF (I158.EQ.1) THEN 1801 : KERRE=158 1802 : INTERR(1)=IB 1803 : GOTO 8030 1804 : ENDIF 1805 : * Remplissage de la matrice de rigidite elementaire (RE(.,.,IB)) 1805 : CALL REMPMT(REL,LRE,RE(1,1,IB)) 1806 : 3030 CONTINUE 1807 : * Fin de la boucle sur les elements 1808 : * Etiquette de gestion des erreurs 1809 : 8030 CONTINUE 1810 : * Menage local 1811 : SEGSUP,WRK1,WRK3 1812 : GOTO 510 1813 : *----------------------------------------------------------------------- 1814 : *-> Elements liquide LTR3 LQU4 LCU8 LPR6 LTE4 LPY5 (MELE = 35 a 40) 1815 : * Elements de surface libre LSU2 LSU3 LSU4 (MELE = 48 53 54) 1816 : * Elements poreux TRIP QUAP CUBP TETP PRIP (MELE = 79 a 83) 1817 : * Elements joints poreux JOP3 JOP6 JOP8 (MELE = 108 a 110) 1818 : * Elements massifs polygonaux POLY (MELE = 111 a 122) 1819 : * Matrice TANGENTE = RIGIDITE ELASTIQUE (Appel a RIGI2) 1820 : *----------------------------------------------------------------------- 1821 : 35 CONTINUE 1822 : NCAR1 = NCART + 1 1823 : MPTVAL=IVAMAT 1824 : NBGMAT = 0 1825 : NELMAT = 0 1826 : IF (CMATE.EQ.'SECTION') THEN 1827 : DO i=1,IVAL(/1) 1828 : IF (IVAL(i).NE.0) THEN 1829 : MELVAL=IVAL(i) 1830 : NBGMAT=MAX(NBGMAT,IELCHE(/1)) 1831 : NELMAT=MAX(NELMAT,IELCHE(/2)) 1832 : ENDIF 1833 : ENDDO 1834 : ELSE 1835 : DO i=1,IVAL(/1) 1836 : IF (IVAL(i).NE.0) THEN 1837 : MELVAL=IVAL(i) 1838 : NBGMAT=MAX(NBGMAT,VELCHE(/1)) 1839 : NELMAT=MAX(NELMAT,VELCHE(/2)) 1840 : ENDIF 1841 : ENDDO 1842 : ENDIF 1843 : IIPDPG = IPDPGE 1843 : CALL RIGI2 (MATE,MELE,IPMAIL,IPMINT,NBPGAU,LRE,NSTRS,IVAMAT, 1844 : & IVACAR,CMATE,MFR,NBGMAT,NELMAT,1,LHOOK,NMATT,IPORE, 1845 : & NDDL,IPMATR,IIPDPG,NCAR1) 1846 : IF (IERR.NE.0) KERRE=-ABS(IERR) 1847 : GOTO 510 1848 : *----------------------------------------------------------------------- 1849 : *-> Elements TUYA POI1 JOT3 JOI4 TRIH TUYO (MELE = 42 45 87 88 92 96) 1850 : * LSE2 LITU BAR3 BAEX LIA2 QUAH CUBH (MELE = 97 98 123 a 127) 1851 : * TRH6 JCT3 JCI4 JGI2 JGT3 JGI4 (MELE = 157 168 a 172) 1852 : * CIFL SURE?? SHB8 (MELE = 258 259? 260) 1853 : *-> Cas particuliers : LISP & LISM en elasticite (MELE= 30 50 & MAPL=0) 1854 : * TUFI en elasticite (MELE=43 & MAPL=0) 1855 : * Matrice TANGENTE = RIGIDITE ELASTIQUE (Appel a RIGI4) 1856 : *----------------------------------------------------------------------- 1857 : 42 CONTINUE 1858 : MPTVAL=IVAMAT 1859 : NBGMAT = 0 1860 : NELMAT = 0 1861 : IF (CMATE.EQ.'SECTION') THEN 1862 : DO i=1,IVAL(/1) 1863 : IF (IVAL(i).NE.0)THEN 1864 : MELVAL=IVAL(i) 1865 : NBGMAT=MAX(NBGMAT,IELCHE(/1)) 1866 : NELMAT=MAX(NELMAT,IELCHE(/2)) 1867 : ENDIF 1868 : ENDDO 1869 : ELSE 1870 : DO i=1,IVAL(/1) 1871 : IF (IVAL(i).NE.0)THEN 1872 : MELVAL=IVAL(i) 1873 : NBGMAT=MAX(NBGMAT,VELCHE(/1)) 1874 : NELMAT=MAX(NELMAT,VELCHE(/2)) 1875 : ENDIF 1876 : ENDDO 1877 : ENDIF 1878 : IIPDPG = IPDPGE 1878 : CALL RIGI4(MATE,MELE,IPMAIL,IPMINT,NBPGAU,LRE,NSTRS, 1879 : & IVAMAT,IVACAR,IVECT,CMATE,MFR,NBGMAT,NELMAT,1, 1880 : & LHOOK,NMATT,NCART,ISOUS,LW,IPORE,IPMATR,IIPDPG) 1881 : IF (IERR.NE.0) KERRE=-ABS(IERR) 1882 : GOTO 510 1883 : *----------------------------------------------------------------------- 1884 : *-> Element TUFI en non lineaire (MELE=43) 1885 : *----------------------------------------------------------------------- 1886 : 43 CONTINUE 1887 : IF (MAPL.EQ.0) GOTO 42 1888 : C* Temporaire : si SIGF n'est pas definie, on utilise la matrice elastique 1889 : MPTVAL=IVAMAT 1890 : IF (IVAL(3).EQ.0) GOTO 42 1891 : NBBB=NBNN 1892 : SEGINI,WRK1,WRK3 1893 : * Boucle sur les elements de la sous-zone ISOU 1894 : DO 3043 IB=1,NBELEM 1895 : * Recuperation des proprietes materielles (stockees dans WORK) 1896 : IE =1 1897 : IE1=IE 1898 : MPTVAL=IVAMAT 1899 : DO IC=1,NBPGAU 1900 : DO i=1,2 1901 : MELVAL=IVAL(i) 1902 : IGMN=MIN(IC,VELCHE(/1)) 1903 : IBMN=MIN(IB,VELCHE(/2)) 1904 : WORK(IE)=VELCHE(IGMN,IBMN) 1905 : IE=IE+1 1906 : ENDDO 1907 : DO i=3,4 1908 : WORK(IE)=0.D0 1909 : IE=IE+1 1910 : ENDDO 1911 : MELVAL=IVAL(3) 1912 : IF (MELVAL.NE.0) THEN 1913 : IGMN=MIN(IC,VELCHE(/1)) 1914 : IBMN=MIN(IB,VELCHE(/2)) 1915 : WORK(IE)=VELCHE(IGMN,IBMN) 1916 : ELSE 1917 : WORK(IE)=0.D0 1918 : ENDIF 1919 : IE=IE+1 1920 : DO i=6,7 1921 : WORK(IE)=0.D0 1922 : IE=IE+1 1923 : ENDDO 1924 : ENDDO 1925 : * Recuperation des contraintes (stockees dans WORK) 1926 : IE2=IE 1927 : MPTVAL=IVACON 1928 : DO IC=1,NBGS 1929 : DO i=1,NSTRS 1930 : MELVAL=IVAL(i) 1931 : IGMN=MIN(IC,VELCHE(/1)) 1932 : IBMN=MIN(IB,VELCHE(/2)) 1933 : WORK(IE)=VELCHE(IGMN,IBMN) 1934 : IE=IE+1 1935 : ENDDO 1936 : ENDDO 1937 : * Recuperation des caracteristiques geometriques (stockees dans WORK) 1938 : IE3=IE 1939 : MPTVAL=IVACAR 1940 : DO IC=1,NBPGAU 1941 : DO i=1,8 1942 : MELVAL=IVAL(i) 1943 : IGMN=MIN(IC,VELCHE(/1)) 1944 : IBMN=MIN(IB,VELCHE(/2)) 1945 : WORK(IE)=VELCHE(IGMN,IBMN) 1946 : IE=IE+1 1947 : ENDDO 1948 : WORK(IE)=0.D0 1949 : IE=IE+1 1950 : ENDDO 1951 : * Recuperation des variables internes (stockees dans WORK) 1952 : IE4=IE 1953 : MPTVAL=IVARI 1954 : DO IC=1,NBGS 1955 : DO i=1,NVART 1956 : MELVAL=IVAL(i) 1957 : IGMN=MIN(IC,VELCHE(/1)) 1958 : IBMN=MIN(IB,VELCHE(/2)) 1959 : WORK(IE)=VELCHE(IGMN,IBMN) 1960 : IE=IE+1 1961 : ENDDO 1962 : ENDDO 1963 : IE5=IE+1 1964 : * Calcul de la rigidite elementaire tangente (IB) 1964 : CALL TUFIKT(WORK(IE1),WORK(IE2),WORK(IE3),WORK(IE4),REL,XPREC, 1965 : & IRET) 1966 : IF (IRET.NE.0) THEN 1967 : INTERR(1)=ISOUS 1968 : INTERR(2)=IB 1969 : IF (IRET.EQ.1) KERRE=137 1970 : IF (IRET.EQ.2) KERRE=123 1971 : IF (IRET.EQ.3) KERRE=266 1972 : IF (IRET.EQ.4) THEN 1973 : KERRE=275 1974 : INTERR(1)=IB 1975 : INTERR(2)=1 1976 : MOTERR(1:4)=NOMTP(MELE) 1977 : ENDIF 1978 : GOTO 8043 1979 : ENDIF 1980 : * Remplissage de la matrice de rigidite elementaire (RE(.,.,IB)) 1980 : CALL REMPMT(REL,LRE,RE(1,1,IB)) 1981 : 3043 CONTINUE 1982 : * Fin de la boucle sur les elements 1983 : * Etiquette de gestion des erreurs 1984 : 8043 CONTINUE 1985 : * Menage local 1986 : SEGSUP,WRK1,WRK3 1987 : GOTO 510 1988 : *----------------------------------------------------------------------- 1989 : *-> Elements BARRe et CERCe (MELE = 46 95) 1990 : *----------------------------------------------------------------------- 1991 : 46 CONTINUE 1992 : IF (MELE.EQ.95.AND.(IFOUR.NE.0.AND.IFOUR.NE.1)) GOTO 99 1993 : NBBB=NBNN 1994 : SEGINI,WRK1,WRK3 1995 : MPTVAL=IVACAR 1996 : MELVAL=IVAL(1) 1997 : NELCAR=VELCHE(/2) 1998 : MELCAR=IVAL(1) 1999 : * Boucle sur les elements de la sous-zone ISOU 2000 : DO 3046 IB=1,NBELEM 2001 : * Recuperation des coordonnees des noeuds de l'element IB 2001 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 2002 : * Recuperation de la section de l'element IB 2003 : MELVAL=MELCAR 2004 : IBMN=MIN(IB,NELCAR) 2005 : SECT=VELCHE(1,IBMN) 2006 : * Recuperation du module tangent selon le modele utilise 2007 : MPTVAL=IVARI 2008 : IF (MAPL.EQ.93) THEN 2009 : MELVAL=IVAL(16) 2010 : IBMN=MIN(IB,VELCHE(/2)) 2011 : YOUNGT=VELCHE(1,IBMN) 2012 : ELSE IF (MAPL.EQ.92) THEN 2013 : MELVAL=IVAL(6) 2014 : IBMN=MIN(IB,VELCHE(/2)) 2015 : YOUNGT=VELCHE(1,IBMN) 2016 : ELSE IF (MAPL.EQ.39) THEN 2017 : MELVAL=IVAL(6) 2018 : IBMN=MIN(IB,VELCHE(/2)) 2019 : YOUNGT=VELCHE(1,IBMN) 2020 : ELSE IF (MAPL.EQ.40) THEN 2021 : MELVAL=IVAL(4) 2022 : IBMN=MIN(IB,VELCHE(/2)) 2023 : YOUNGT=VELCHE(1,IBMN) 2024 : ELSE IF (MAPL.EQ.0) THEN 2025 : MPTVAL=IVAMAT 2026 : MELVAL=IVAL(1) 2027 : IBMN=MIN(IB,VELCHE(/2)) 2028 : YOUNGT=VELCHE(1,IBMN) 2029 : ELSE 2030 : KERRE=81 2031 : MOTERR(1:8)=CMATE 2032 : MOTERR(9:16)=NOMFR(MFR/2+1) 2033 : INTERR(1)=IFOUR 2034 : GOTO 8046 2035 : ENDIF 2036 : * Calcul de la rigidite elementaire tangente (IB) 2037 : XHOOK=YOUNGT*SECT 2038 : IF (MELE.EQ.46) THEN 2038 : CALL BARRIG(REL,LRE,XHOOK,XE,IRET) 2039 : IF (IRET.EQ.1) KERRE=128 2040 : ELSE IF (MELE.EQ.95) THEN 2040 : CALL CERRIG(REL,LRE,XHOOK,XE,IRET) 2041 : IF (IRET.EQ.1) KERRE=601 2042 : ENDIF 2043 : IF (KERRE.NE.0) THEN 2044 : INTERR(1)=ISOUS 2045 : INTERR(2)=IB 2046 : GOTO 8046 2047 : ENDIF 2048 : * Remplissage de la matrice de rigidite elementaire (RE(.,.,IB)) 2048 : CALL REMPMT(REL,LRE,RE(1,1,IB)) 2049 : 3046 CONTINUE 2050 : * Fin de la boucle sur les elements 2051 : * Etiquette de gestion des erreurs 2052 : 8046 CONTINUE 2053 : * Menage local 2054 : SEGSUP,WRK1,WRK3 2055 : GOTO 510 2056 : *----------------------------------------------------------------------- 2057 : *-> Element de poutre de TIMOschenko (MELE=84 - Formulation 'SECTION') 2058 : *----------------------------------------------------------------------- 2059 : 84 CONTINUE 2060 : IF (CMATE.EQ.'ISOTROPE') GOTO 29 2061 : * Remarque : La formulation SECTION est le seul cas prevu actuellement. 2062 : IF (CMATE.NE.'SECTION') THEN 2063 : KERRE=193 2064 : MOTERR(1:8)=NOMFR(MFR) 2065 : GOTO 510 2066 : ENDIF 2067 : NBBB=NBNN 2068 : SEGINI WRK1,WRK3 2069 : * Boucle sur les elements de la sous-zone ISOU 2070 : DO 3084 IB=1,NBELEM 2071 : * Recuperation des coordonnees des noeuds de l'element IB 2071 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 2072 : * Recuperation des caracteristiques geometriques (stockees dans WORK) 2073 : * Attention : on a tenu compte du fait que NCART=1 2074 : MPTVAL=IVACAR 2075 : IF (IVAL(NCART).NE.0) THEN 2076 : MELVAL=IVAL(NCART) 2077 : IBMN=MIN(IB,IELCHE(/2)) 2078 : IP=IELCHE(1,IBMN) 2079 : IREF=(IP-1)*(IDIM+1) 2080 : DO IC=1,IDIM 2081 : WORK(IC)=XCOOR(IREF+IC) 2082 : ENDDO 2083 : ELSE 2084 : DO IC=1,IDIM 2085 : WORK(IC)=0.D0 2086 : ENDDO 2087 : ENDIF 2088 : MPTVAL=IVAMAT 2089 : * Traitement dans le cas de la formulation section 2090 : C** IF (CMATE.EQ.'SECTION') THEN 2091 : * Dans le cas d'un materiau elastique, on prend les matrices de Hooke 2092 : * si elles existent dans le MCHAML des proprietes materielles 2093 : IF (MAPL.EQ.0.AND.IVAL(3).NE.0) THEN 2094 : MELVAL=IVAL(3) 2095 : IF (IB.LE.IELCHE(/2).OR.IELCHE(/1).GT.1) THEN 2096 : IBMN=MIN(IB,IELCHE(/2)) 2097 : MLREEL=IELCHE(1,IBMN) 2098 : SEGACT,MLREEL 2098 : CALL DOHOOO(PROG,LHOOK,DDHOOK) 2099 : SEGDES,MLREEL 2100 : ENDIF 2101 : ELSE 2102 : MELVAL=IVAL(1) 2103 : IBMN=MIN(IB,IELCHE(/2)) 2104 : IPMOD=IELCHE(1,IBMN) 2105 : MELVAL=IVAL(2) 2106 : IBMN=MIN(IB,IELCHE(/2)) 2107 : IPCAR=IELCHE(1,IBMN) 2108 : * Sinon calcul des matrices de Hooke a partir des proprietes elastiques 2109 : IF (MAPL.EQ.0) THEN 2109 : CALL FRIGIE(IPMOD,IPCAR,CRIGI,CMASS) 2110 : * Ou calcul des matrices de Hooke a partir des variables internes 2111 : ELSE 2112 : MPTVAL=IVARI 2113 : MELVAL=IVAL(2) 2114 : IBMN=MIN(IB,IELCHE(/2)) 2115 : IPVAR=IELCHE(1,IBMN) 2116 : IF (IPVAR.NE.0) THEN 2116 : CALL FRIGTA(IPMOD,IPCAR,IPVAR,CRIGI) 2117 : ELSE 2117 : CALL FRIGIE(IPMOD,IPCAR,CRIGI,CMASS) 2118 : ENDIF 2119 : ENDIF 2119 : CALL DOHTIF(CRIGI,CMATE,IFOUR,LHOOK,DDHOOK,IRET) 2120 : ENDIF 2121 : IF (BPLAN) THEN 2121 : CALL TIFRI2(REL,LRE,XE,WORK(12),LHOOK,DDHOOK,IRET) 2122 : ELSE 2122 : CALL TIFRIG(REL,LRE,WORK,XE,WORK(12),LHOOK,DDHOOK,IRET) 2123 : ENDIF 2124 : C** ENDIF 2125 : IF (IRET.NE.0) THEN 2126 : INTERR(1)=ISOUS 2127 : INTERR(2)=IB 2128 : IF (IRET.EQ.1) KERRE=128 2129 : IF (IRET.EQ.2) KERRE=138 2130 : GOTO 8084 2131 : ENDIF 2132 : * Remplissage de la matrice de rigidite elementaire (RE(.,.,IB)) 2132 : CALL REMPMT(REL,LRE,RE(1,1,IB)) 2133 : 3084 CONTINUE 2134 : * Fin de la boucle sur les elements 2135 : * Etiquette de gestion des erreurs 2136 : 8084 CONTINUE 2137 : * Menage local 2138 : SEGSUP,WRK1,WRK3 2139 : GOTO 510 2140 : *----------------------------------------------------------------------- 2141 : *-> Element JOI2 - Materiau ISOTROPE (MELE = 85) 2142 : *----------------------------------------------------------------------- 2143 : *OF A voir : Erreur pour joi_ama.dgibi car MAPL=47 et on passe dans 2144 : *OF DOUOTA qui ne traite que MAPL=35,56,91 2145 : 85 CONTINUE 2146 : IF (CMATE.NE.'ISOTROPE') THEN 2147 : KERRE=834 2148 : MOTERR(1:8)=CMATE 2149 : GOTO 510 2150 : ENDIF 2151 : NBNO=NBNN 2152 : NBBB=NBNN 2153 : LW=100 2154 : SEGINI,WRK1,WRK2,WRK3,WRK4 2155 : * Boucle sur les elements de la sous-zone ISOU 2156 : DO 3085 IB=1,NBELEM 2157 : * Recuperation des coordonnees des noeuds de l'element IB 2157 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 2158 : * Calcul des axes locaux de l'element IB 2158 : CALL JO2LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL) 2159 : * Mise a zero de la matrice de rigidite elementaire (IB) 2159 : CALL ZERO(REL,LRE,LRE) 2160 : * Boucle sur les points de Gauss de l'element IB 2161 : DO 4085 IGAU=1,NBPGAU 2162 : * Calcul de la matrice B et du jacobien DJAC au point de Gauss IGAU 2162 : CALL BJO2(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK, 2163 : & BGENE,DJAC,IRET) 2164 : DJAC=DJAC*POIGAU(IGAU) 2165 : * Erreur si le jacobien est <= 0. 2166 : IF (IRET.NE.0) THEN 2167 : KERRE=612 2168 : INTERR(1)=IB 2169 : GOTO 8085 2170 : ENDIF 2171 : * Recuperation des proprietes materielles (stockees dans WORK) 2172 : IE=1 2173 : IE1=IE 2174 : MPTVAL=IVAMAT 2175 : DO i=1,NMATT 2176 : MELVAL=IVAL(i) 2177 : IBMN=MIN(IB ,VELCHE(/2)) 2178 : IGMN=MIN(IGAU,VELCHE(/1)) 2179 : WORK(IE)=VELCHE(IGMN,IBMN) 2180 : IE=IE+1 2181 : ENDDO 2182 : * Calcul de la matrice de Hooke tangente au point de Gauss IGAU 2183 : IF (MAPL.EQ.35.OR.MAPL.EQ.56.OR.MAPL.EQ.91) THEN 2184 : * Recuperation des contraintes (stockees dans WORK) 2185 : IE2=IE 2186 : MPTVAL=IVACON 2187 : DO i=1,NSTRS 2188 : MELVAL=IVAL(i) 2189 : IBMN=MIN(IB ,VELCHE(/2)) 2190 : IGMN=MIN(IGAU,VELCHE(/1)) 2191 : WORK(IE)=VELCHE(IGMN,IBMN) 2192 : IE=IE+1 2193 : ENDDO 2194 : * Recuperation des variables internes (stockees dans WORK) 2195 : IE3=IE 2196 : MPTVAL=IVARI 2197 : DO i=1,NVARI+NVARF 2198 : MELVAL=IVAL(i) 2199 : IBMN=MIN(IB ,VELCHE(/2)) 2200 : IGMN=MIN(IGAU,VELCHE(/1)) 2201 : WORK(IE)=VELCHE(IGMN,IBMN) 2202 : IE=IE+1 2203 : ENDDO 2203 : CALL DOUOTA(WORK(IE1),CMATE,IFOUR,MAPL,WORK(IE2), 2204 : & WORK(IE3),LHOOK,DDHOOK,IRET) 2205 : ELSE 2205 : CALL DOUO88(WORK(IE1),CMATE,IFOUR,LHOOK,DDHOOK,IRET) 2206 : ENDIF 2207 : IF (IRET.EQ.0) THEN 2208 : KERRE=81 2209 : INTERR(1)=IFOUR 2210 : MOTERR(1:8)=CMATE 2211 : MOTERR(9:16)=NOMFR(MFR/2+1) 2212 : GOTO 8085 2213 : ENDIF 2214 : * Contribution du pt de Gauss IGAU a la matrice tangente elementaire 2215 : IF (IRIGE7.EQ.2) THEN 2215 : CALL BDBSTS(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL) 2216 : ELSE 2216 : CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL) 2217 : ENDIF 2218 : 4085 CONTINUE 2219 : * Fin de la boucle sur les points de Gauss 2220 : * Remplissage de la matrice de rigidite elementaire (RE(.,.,IB)) 2221 : IF (IRIGE7.EQ.2) THEN 2221 : CALL REMPMS(REL,LRE,RE(1,1,IB)) 2222 : ELSE 2222 : CALL REMPMT(REL,LRE,RE(1,1,IB)) 2223 : ENDIF 2224 : 3085 CONTINUE 2225 : * Fin de la boucle sur les elements 2226 : * Etiquette de gestion des erreurs 2227 : 8085 CONTINUE 2228 : * Menage local 2229 : SEGSUP,WRK1,WRK2,WRK3,WRK4 2230 : GOTO 510 2231 : *----------------------------------------------------------------------- 2232 : *-> Element JOI3 - Materiau ISOTROPE (MELE = 86) 2233 : *----------------------------------------------------------------------- 2234 : 86 CONTINUE 2235 : IF (CMATE.NE.'ISOTROPE') THEN 2236 : KERRE=834 2237 : MOTERR(1:8)=CMATE 2238 : GOTO 510 2239 : ENDIF 2240 : NBNO=NBNN 2241 : NBBB=NBNN 2242 : LW=100 2243 : SEGINI,WRK1,WRK2,WRK3,WRK4 2244 : * Boucle sur les elements de la sous-zone ISOU 2245 : DO 3086 IB=1,NBELEM 2246 : * Recuperation des coordonnees des noeuds de l'element IB 2246 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 2247 : * Mise a zero de la matrice de rigidite elementaire (IB) 2247 : CALL ZERO(REL,LRE,LRE) 2248 : * Boucle sur les points de Gauss de l'element IB 2249 : DO 4086 IGAU=1,NBPGAU 2250 : * Calcul de la matrice B et du jacobien DJAC au point de Gauss IGAU 2250 : CALL JO3LOC(XE,SHPTOT,IGAU,NBNO,BPSS) 2250 : CALL BJO3(IGAU,MFR,IFOUR,NIFOUR,XE,BPSS,SHPTOT,SHPWRK, 2251 : & BGENE,DJAC,IRET) 2252 : DJAC=DJAC*POIGAU(IGAU) 2253 : * Erreur si le jacobien est <= 0. 2254 : IF (IRET.NE.0) THEN 2255 : KERRE=612 2256 : INTERR(1)=IB 2256 : CALL ERREUR(612) 2257 : GOTO 8086 2258 : ENDIF 2259 : * Recuperation des proprietes materielles (stockees dans WORK) 2260 : IE=1 2261 : IE1=IE 2262 : MPTVAL=IVAMAT 2263 : DO i=1,NMATT 2264 : MELVAL=IVAL(i) 2265 : IBMN=MIN(IB ,VELCHE(/2)) 2266 : IGMN=MIN(IGAU,VELCHE(/1)) 2267 : WORK(IE)=VELCHE(IGMN,IBMN) 2268 : IE=IE+1 2269 : ENDDO 2270 : * Calcul de la matrice de Hooke tangente au point de Gauss IGAU 2271 : IF (MAPL.EQ.35.OR.MAPL.EQ.56.OR.MAPL.EQ.91) THEN 2272 : * Recuperation des contraintes (stockees dans WORK) 2273 : IE2=IE 2274 : MPTVAL=IVACON 2275 : DO i=1,NSTRS 2276 : MELVAL=IVAL(i) 2277 : IBMN=MIN(IB ,VELCHE(/2)) 2278 : IGMN=MIN(IGAU,VELCHE(/1)) 2279 : WORK(IE)=VELCHE(IGMN,IBMN) 2280 : IE=IE+1 2281 : ENDDO 2282 : * Recuperation des variables internes (stockees dans WORK) 2283 : IE3=IE 2284 : MPTVAL=IVARI 2285 : DO i=1,NVARI+NVARF 2286 : MELVAL=IVAL(i) 2287 : IBMN=MIN(IB ,VELCHE(/2)) 2288 : IGMN=MIN(IGAU,VELCHE(/1)) 2289 : WORK(IE)=VELCHE(IGMN,IBMN) 2290 : IE=IE+1 2291 : ENDDO 2291 : CALL DOUOTA(WORK(IE1),CMATE,IFOUR,MAPL,WORK(IE2), 2292 : & WORK(IE3),LHOOK,DDHOOK,IRET) 2293 : ELSE 2293 : CALL DOUO88(WORK(IE1),CMATE,IFOUR,LHOOK,DDHOOK,IRET) 2294 : ENDIF 2295 : IF (IRET.EQ.0) THEN 2296 : KERRE=81 2297 : INTERR(1)=IFOUR 2298 : MOTERR(1:8)=CMATE 2299 : MOTERR(9:16)=NOMFR(MFR/2+1) 2300 : GOTO 8086 2301 : ENDIF 2302 : * Contribution du pt de Gauss IGAU a la matrice tangente elementaire 2303 : IF (IRIGE7.EQ.2) THEN 2303 : CALL BDBSTS(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL) 2304 : ELSE 2304 : CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL) 2305 : ENDIF 2306 : 4086 CONTINUE 2307 : * Remplissage de la matrice de rigidite elementaire (RE(.,.,IB)) 2308 : IF (IRIGE7.EQ.2) THEN 2308 : CALL REMPMS(REL,LRE,RE(1,1,IB)) 2309 : ELSE 2309 : CALL REMPMT(REL,LRE,RE(1,1,IB)) 2310 : ENDIF 2311 : 3086 CONTINUE 2312 : * Fin de la boucle sur les elements 2313 : * Etiquette de gestion des erreurs 2314 : 8086 CONTINUE 2315 : * Menage local 2316 : SEGSUP,WRK1,WRK2,WRK3,WRK4 2317 : GOTO 510 2318 : *----------------------------------------------------------------------- 2319 : * desactivation des segments propres a la zone geometrique ISOU 2320 : *----------------------------------------------------------------------- 2321 : 510 CONTINUE 2322 : IF (IPMATR.NE.0) THEN 2323 : * Symetrisation de la matrice si demandee 2324 : IF (IRIGE7.EQ.2 .AND. IKTSYM.EQ.1) THEN 2325 : LRE = RE(/1) 2326 : DO 5100 IB=1,NBELEM 2327 : DO i=1,LRE 2328 : DO j=i+1,LRE 2329 : RE(i,j,IB) = 0.5*( RE(i,j,IB)+RE(j,i,IB) ) 2330 : RE(j,i,IB) = RE(i,j,IB) 2331 : ENDDO 2332 : ENDDO 2333 : 5100 CONTINUE 2334 : ENDIF 2335 : SEGDES,XMATRI 2336 : ENDIF 2337 : IF (IPDSCR.NE.0) SEGDES,DESCR 2338 : 515 CONTINUE 2339 : IF (ISUPMA.EQ.1) THEN 2339 : CALL DTMVAL(IVACAR,3) 2340 : ELSE 2340 : CALL DTMVAL(IVACAR,1) 2341 : ENDIF 2342 : IF (ISUPMA.EQ.1) THEN 2342 : CALL DTMVAL(IVAMAT,3) 2343 : ELSE 2343 : CALL DTMVAL(IVAMAT,1) 2344 : ENDIF 2345 : IF (ISUPVA.EQ.1) THEN 2345 : CALL DTMVAL(IVARI,3) 2346 : ELSE 2346 : CALL DTMVAL(IVARI,1) 2347 : ENDIF 2348 : IF (ISUPCO.EQ.1) THEN 2348 : CALL DTMVAL(IVACON,3) 2349 : ELSE 2349 : CALL DTMVAL(IVACON,1) 2350 : ENDIF 2351 : IF (lsupdp) THEN 2352 : NOMID=MODEPL 2353 : SEGSUP,NOMID 2354 : ENDIF 2355 : IF (lsupfo) THEN 2356 : NOMID=MOFORC 2357 : SEGSUP,NOMID 2358 : ENDIF 2359 : ** MELEME=IPMAIL 2360 : SEGDES,MELEME 2361 : * Mise a jour du segment MRIGID en cas de SUCCES ! 2362 : IF (KERRE.EQ.0) THEN 2363 : COERIG(ISOU)=1.D0 2364 : IRIGEL(1,ISOU)=IPMAGD 2365 : IRIGEL(2,ISOU)=0 2366 : IRIGEL(3,ISOU)=IPDSCR 2367 : IRIGEL(4,ISOU)=IPMATR 2368 : IRIGEL(5,ISOU)=NIFOUR 2369 : IRIGEL(6,ISOU)=0 2370 : IRIGEL(7,ISOU)=IRIGE7*(1-IKTSYM) 2371 : IRIGEL(8,ISOU)=0 2372 : * Sinon en cas d'ERREUR : sortie prematuree ! 2373 : ELSE 2374 : * Affichage erreur si KERRE > 0 (car KERRE<0 qd erreur deja imprimee) 2374 : IF (KERRE.GT.0) CALL ERREUR(KERRE) 2375 : IF (IPDSCR.NE.0) SEGSUP,DESCR 2376 : IF (IPMATR.NE.0) SEGSUP,XMATRI 2377 : ** IF (IPMAGD.GT.0.AND.IPMAGD.NE.IPMAIL) THEN 2378 : ** MELEME=IPMAGD 2379 : ** SEGSUP,MELEME 2380 : ** ENDIF 2381 : IF (MELE.NE.260) SEGDES,MINTE 2382 : GOTO 551 2383 : ENDIF 2384 : * Fin de la boucle (5000) de PARTITIONNEMENT du segment XMATRI 2385 : 5000 CONTINUE 2386 : IF (MELE.NE.260) SEGDES,MINTE 2387 : *----------------------------------------------------------------------- 2388 : * Fin de la boucle sur les sous-zones du modele 2389 : *----------------------------------------------------------------------- 2390 : 500 CONTINUE 2391 : 2392 : * Sortie du sous-programme 2393 : 551 CONTINUE 2394 : IF (KERRE.EQ.0) THEN 2395 : SEGDES,MRIGID 2396 : IPRIGI=MRIGID 2397 : ELSE 2398 : SEGSUP,MRIGID 2399 : IPRIGI=0 2400 : ENDIF 2401 : * Suppression du modele "deroule" 2402 : 550 CONTINUE 2403 : MMODEL = IPMODL 2404 : DO i = 1,KMODEL(/1) 2405 : IMODEL = KMODEL(i) 2406 : SEGDES,IMODEL 2407 : ENDDO 2408 : SEGSUP,MMODEL 2409 : * Desactivation des champs par element 2410 : MCHELM=IPCHE1 2411 : SEGDES,MCHELM 2412 : MCHELM=IPCHE2 2413 : SEGDES,MCHELM 2414 : MCHELM=IPCHE3 2415 : SEGDES,MCHELM 2416 : 2417 : RETURN 2418 : END 2419 : 2420 : 2421 :
© Cast3M 2003 - All rights reserved.
Disclaimer