Télécharger rigsux.eso

Retour à la liste

rigsux
C RIGSUX    SOURCE    CB215821  24/04/12    21:17:12     11897          
 
      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)
         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
 
 
 
 
 
 

© Cast3M 2003 - Tous droits réservés.
Mentions légales