C RIGSUX SOURCE PV090527 26/04/30 21:16:22 12529 SUBROUTINE RIGSUX(ISOU ,IPOI6, IMODEL) C---------------------------------------------------------------------* C subroutine construisant les sousmatrices de rigidité pour les C sous-modeles de type SURE XFEM : C itypel=48, nformod=259, mfr=63 C---------------------------------------------------------------------* C---------------------------------------------------------------------* C * C ENTREES : * C ________ * C * C IMODEL pointeur sur le sous modele de sure * C ENTREES/SORTIE : * C ________ * C * C IPOI6 pointeur sur la rigidite construite * C ISOU compteur des sous matrices de rigidite construite * C---------------------------------------------------------------------* c IMPLICIT REAL*8 (A-H,O-Z) IMPLICIT INTEGER (I-N) C -INC PPARAM -INC CCOPTIO -INC SMRIGID C-INC SMINTE -INC SMMODEL -INC SMELEME -INC CCHAMP -INC CCGEOME -INC SMCHAML -INC SMCOORD POINTEUR MCHEX1.MCHELM C C C Petit tableau des "couleurs" des relations de conformite DIMENSION LCOLOR(6) DATA LCOLOR / 1, 3, 6, 10, 16, 24 / C MELEME=imamod SEGACT, MELEME IDEBUT = LCOLOR(ICOLOR(1)) - 3 c récupérations du nom des composantes du modele de sure nomid=IMODEL.lnomid(1) SEGACT, nomid c récupération du champ d'enrichissement c MCHEX1= IMODEL.IVAMOD(1) c SEGACT, MCHEX1 c MCHAM1= MCHEX1.ICHAML(1) MCHAM1= IMODEL.IVAMOD(1) SEGACT, MCHAM1 IPT5 = IMODEL.IMAMOD c IPT5 = MCHEX1.IMACHE(1) SEGACT IPT5 C********************************************************************** C Boucle sur les composantes primales facultatives du sure C********************************************************************** ICOMP=0 DO 1 ICOMP=1,nomid.lesfac(/2) C++++ choix du type d'enrichisement de la composante ICOMP IF (nomid.lesfac(ICOMP).EQ.'AX') MELVA1=MCHAM1.IELVAL(1) IF (nomid.lesfac(ICOMP).EQ.'AY') MELVA1=MCHAM1.IELVAL(1) IF (nomid.lesfac(ICOMP).EQ.'AZ') MELVA1=MCHAM1.IELVAL(1) IF (nomid.lesfac(ICOMP).EQ.'B1X') MELVA1=MCHAM1.IELVAL(2) IF (nomid.lesfac(ICOMP).EQ.'B1Y') MELVA1=MCHAM1.IELVAL(2) IF (nomid.lesfac(ICOMP).EQ.'B1Z') MELVA1=MCHAM1.IELVAL(2) IF (nomid.lesfac(ICOMP).EQ.'C1X') MELVA1=MCHAM1.IELVAL(2) IF (nomid.lesfac(ICOMP).EQ.'C1Y') MELVA1=MCHAM1.IELVAL(2) IF (nomid.lesfac(ICOMP).EQ.'C1Z') MELVA1=MCHAM1.IELVAL(2) IF (nomid.lesfac(ICOMP).EQ.'D1X') MELVA1=MCHAM1.IELVAL(2) IF (nomid.lesfac(ICOMP).EQ.'D1Y') MELVA1=MCHAM1.IELVAL(2) IF (nomid.lesfac(ICOMP).EQ.'D1Z') MELVA1=MCHAM1.IELVAL(2) IF (nomid.lesfac(ICOMP).EQ.'E1X') MELVA1=MCHAM1.IELVAL(2) IF (nomid.lesfac(ICOMP).EQ.'E1Y') MELVA1=MCHAM1.IELVAL(2) IF (nomid.lesfac(ICOMP).EQ.'E1Z') MELVA1=MCHAM1.IELVAL(2) IF (nomid.lesfac(ICOMP).EQ.'B2X') MELVA1=MCHAM1.IELVAL(3) IF (nomid.lesfac(ICOMP).EQ.'B2Y') MELVA1=MCHAM1.IELVAL(3) IF (nomid.lesfac(ICOMP).EQ.'B2Z') MELVA1=MCHAM1.IELVAL(3) IF (nomid.lesfac(ICOMP).EQ.'C2X') MELVA1=MCHAM1.IELVAL(3) IF (nomid.lesfac(ICOMP).EQ.'C2Y') MELVA1=MCHAM1.IELVAL(3) IF (nomid.lesfac(ICOMP).EQ.'C2Z') MELVA1=MCHAM1.IELVAL(3) IF (nomid.lesfac(ICOMP).EQ.'D2X') MELVA1=MCHAM1.IELVAL(3) IF (nomid.lesfac(ICOMP).EQ.'D2Y') MELVA1=MCHAM1.IELVAL(3) IF (nomid.lesfac(ICOMP).EQ.'D2Z') MELVA1=MCHAM1.IELVAL(3) IF (nomid.lesfac(ICOMP).EQ.'E2X') MELVA1=MCHAM1.IELVAL(3) IF (nomid.lesfac(ICOMP).EQ.'E2Y') MELVA1=MCHAM1.IELVAL(3) IF (nomid.lesfac(ICOMP).EQ.'E2Z') MELVA1=MCHAM1.IELVAL(3) SEGACT MELVA1 C==================== c creation d'un maillage de multiplicateurs de lagranges enrichis C==================== NBNN=NUM(/1)+1 NBELEM=NUM(/2) NBSOUS=0 NBREF=0 SEGINI, IPT4 IPT4.ITYPEL=22 IELENR=0 c++++ BOUCLE sur les éléments de ipt5 DO 2 JELEM=1,IPT5.NUM(/2) NEXIST=0 ipt4.icolor(jelem)=IPT5.icolor(jelem) JNUM = IPT5.NUM(1,JELEM) c+++ Recherche d'une valeur non nulle du champ d'enrichissement VENR1 = MELVA1.VELCHE(1,JELEM) C On prend les elements dont le hanging node est enrichi IF (VENR1.GT.0) THEN NEXIST=NEXIST+1 C On prend les element dont tout les autres noeuds sont enrichis ELSE DO 21 JNOEUD= 2 , IPT5.NUM(/1) VENR1 = MELVA1.VELCHE(JNOEUD,JELEM) IF (VENR1.eq.0) GOTO 21 NEXIST=NEXIST+1 21 CONTINUE ENDIF IF (nexist.eq.0) GOTO 2 IELENR= IELENR+1 C On recopie dans IPT4 les elements de ipt5 sur lequel on veux c imposer une relation de compatibilité DO 22 I=1,IPT5.NUM(/1) IPT4.NUM(I+1,IELENR)=IPT5.NUM(I,JELEM) 22 CONTINUE 2 CONTINUE NBELEM=IELENR SEGADJ IPT4 IF (ielenr.eq.0) goto 1 C======================================================================= C creation n'un nouveau noeud pour supporter chaque multiplicateur de lagrange C======================================================================= SEGACT,MCOORD*MOD NBPT1=nbpts NBPTS=NBPT1+IELENR SEGADJ,MCOORD DO 3 J=1,IPT4.NUM(/2) NGLOB=(NBPT1+J-1)*(IDIM+1) C remplissage des coordonees des nouveux points DO 31 ID= 1,IDIM XCOOR(NGLOB+ID)=XCOOR((IPT4.NUM(2,J)-1)*(IDIM+1)+ID) 31 CONTINUE IPT4.NUM(1,J) = NBPT1 + J 3 CONTINUE SEGACT,MCOORD C==================== C *** SEGMENT XMATRI C==================== NLIGRD=IPT4.NUM(/1) NLIGRP=NLIGRD NELRIG=IPT4.NUM(/2) rigrel=0 SEGINI, XMATRI c++++ BOUCLE sur les éléments de ipt4 DO 4 IELEM=1,NELRIG RE(1,2,IELEM)=-1. RE(2,1,IELEM)=-1. DO 41 ICAZ=3,NLIGRD RE(1,ICAZ,IELEM)=XCOEFF(IDEBUT+ICAZ) RE(ICAZ,1,IELEM)=RE(1,ICAZ,IELEM) 41 CONTINUE 4 CONTINUE C write(*,*) 'COMPOSANTE FACULTATIVE DU SURE :' C write(*,*) (nomid.lesfac(ICOMP)) C write(*,*) 'MATRICE elementaire :' C DO 6666 I=1,NLIGRD C write(*,*) (RE(i,iou,1), iou=1,NLIGRD) C 6666 CONTINUE C==================== C *** SEGMENT DESCR C==================== NEXIST=0 DO 5 ICO1=1,LNOMDD IF (NOMDD(ICO1).EQ.nomid.lesfac(ICOMP)) NEXIST = ICO1 5 CONTINUE IF (NEXIST.EQ.0) THEN CALL ERREUR(837) ENDIF SEGINI, DESCR LISINC(1)='LX ' LISDUA(1)='FLX ' NOELEP(1)=1 NOELED(1)=1 DO 6 ICO2=2,NLIGRD LISINC(ICO2)=NOMDD(NEXIST) LISDUA(ICO2)=NOMDU(NEXIST) NOELEP(ico2)=ico2 NOELED(ico2)=ico2 6 CONTINUE C==================== C *** SEGMENT MRIGID C==================== MRIGID=IPOI6 SEGACT, MRIGID*mod C Ajustement du segment rigidite nrigel=IRIGEL(/2)+1 SEGADJ, MRIGID isou = isou+1 C* ICHOLE=0 C* IMGEO1=0 C* IMGEO2=0 C* IFORIG=IFOUR C* ISUPEQ=0 COERIG(isou)=1. IRIGEL(1,isou)=IPT4 IRIGEL(2,isou)=0 IRIGEL(3,isou)=DESCR IRIGEL(4,isou)=XMATRI IRIGEL(5,isou)=0 IRIGEL(6,isou)=0 IRIGEL(7,isou)=0 IRIGEL(8,isou)=0 C SEGDES, MRIGID SEGDES, DESCR SEGDES, XMATRI SEGDES, IPT4 C********************************************************************** C FIN Boucle sur les composantes primales facultatives du sure C********************************************************************** 1 CONTINUE SEGDES, nomid RETURN END