Sources Esope | Cast3M

echi1
C ECHI1     SOURCE    CB215821  20/11/25    13:26:52     10792          
      SUBROUTINE ECHI1(IKAS,IVOL1,MTAB1,MTAB2,MPOVA1,MPOVA2,IKH,IKT,
     &                 MELEMD,MELEVF,MLENTI,MLENT1,NOMD)
C-----------------------------------------------------------------------
C Discrétisation de l'opérateur ECHIMP en explicite EFM1 et VF, le
C coeff d'échange étant un SCAL ou CHPO CENTRE, le champ exterieur
C un SCAL, un CHPO CENTRE ou un CHPO SOMMET.
C-----------------------------------------------------------------------
C
C--------------------
C Paramètres Entrée :
C--------------------
C
C E/  IKAS    : Type de situation à traiter (1=EF, 2 ou 3=VF)
C E/  IVOL1   : Type d'échange (0=surfacique, 1=volumique)
C E/  MTAB1   : Pointeur de la table EQEX
C E/  MTAB2   : Pointeur de la table DOMAINE locale
C E/  MPOVA1  : MPOVAL des valeurs du coefficient d'échange
C E/  MPOVA2  : MPOVAL des valeurs du champ exterieur
C E/  IKH     : Forme originel du coefficient d'échange
C               (0=CHPO CENTRE, 1=FLOTTANT)
C E/  IKT     : Forme originel du champ exterieur
C               (0=CHPO CENTRE, 1=FLOTTANT, 4=CHPO SOMMET)
C E/  MELEMD  : Pointeur du spg de l'inconnue
C E/  MELEVF  : Pointeur vers les points CENTRE du maillage volumique
C               en correspondance avec les points CENTRE surfacique
C               (Utilisé en Formulation VF et échange surfacique)
C E/  MLENTI  : Correspondance numéotation globale/numérotation locale
C               LECT(I)=J : le point numéro I est le Jième de MELEMD
C E/  MLENT1  : Idem MLENTI pour le spg du champ exterieur
C               (Utilisé lorsque le champ exterieur est au SOMMET)
C E/  NOMD    : Nom de l'inconnue
C
C------------------
C Champs calculés :
C------------------
C
C     MPOVA3  : MPOVAL des valeurs de la matrice diagonale
C               Stocké à l'indice NOMD de la table KIZG1
C     MPOVA4  : MPOVAL des valeurs du second membre
C               Stocké à l'indice NOMD de la table KIZG
C
C-----------------------------------------------------------------------
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C
 
-INC PPARAM
-INC CCOPTIO
-INC SMCHPOI
-INC SMCHAML
-INC SMMATRIK
-INC SMELEME
      POINTEUR MELEMD.MELEME
-INC SMLENTI
C
      CHARACTER*8 NOMD,TYPE,TYPC,TYPS
C
C- Initialisations
C
      NBCOMP = 1
      IF (IKAS.EQ.1) THEN
         TYPS = 'SOMMET  '
      ELSE
         TYPS = 'CENTRE  '
      ENDIF
C
      NRIGE=7
      NKID =9
      NKMT =7
      NMATRI=1
      SEGINI MATRIK
      IRIGEL(1,1)=MELEMD
      IRIGEL(2,1)=MELEMD
      IRIGEL(7,1)=5
      NBME=1
      NBSOUS=1
      SEGINI IMATRI
      IRIGEL(4,1)=IMATRI
      SEGACT MELEMD
      KSPGP=MELEMD
      KSPGD=MELEMD
      LISPRI(1)=NOMD
      LISDUA(1)=NOMD
      NP=1
      MP=1
      NBEL=MELEMD.NUM(/2)
      SEGINI IZAFM
      LIZAFM(1,1)=IZAFM
      LIZAFM(1,1)=IZAFM
      SEGDES MATRIK,IMATRI
         CALL KRCHPT(TYPS,MELEMD,NBCOMP,IZG,NOMD(1:4))
      CALL LICHTM(IZG,MPOVA4,TYPC,IGEOM)
C
C- Activation
C
      SEGACT MPOVA1
      SEGACT MPOVA2
      SEGACT MLENTI
      SEGACT MLENT1
C
C----------------------------------------------------------------------
C- Traitement d'une formulation EF ou EMM1 explicite, le champ
C- exterieur étant 1) un SCAL ou un CHPO CENTRE, 2) un CHPO SOMMET.
C- Dans les deux cas, l'indice XXPSOML de la table domaine local suffit
C- (contient l'intégrale sur chaque élément des fonctions de forme).
C- En effet, en explicite les matrices masses sont condensées (EF=EFM1)
C----------------------------------------------------------------------
C
      IF (IKAS.EQ.1) THEN
         CALL LEKTAB(MTAB2,'MAILLAGE',MELEME)
         CALL LEKTAB(MTAB2,'XXPSOML ',MCHELM)
         IF (IERR.NE.0) RETURN
         SEGACT MCHELM
         SEGACT MELEME
         NBSOUS = LISOUS(/1)
         IF (NBSOUS.EQ.0) NBSOUS=1
         NUTOEL = 0
         DO 30 L=1,NBSOUS
            IPT1 = MELEME
            IF (NBSOUS.NE.1) IPT1=LISOUS(L)
            SEGACT IPT1
            NP     = IPT1.NUM(/1)
            NBEL   = IPT1.NUM(/2)
            MCHAML = ICHAML(L)
            SEGACT MCHAML
            MELVAL = IELVAL(1)
            SEGACT MELVAL
            DO 20 K=1,NBEL
               NK   = NUTOEL + K
               KPOS = 1 + (1-IKH)*(NK-1)
               DO 10 I=1,NP
                  II   = IPT1.NUM(I,K)
                  IPOS = LECT(II)
                  VAL1 = MPOVA1.VPOCHA(KPOS,1)*VELCHE(I,K)
                  AM(IPOS,1,1)          = AM(IPOS,1,1)          + VAL1
                  IF (IKT.EQ.4) THEN
                     JPOS = MLENT1.LECT(II)
                  ELSE
                     JPOS = 1 + (1-IKT)*(NK-1)
                  ENDIF
                  VAL2 = VAL1 * MPOVA2.VPOCHA(JPOS,1)
                  MPOVA4.VPOCHA(IPOS,1) = MPOVA4.VPOCHA(IPOS,1) + VAL2
 10            CONTINUE
 20         CONTINUE
            SEGDES IPT1
            SEGDES MCHAML,MELVAL
            NUTOEL = NUTOEL + NBEL
 30      CONTINUE
        IF (NBSOUS.NE.1) SEGDES MELEME
        SEGDES MCHELM
C
C----------------------------------------------------------------------
C- Traitement d'une formulation VF Explicite, le champ exterieur étant
C- 1) un SCAL ou un CHPO CENTRE, 2) un CHPO SOMMET.
C-
C- Le traitement différe pour le second membre :
C- Dans le premier cas, l'indice XXVOLUM de la table domaine local,
C- utilisé pour calculer la matrice suffit (contient le volume de
C- chaque élément). Dans le deuxième cas, on a également besoin de
C- l'indice XXPSOML que l'on sature par le champ exterieur au sommet.
C-
C- Le spg des champoints résultats dépend du type d'échange :
C- Lorsque l'échange est volumique, les points CENTRE de la table
C- domaine local sont à considerer. En surfacique, on a construit
C- la correspondance entre centre(volume)-centre(surface); les CENTRE
C- des volumes concernés sont rangés dans MELEVF.
C----------------------------------------------------------------------
C
      ELSE
         CALL LEKTAB(MTAB2,'XXVOLUM ',MCHPOI)
         CALL LICHTL(MCHPOI,MPOVA5,TYPC,MELEMC)
         IF (IVOL1.EQ.0) THEN
            IPT2 = MELEVF
         ELSE
            IPT2 = MELEMC
         ENDIF
         SEGACT IPT2
         IF (IKT.EQ.0 .OR. IKT.EQ.1) THEN
            NBEL = IPT2.NUM(/2)
            DO 40 K=1,NBEL
               IPOS = LECT(IPT2.NUM(1,K))
               KPOS = 1 + (1-IKH)*(K-1)
               KTEX = 1 + (1-IKT)*(K-1)
               VAL1 = MPOVA1.VPOCHA(KPOS,1) * MPOVA5.VPOCHA(K,1)
               AM(IPOS,1,1)          = AM(IPOS,1,1)          + VAL1
               VAL2 = MPOVA2.VPOCHA(KTEX,1) * VAL1
               MPOVA4.VPOCHA(IPOS,1) = MPOVA4.VPOCHA(IPOS,1) + VAL2
 40         CONTINUE
         ELSE
            CALL LEKTAB(MTAB2,'MAILLAGE',MELEME)
            CALL LEKTAB(MTAB2,'XXPSOML ',MCHELM)
            IF (IERR.NE.0) RETURN
            SEGACT MCHELM
            SEGACT MELEME
            NBSOUS = LISOUS(/1)
            IF (NBSOUS.EQ.0) NBSOUS=1
            NUTOEL = 0
            DO 70 L=1,NBSOUS
               IPT1 = MELEME
               IF (NBSOUS.NE.1) IPT1=LISOUS(L)
               SEGACT IPT1
               NP     = IPT1.NUM(/1)
               NBEL   = IPT1.NUM(/2)
               MCHAML = ICHAML(L)
               SEGACT MCHAML
               MELVAL = IELVAL(1)
               SEGACT MELVAL
               DO 60 K=1,NBEL
                  NK   = NUTOEL + K
                  IPOS = LECT(IPT2.NUM(1,NK))
                  KPOS = 1 + (1-IKH)*(NK-1)
                  VAL1 = MPOVA1.VPOCHA(KPOS,1) * MPOVA5.VPOCHA(NK,1)
                  AM(IPOS,1,1)          = AM(IPOS,1,1)          + VAL1
                  VAL2 = 0.D0
                  DO 50 I=1,NP
                     II   = IPT1.NUM(I,K)
                     JPOS = MLENT1.LECT(II)
                     VAL2 = VAL2 + MPOVA1.VPOCHA(KPOS,1)
     &                    * MPOVA2.VPOCHA(JPOS,1) * VELCHE(I,K)
 50               CONTINUE
                  MPOVA4.VPOCHA(IPOS,1) = MPOVA4.VPOCHA(IPOS,1) + VAL2
 60            CONTINUE
               NUTOEL = NUTOEL + NBEL
               SEGDES IPT1
               SEGDES MELVAL,MCHAML
 70         CONTINUE
            IF (NBSOUS.NE.1) SEGDES MELEME
            SEGDES MCHELM
         ENDIF
         SEGDES IPT2
         SEGDES MPOVA5
      ENDIF
C
C- Désactivation
C
      SEGDES IZAFM
      SEGDES MPOVA1
      SEGDES MPOVA2
      SEGDES MPOVA4
      SEGSUP MLENTI
      SEGSUP MLENT1
C
      CALL ECROBJ('MATRIK',MATRIK)
      CALL ECROBJ('CHPOINT',IZG)
 
      RETURN
      END