1 : C FRVISQ SOURCE FANDEUR 13/01/16 21:15:15 7665 2 : 3 : SUBROUTINE FRVISQ(IPMODL,JPMAIL,IPCHE1, IPRIG) 4 : C 5 : C*********************************************************************** 6 : C * 7 : C Routine principale appelée par AMOR * 8 : C * 9 : C Calcule la matrice d'amortissement associée à la frontière du * 10 : C maillage dans plusieurs cas : * 11 : C * 12 : C FORMULATION MECANIQUE * 13 : C +++++++++++++++++++++ * 14 : C * 15 : C * cas des massifs, dont l'enveloppe est constituée de SEG2 ou * 16 : C SEG3 (cas 2D), FAC3, FAC4, FAC6, ou FAC8 (cas 3D) * 17 : C * 18 : C FORMULATION LIQUIDE * 19 : C +++++++++++++++++++ * 20 : C * 21 : C * cas des éléments dont l'enveloppe est constituée d'éléments * 22 : C à 2 (cas 2D), 3 ou 4 noeuds (cas 3D). * 23 : C______________________________________________________________________* 24 : C * 25 : C Entrées : * 26 : C -------- * 27 : C * 28 : C IPMODL : pointeur sur le modèle, objet MMODEL * 29 : C JPMAIL : pointeur sur le maillage de la frontière, objet MELEME * 30 : C IPCHE1 : pointeur sur le champ par éléments de caractéristiques * 31 : C matériau, objet MCHAML * 32 : C Sorties : * 33 : C -------- * 34 : C IPRIG : pointeur sur la matrice d'amortissement construite, * 35 : C objet MRIGID (=0 en cas d'erreur) * 36 : C * 37 : C*********************************************************************** 38 : C 39 : IMPLICIT INTEGER(I-N) 40 : IMPLICIT REAL*8(A-H,O-Z) 41 : C 42 : -INC CCOPTIO 43 : -INC CCHAMP 44 : 45 : -INC SMCOORD 46 : -INC SMELEME 47 : -INC SMMODEL 48 : -INC SMCHAML 49 : -INC SMRIGID 50 : -INC SMINTE 51 : C 52 : INTEGER oooval 53 : 54 : SEGMENT INFO 55 : INTEGER INFELL(JG) 56 : ENDSEGMENT 57 : C 58 : SEGMENT NOTYPE 59 : CHARACTER*16 TYPE(NBTYPE) 60 : ENDSEGMENT 61 : C 62 : SEGMENT MPTVAL 63 : INTEGER IPOS(NS),NSOF(NS) 64 : INTEGER IVAL(NCOSOU) 65 : CHARACTER*16 TYVAL(NCOSOU) 66 : ENDSEGMENT 67 : C 68 : CHARACTER*(NCONCH) CONM 69 : 70 : C Support du champ de caracteristiques 71 : PARAMETER ( IPLAZ=3 ) 72 : 73 : PARAMETER (NINF=3) 74 : INTEGER INFOS(NINF) 75 : C 76 : IPRIG = 0 77 : 78 : IF (IFOUR.EQ.-3) THEN 78 : CALL ERREUR(21) 79 : RETURN 80 : ENDIF 81 : 82 : c_______________________________________________________________________ 83 : c 84 : c activation du modele 85 : c_______________________________________________________________________ 86 : C 87 : MMODEL=IPMODL 88 : SEGACT MMODEL 89 : NSOUS=KMODEL(/1) 90 : 91 : C______________________________________________________________________C 92 : C C 93 : C CREATION DE L'OBJET MATRICE DE RIGIDITE C 94 : C______________________________________________________________________C 95 : C C 96 : NRIGEL=0 97 : SEGINI,MRIGID 98 : MTYMAT='RIGIDITE' 99 : IFORIG=IFOMOD 100 : ICHOLE=0 101 : IMGEO1=0 102 : IMGEO2=0 103 : ISUPEQ=0 104 : JRCOND=0 105 : JRDEPP=0 106 : JRDEPD=0 107 : 108 : C______________________________________________________________________C 109 : C C 110 : C BOUCLE SUR LES SOUS ZONES C 111 : C______________________________________________________________________C 112 : C C 113 : DO 100 ISOUS = 1, NSOUS 114 : C 115 : C on récupère l'information générale 116 : C 117 : IMODEL = KMODEL(ISOUS) 118 : SEGACT,IMODEL 119 : 120 : C- Initialisations 121 : IENVEL = 0 122 : IPOGEO = 0 123 : 124 : IPT1 = IMAMOD 125 : CONM = CONMOD 126 : MELM = NEFMOD 127 : C 128 : C création du tableau info 129 : C 130 : iret = 1 130 : CALL IDENT(IPT1,CONM,IPCHE1,0,INFOS,iret) 131 : IF (iret.EQ.0) GOTO 1099 132 : C 133 : C Determination de l'enveloppe du maillage massif du sous-modele 134 : C 134 : CALL ECROBJ('MAILLAGE',IPT1) 135 : IF (IDIM.EQ.3) THEN 135 : CALL ENVELO 136 : ELSE IF (IDIM.EQ.2) THEN 136 : CALL PRCONT 137 : ELSE 137 : CALL ERREUR(5) 138 : ENDIF 139 : IF (IERR.NE.0) GOTO 1099 139 : CALL LIROBJ('MAILLAGE',IENVEL,1,iret) 140 : IF (IERR.NE.0) GOTO 1099 141 : C 142 : C Elements de l'enveloppe IENVEL dans le maillage frontiere JPMAIL 143 : C 144 : iret = 0 144 : CALL INTERB(IENVEL,JPMAIL,iret,IPOGEO) 145 : IF (iret.GT.0) GOTO 1099 146 : 147 : IPT3 = IPOGEO 148 : SEGACT,IPT3 149 : NBSOU3 = IPT3.LISOUS(/1) 150 : IPT2 = IPT3 151 : C 152 : C boucle sur les sous-zones de l'enveloppe 153 : C 154 : DO 110 IB = 1, MAX(1,NBSOU3) 155 : 156 : C-- Initialisations : 157 : MOFORC = 0 158 : MODEPL = 0 159 : IPMINT = 0 160 : MOMATR = 0 161 : MOCARA = 0 162 : MOTYPM = 0 163 : MOTYPC = 0 164 : ISUPM = 0 165 : ISUPC = 0 166 : IDESCR = 0 167 : 168 : C-- Informations sur la (sous-zone de) l'enveloppe 169 : IF (NBSOU3.NE.0) THEN 170 : IPT2 = IPT3.LISOUS(IB) 171 : SEGACT,IPT2 172 : ENDIF 173 : NBNOE2 = IPT2.NUM(/1) 174 : NBELE2 = IPT2.NUM(/2) 175 : LETYP = IPT2.ITYPEL 176 : C-- Petit test sur le type 177 : IF (LETYP.EQ.1) THEN 177 : CALL ERREUR(16) 178 : GOTO 1199 179 : ENDIF 180 : IPOGEO = IPT2 181 : C 182 : C-- On détermine le formulation associée à l'objet géométrique 183 : C-- elementaire de surface 183 : CALL TYPFAC(MELM,NBNOE2,MELE) 184 : C 185 : C-- ERREUR : impossible d'utiliser FROABS pour les éléments 186 : C-- de formulation MELM 187 : IF (MELE.EQ.0) THEN 188 : MOTERR(1:8) = NOMTP(MELM) 188 : CALL ERREUR(193) 189 : GOTO 1199 190 : ENDIF 191 : 192 : C-- Information sur l'élément fini 192 : CALL ELQUOI(MELE,0,3,IPINF,IMODEL) 193 : IF (IERR.NE.0) GOTO 1199 194 : C 195 : INFO = IPINF 196 : MFR = INFELL(13) 197 : LRE = INFELL(9) 198 : LW = INFELL(7) 199 : NDDL = INFELL(15) 200 : c* IELE = INFELL(14) 201 : IPPORE = 0 202 : IPMINT = INFELL(11) 203 : SEGSUP,INFO 204 : 205 : C-- Recherche des incomnnues primales et duales (DEPL-FORC) 205 : CALL IDDEPL(MFR,IFOUR,MODEPL,NDEPL,ndum) 205 : CALL IDFORC(MFR,IFOUR,MOFORC,NFORC,ndum) 206 : C 207 : IF (NDEPL.EQ.0 .OR. NFORC.EQ.0 .OR. NDEPL.NE.NFORC) THEN 207 : CALL ERREUR(5) 208 : GOTO 1199 209 : ENDIF 210 : C 211 : NOMID = MODEPL 212 : SEGACT,NOMID 213 : NOMID = MOFORC 214 : SEGACT,NOMID 215 : 216 : C-- Remplissage du segment DESCRipteur 217 : NLIGRP = LRE 218 : NLIGRD = LRE 219 : SEGINI,DESCR 220 : 221 : NCOMP = NDEPL 222 : NBNNS = NBNOE2 223 : IDDL=1 224 : DO 1004 INOEUD=1,NBNNS 225 : DO 1005 ICOMP=1,NCOMP 226 : NOMID = MODEPL 227 : LISINC(IDDL)=LESOBL(ICOMP) 228 : NOMID = MOFORC 229 : LISDUA(IDDL)=LESOBL(ICOMP) 230 : NOELEP(IDDL)=INOEUD 231 : NOELED(IDDL)=INOEUD 232 : IDDL=IDDL+1 233 : 1005 CONTINUE 234 : 1004 CONTINUE 235 : 236 : SEGDES,DESCR 237 : IDESCR = DESCR 238 : 239 : C-- Recuperation des noms de composantes MATERIAU 240 : nbrobl = 0 241 : nbrfac = 0 242 : nomid = 0 243 : notype = 0 244 : 245 : C rho, E, nu pour les massifs 246 : IF (MFR.EQ.1) THEN 247 : nbrobl = 3 248 : SEGINI,nomid 249 : lesobl(1) = 'RHO ' 250 : lesobl(2) = 'YOUN' 251 : lesobl(3) = 'NU ' 252 : 253 : nbtype = 1 254 : SEGINI,notype 255 : type(1) = 'REAL*8' 256 : C 257 : C rho, cson, rhoref, cref, rlcar pour les liquides 258 : ELSE IF (MFR.EQ.11.OR.MFR.EQ.41) THEN 259 : nbrobl = 5 260 : SEGINI,nomid 261 : lesobl(1) = 'RHO ' 262 : lesobl(2) = 'CSON' 263 : lesobl(3) = 'RORF' 264 : lesobl(4) = 'CREF' 265 : lesobl(5) = 'LCAR' 266 : 267 : nbtype = 1 268 : SEGINI,notype 269 : type(1) = 'REAL*8' 270 : ENDIF 271 : 272 : MOMATR = nomid 273 : MOTYPM = notype 274 : NMATR = nbrobl 275 : NMATF = nbrfac 276 : NMATT = NMATR+NMATF 277 : 278 : C--- Verification du support des composantes recherchées 279 : IF (MOMATR.NE.0) THEN 279 : CALL QUESUQ(IMODEL,IPCHE1,3,0,MOMATR,IPLAZ,ISUPM,iret) 280 : IF (ISUPM.GT.1) GOTO 1199 281 : ENDIF 282 : C 283 : C-- Recuperation des noms de composantes CARACTERISTIQUES 284 : nbrobl = 0 285 : nbrfac = 0 286 : nomid = 0 287 : notype = 0 288 : 289 : C Epaisseur du massif en contraintes planes 290 : IF (MFR.EQ.1 .AND. IFOUR.EQ.-2) THEN 291 : nbrfac = 1 292 : SEGINI,nomid 293 : lesfac(1) = 'DIM3' 294 : nbtype = 1 295 : SEGINI,notype 296 : type(1) = 'REAL*8' 297 : ENDIF 298 : 299 : MOCARA = nomid 300 : MOTYPC = notype 301 : NCARA = nbrobl 302 : NCARF = nbrfac 303 : NCARR = NCARA+NCARF 304 : 305 : C--- Verification du support des composantes recherchées 306 : IF (MOCARA.NE.0) THEN 306 : CALL QUESUQ(IMODEL,IPCHE1,3,0,MOCARA,IPLAZ,ISUPC,iret) 307 : IF (ISUPC.GT.1) GOTO 1199 308 : ENDIF 309 : 310 : C-- Segment d'integration MINTE 311 : MINTE = IPMINT 312 : SEGACT,MINTE 313 : NBPGAU = POIGAU(/1) 314 : 315 : C- Partionnement si necessaire de la matrice d'amortissement 316 : C- determinant ainsi le nombre d'objets elementaires de MRIGID 317 : LTRK = oooval(1,4) 318 : IF (LTRK.EQ.0) LTRK = oooval(1,1) 319 : * Ajout a la taille en mots de la matrice des infos du segment 320 : LSEG = LRE*LRE*NBELE2 + 16 321 : NBLPRT = (LSEG-1)/LTRK + 1 322 : NBLMAX = (NBELE2-1)/NBLPRT + 1 323 : NBLPRT = (NBELE2-1)/NBLMAX + 1 324 : c* write(ioimp,*) ' frvisq : nblprt nblmax = ',nblprt,nblmax,nbele2 325 : C*OF : Pour l'instant pas de partition pour FRVISQ 326 : NBLPRT = 1 327 : 328 : C-- Ajout de la matrice d'AMORTISSEMENT a la matrice globale 329 : NRIGE0 = IRIGEL(/2) 330 : NRIGEL = NRIGE0 + NBLPRT 331 : SEGADJ,MRIGID 332 : 333 : descr = IDESCR 334 : meleme = IPOGEO 335 : nbnn = NBNOE2 336 : nbelem = NBELE2 337 : nbsous = 0 338 : nbref = 0 339 : 340 : DO 120 irige = 1, NBLPRT 341 : 342 : C-- Mettre ici la partition du maillage IPOGEO 343 : ipmail = meleme 344 : ipdesc = descr 345 : 346 : C- Initialisation de la matrice de rigidite elementaire (xmatri) 347 : NELRIG = nbelem 348 : SEGINI,xmatri 349 : ipmatr = xmatri 350 : 351 : C- Recuperation des valeurs des proprietes materiau et geometriques 352 : c* Note : les proprietes sont les valeurs au support des EF massifs 353 : c* et non celles au niveau de l'enveloppe surfacique ! 354 : c* Cela ne marche que si les proprietes sont constantes. Dans 355 : c* les autres cas, le resultat est... Pour eviter cela, on met 356 : c* un test sur la constance du champ ! 357 : ivamat = 0 358 : ivacar = 0 359 : IF (MOMATR.NE.0) THEN 359 : CALL KOMCHA(IPCHE1,IPT1,CONM,MOMATR,MOTYPM,1, 359 : c* CALL KOMCHA(IPCHE1,ipmail,CONM,MOMATR,MOTYPM,1, 360 : & INFOS,3, ivamat) 361 : IF (IERR.NE.0) GOTO 1199 362 : mptval = ivamat 363 : do i = 1, NMATT 364 : if (ival(i).ne.0) then 365 : melval = IVAL(i) 366 : if (velche(/1).ne.1 .and. velche(/2).ne.1) then 367 : write(ioimp,*) 'Champ MATERIAU non constant' 367 : call erreur(21) 368 : goto 1199 369 : endif 370 : endif 371 : enddo 372 : IF (ISUPM.EQ.1) THEN 372 : CALL VALCHE(ivamat,NMATT,IPMINT,IPPORE) 373 : IF (IERR.NE.0) THEN 374 : ISUPM = 0 375 : GOTO 1199 376 : ENDIF 377 : ENDIF 378 : ENDIF 379 : IF (MOCARA.NE.0) THEN 379 : CALL KOMCHA(IPCHE1,IPT1,CONM,MOCARA,MOTYPC,1, 379 : c* CALL KOMCHA(IPCHE1,ipmail,CONM,MOCARA,MOTYPC,1, 380 : & INFOS,3, ivacar) 381 : IF (IERR.NE.0) GOTO 1199 382 : mptval = ivacar 383 : do i = 1, NCARR 384 : if (ival(i).ne.0) then 385 : melval = IVAL(i) 386 : if (velche(/1).ne.1 .and. velche(/2).ne.1) then 387 : write(ioimp,*) 'Champ MATERIAU non constant' 387 : call erreur(21) 388 : goto 1199 389 : endif 390 : endif 391 : enddo 392 : IF (ISUPC.EQ.1) THEN 392 : CALL VALCHE(ivacar,NCARR,IPMINT,IPPORE) 393 : IF (IERR.NE.0)THEN 394 : ISUPC = 0 395 : GOTO 1199 396 : ENDIF 397 : ENDIF 398 : ENDIF 399 : 400 : C distinction des cas 2D et 3D 401 : C______________________________________________________________________C 402 : C C 403 : C CAS DES ELEMENTS MASSIFS BIDIMENSIONNELS C 404 : C FACES ASSOCIEES SEG2 OU SEG3 C 405 : C______________________________________________________________________C 406 : C C 407 : IF (MELE.EQ.2.OR.MELE.EQ.3) THEN 408 : C 408 : CALL FROA2D(ipmail,ipmatr,IPMINT,ivamat,ivacar, 409 : 1 MELE,MFR,LRE,NDDL) 410 : C 411 : C______________________________________________________________________C 412 : C C 413 : C CAS DES ELEMENTS LIQUIDES 2D OU 3D C 414 : C FACES ASSOCIEES LSE2, LTR3 OU LQU4 C 415 : C______________________________________________________________________C 416 : C C 417 : C 418 : ELSE IF(MELE.EQ.97.OR.MELE.EQ.35.OR.MELE.EQ.36) THEN 419 : C 419 : CALL LFROA(ipmail,ipmatr,IPMINT,ivamat,ivacar, 420 : 1 MELE,MFR,LRE,NDDL) 421 : C 422 : C______________________________________________________________________C 423 : C C 424 : C CAS DES ELEMENTS MASSIFS TRIDIMENSIONNELS C 425 : C FACES ASSOCIEES FAC3,FAC4,FAC6 OU FAC8 C 426 : C______________________________________________________________________C 427 : C 428 : ELSE IF(MELE.EQ.31.OR.MELE.EQ.32.OR.MELE.EQ.33. 429 : 1 OR.MELE.EQ.34)THEN 430 : C 430 : CALL FROA3D(ipmail,ipmatr,IPMINT,ivamat,ivacar, 431 : 1 MELE,MFR,LRE,NDDL) 432 : C 433 : C erreur, l'élément n'est pas encore implémenté 434 : C 435 : ELSE 436 : C 437 : MOTERR(1:4)=NOMTP(MELE) 438 : MOTERR(5:12)='FRVISQ' 438 : CALL ERREUR (86) 439 : ENDIF 440 : C 441 : IF (ISUPM.EQ.1 .OR. nblprt.GT.1) THEN 441 : CALL DTMVAL(ivamat,3) 442 : ELSE 442 : CALL DTMVAL(ivamat,1) 443 : ENDIF 444 : IF (ISUPC.EQ.1 .OR. nblprt.GT.1) THEN 444 : CALL DTMVAL(ivacar,3) 445 : ELSE 445 : CALL DTMVAL(ivacar,1) 446 : ENDIF 447 : 448 : xmatri = ipmatr 449 : SEGDES,xmatri 450 : IF (NBLPRT.GT.1) THEN 451 : meleme = ipmail 452 : SEGDES,meleme 453 : ENDIF 454 : 455 : C- Sortie prematuree en cas d'erreur 456 : IF (IERR.NE.0) GOTO 1199 457 : 458 : C- Stockage de la matrice 459 : jrige = NRIGE0 + irige 460 : COERIG(jrige) = 1. 461 : IRIGEL(1,jrige) = ipmail 462 : IRIGEL(2,jrige) = 0 463 : IRIGEL(3,jrige) = ipdesc 464 : IRIGEL(4,jrige) = ipmatr 465 : IRIGEL(5,jrige) = NIFOUR 466 : IRIGEL(6,jrige) = 0 467 : IRIGEL(7,jrige) = 0 468 : * matrice non symetrique (forces sur pi seulement 469 : * qui dependent de p) 470 : IF (MFR.EQ.11.OR.MFR.EQ.41) THEN 471 : IRIGEL(7,jrige) = 2 472 : ENDIF 473 : IRIGEL(8,jrige) = 0 474 : 475 : 120 CONTINUE 476 : C- Fin de la boucle de partition maillage/rigidite 477 : 478 : SEGDES,MINTE 479 : 1199 CONTINUE 480 : IF (MOMATR.NE.0) THEN 481 : nomid = MOMATR 482 : SEGSUP,nomid 483 : notype = MOTYPM 484 : SEGSUP,notype 485 : ENDIF 486 : IF (MOCARA.NE.0) THEN 487 : nomid = MOCARA 488 : SEGSUP,nomid 489 : notype = MOTYPC 490 : SEGSUP,notype 491 : ENDIF 492 : 493 : nomid = MOFORC 494 : SEGSUP,nomid 495 : nomid = MODEPL 496 : SEGSUP,nomid 497 : C 498 : IF (NBSOU3.NE.0) SEGDES,IPT2 499 : 500 : C- Sortie prematuree en cas d'erreur 501 : IF (IERR.NE.0) GOTO 1098 502 : 503 : 110 CONTINUE 504 : C- Fin de la boucle sur (les sous-zones de) l'enveloppe 505 : C 506 : 1098 CONTINUE 507 : SEGDES,IPT3 508 : 1099 CONTINUE 509 : SEGDES,IMODEL 510 : C- Sortie prematuree en cas d'erreur 511 : IF (IERR.NE.0) GOTO 999 512 : C 513 : 100 CONTINUE 514 : C- Fin de la boucle sur les modeles elementaires 515 : C 516 : NRIGE0 = IRIGEL(/2) 517 : IF (NRIGE0.EQ.0) THEN 517 : CALL ERREUR(902) 518 : ENDIF 519 : 520 : 999 CONTINUE 521 : IF (IERR.EQ.0) THEN 522 : IPRIG = MRIGID 523 : SEGDES,MRIGID 524 : ELSE 525 : IPRIG = 0 526 : SEGSUP,MRIGID 527 : ENDIF 528 : SEGDES,MMODEL 529 : 530 : RETURN 531 : END 532 : 533 :
© Cast3M 2003 - All rights reserved.
Disclaimer