Sources Esope | Cast3M

tconvd
C TCONVD    SOURCE    FANDEUR   22/01/03    21:15:50     11237          
      SUBROUTINE TCONVD (MRIGID,IPTCEL,LPRIMA,NOMPR1,NOMDU1,IPJUCE,
     &                   MPOVA1,IPT1,IPTJUN,MPOVA2)
C
C***********************************************************************
C
C FONCTION:
C ---------
C
C     Création de la matrice de RIGIDITE liée à la discrétisation
C     en "0D/1D" sur des éléments de type POINT.
C
C     (appelée par la subroutine TOCONV)
C
C AUTEUR, DATE DE CREATION:
C -------------------------
C
C     Laurent DADA      décembre 1996
C
C
C LANGAGE:
C --------
C
C     ESOPE + FORTRAN77
C
C***********************************************************************
C
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C
 
-INC PPARAM
-INC CCOPTIO
-INC CCGEOME
-INC SMCOORD
-INC SMCHPOI
-INC SMELEME
      POINTEUR IPTCEL.MELEME,IPTJUN.MELEME,IPJUCE.MELEME
-INC SMRIGID
C
      SEGMENT REDI
        INTEGER ORDR1(NNGOT)
      ENDSEGMENT
C
      CHARACTER*8 TYPE,MOTI,MOT1,NOMPR1,NOMDU1,NOSUP1,NOSUD1,NOMMU1
      CHARACTER*7 NAMT1
      CHARACTER*8 NOMFL1,NOSUF1
      LOGICAL     LPRIMA
C
C
C Création du support géométrique pour la RIGIDITE
C (maillage de type SUPER-ELEMENT)
C
      NNGOT  = nbpts
      SEGINI REDI
C
C On transforme le maillage de POI1 du support de l'inconnue CELL
C en un maillage de type SUPER-ELEMENT.
C
      SEGACT IPTCEL
      IF (IPTCEL.ITYPEL.NE.1)   CALL CHANGE (IPTCEL,1)
      SEGACT IPTCEL
C
      NBNN   = IPTCEL.NUM(/2)
      NBSOUS = 0
      NBREF  = 0
      NBELEM = 1
      SEGINI MELEME
      ICOLOR(1) = IDCOUL
      ITYPEL    = 28
      DO 40 I40=1,NBNN
        NUM(I40,1)        = IPTCEL.NUM(1,I40)
        ORDR1(NUM(I40,1)) = I40
 40   CONTINUE
C
      SEGDES IPTCEL
C
C Création de la RIGIDITE
C
      NRIGE  = 7
      NRIGEL = 1
      SEGINI MRIGID
      IPRIGI = MRIGID
C
      MTYMAT = 'RIGIDITE'
      IFORIG = IFOUR
      ICHOLE = 0
      IMGEO1 = 0
      IMGEO2 = 0
      ISUPEQ = 0
      COERIG(1)   = 1.D0
      IRIGEL(1,1) = MELEME
      IRIGEL(2,1) = 0
      IRIGEL(5,1) = NIFOUR
      IRIGEL(6,1) = 0
      IRIGEL(7,1) = 2
C
C Remplissage du descripteur de l'objet RIGIDITE
C
      IF (LPRIMA) THEN
        NLIGRP = NBNN
        NLIGRD = NBNN
        SEGINI DESCR
        IRIGEL(3,1) = DESCR
        DO 10 I10=1,NBNN
          NOELEP(I10) = I10
          LISINC(I10) = NOMPR1
10      CONTINUE
        DO 11 I11=1,NBNN
          NOELED(I11) = I11
          LISDUA(I11) = NOMDU1
11      CONTINUE
      ELSE
        NLIGRP = NBNN
        NLIGRD = NBNN
        SEGINI DESCR
        IRIGEL(3,1) = DESCR
        DO 20 I20=1,NBNN
          NOELEP(I20) = I20
          LISINC(I20) = NOMDU1
          NOELED(I20) = I20
          LISDUA(I20) = NOMDU1
20      CONTINUE
      ENDIF
C
      SEGDES DESCR
C
      NELRIG = 1
*      SEGINI IMATRI
      SEGINI XMATRI
C
*      IMATTT(1)   = XMATRI
      IRIGEL(4,1) = xMATRI
       xmatri.symre=2
*      SEGDES IMATRI
C
C Remplissage de la matrice élémentaire
C
      SEGACT IPJUCE
      NBEJC1 = IPJUCE.NUM(/2)
C activation du maillage et des valeurs du CHPOINT MULT1
      SEGACT IPT1
      SEGACT MPOVA1
C petit controle du support du champ MULT1
      NBEL1 = IPT1.NUM(/2)
      IF (NBEL1.NE.NBNN) THEN
        CALL ERREUR (348)
        SEGDES IPT1
        SEGDES MPOVA1
        SEGDES IPJUCE
        SEGSUP MELEME
        SEGSUP XMATRI
        SEGSUP MRIGID
        SEGSUP REDI
        RETURN
      ENDIF
C
C
C
C activation du maillage et des valeurs du CHPOINT FLUX
      SEGACT IPTJUN
      NBNNJU = IPTJUN.NUM(/2)
      SEGACT MPOVA2
C mise à 0.d0 de la matrice élémentaire
      DO 30 I30=1,NBNN
        DO 301 I301=1,NBNN
          RE(I30,I301,1) = 0.D0
 301    CONTINUE
 30   CONTINUE
C
C balayage sur les SEG3 du maillage des connectivités 'JUNCEL'
      DO 32 I32=1,NBEJC1
        NPT1  = IPJUCE.NUM(1,I32)
        NPTF1 = IPJUCE.NUM(2,I32)
        NPT2  = IPJUCE.NUM(3,I32)
C récupération de la valeur du débit de masse au point NPTF1
C et des valeurs du champ multiplicateur aux points NPT1 et NPT2
C balayage sur les points du CHPOINT FLUX
        XVALF1 = 0.D0
        DO 321 I321=1,NBNNJU
          IF (NPTF1.EQ.(IPTJUN.NUM(1,I321))) THEN
            XVALF1 = MPOVA2.VPOCHA(I321,1)
            GOTO 322
          ENDIF
 321    CONTINUE
 322    CONTINUE
C balayage sur les points du CHPOINT MULT1
        XVALM1 = 0.D0
        XVALM2 = 0.D0
        DO 323 I323=1,NBEL1
        IF (NPT1.EQ.(IPT1.NUM(1,I323))) XVALM1 = MPOVA1.VPOCHA(I323,1)
        IF (NPT2.EQ.(IPT1.NUM(1,I323))) XVALM2 = MPOVA1.VPOCHA(I323,1)
 323    CONTINUE
C quantités disparaissant ou apparaissant dans les deux compartiments
        XMASS1 =  0.5D0 * XVALM1 * (ABS(XVALF1)+XVALF1)
        XMASS2 =  0.5D0 * XVALM2 * (ABS(XVALF1)-XVALF1)
C positions dans la matrice élémentaire
        IDUA1 = ORDR1(NPT1)
        IDUA2 = ORDR1(NPT2)
C remplissage de la matrice
        RE(IDUA1,IDUA1,1) = RE(IDUA1,IDUA1,1) + XMASS1
        RE(IDUA1,IDUA2,1) =           -1.D0 * XMASS2
        RE(IDUA2,IDUA1,1) =           -1.D0 * XMASS1
        RE(IDUA2,IDUA2,1) = RE(IDUA2,IDUA2,1) + XMASS2
 32   CONTINUE
C
      SEGDES IPTJUN
      SEGDES MPOVA2
C
      SEGDES IPT1
      SEGDES MPOVA1
C
      SEGDES XMATRI
      SEGDES IPJUCE
C
      SEGDES MELEME
C
      SEGDES MRIGID
      SEGSUP REDI
C
      END