Sources Esope | Cast3M

melbou
C MELBOU    SOURCE    PV090527  25/01/07    14:42:50     12115          
      SUBROUTINE MELBOU(MTABD,MCHELS,MCHEL1,MCHEL2,MCHEL3)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C***********************************************************************
C
C  Ce Sp crée un MCHAML résultat Boussinesq
C Le MCHAML en retour est jetable et est calcule aux pts d'integrations
C Quel que soit le type de l'objet récupéré, l'objet retourné est un
C MCHAML.
C----------------------------------------------------------------------
C
C
C----------------------------------------------------------------------
C HISTORIQUE : 20/10/01 : Création
C
C HISTORIQUE :
C
C
C---------------------------
C Paramètres Entrée/Sortie :
C---------------------------
C
C E/  MTABD  : Objet model de la zone
C----------------------------------------------------------------------
C************************************************************************
 
-INC SIZFFB
      POINTEUR IZF1.IZFFM,IZH2.IZHR,IZFD.IZFFM
-INC SMCHAML
-INC SMELEME
-INC PPARAM
-INC CCOPTIO
-INC CCGEOME
-INC SMCOORD
      CHARACTER*8 NOM0
C*****************************************************************************
CMELBOU
C     write(6,*)' DEBUT MELBOU '
      XPETI=1.D-30
      IAXI=0
      IF(IFOMOD.EQ.0)IAXI=2
C
      CALL LEKTAB(MTABD,'MAILLAGE',MELEME)
 
      SEGACT MELEME
 
      L1=72
      N1=MAX(1,LISOUS(/1))
      N2=1
      N3=6
      SEGINI MCHELM
 
C-------------------------------------------------------------------------
 
      SEGACT MCHEL1,MCHEL2,MCHEL3
 
      DO 191 L=1,MAX(1,LISOUS(/1))
      IPT1=MELEME
      IF(LISOUS(/1).NE.0)IPT1=LISOUS(L)
      SEGACT IPT1
 
      NOM0 = NOMS(IPT1.ITYPEL)//'    '
      CALL KALPBG(NOM0,'FONFORM ',IZFFM)
      SEGACT IZFFM
      IZHR=KZHR(1)
      IZF1=KTP(1)
      IZH2=KZHR(2)
      SEGACT IZHR*MOD
 
      NES=GR(/1)
      NPG=GR(/3)
 
      NBNN  =IPT1.NUM(/1)
      NBELEM=IPT1.NUM(/2)
      SEGINI MCHAML
 
      N1PTEL=NPG*IDIM
      N1EL  =NBELEM
      N2PTEL=0
      N2EL=0
      IMACHE(L)=IPT1
      ICHAML(L)=MCHAML
 
      SEGINI MELVAL
      IELVAL(1)=MELVAL
 
 
        MCHAM1=MCHEL1.ICHAML(L)
        SEGACT MCHAM1
        MELVA1=MCHAM1.IELVAL(1)
        SEGACT MELVA1
        NIL1=MELVA1.VELCHE(/2)
        IF(NIL1.EQ.1)THEN
        IK1=1
        ELSE
        IK1=0
        ENDIF
        MCHAM2=MCHEL2.ICHAML(L)
        SEGACT MCHAM2
        MELVA2=MCHAM2.IELVAL(1)
        SEGACT MELVA2
        NIL2=MELVA2.VELCHE(/2)
        IF(NIL2.EQ.1)THEN
        IK2=1
        ELSE
        IK2=0
        ENDIF
 
        MCHAM3=MCHEL3.ICHAML(L)
        SEGACT MCHAM3
        MELVA3=MCHAM3.IELVAL(1)
        SEGACT MELVA3
        NIL3=MELVA3.VELCHE(/2)
        IF(NIL3.EQ.1)THEN
        IK3=1
        ELSE
        IK3=0
        ENDIF
 
      DO 192 K=1,N1EL
        NK1=K + IK1*(1 - K)
        NK2=K + IK2*(1 - K)
        NK3=K + IK3*(1 - K)
      DO 194 N=1,IDIM
      DO 194 LG=1,NPG
      VELCHE(LG+(N-1)*NPG,K)=MELVA1.VELCHE(LG+(N-1)*NPG,NK1)*
     & (MELVA3.VELCHE(LG,NK3) - MELVA2.VELCHE(LG,NK2))
 194  CONTINUE
 192  CONTINUE
 
 
      SEGSUP MELVA1,MELVA2,MELVA3
      SEGSUP MCHAM1,MCHAM2,MCHAM3
 
      SEGDES MELVAL
      SEGDES IPT1,MCHAML
      SEGSUP IZFFM,IZHR,IZF1,IZH2
 191  CONTINUE
      SEGDES MCHELM,MELEME
      SEGSUP MCHEL1,MCHEL2,MCHEL3
      MCHELS=MCHELM
 
C*************************************************************************
 
c     write(6,*)' FIN MELBOU '
      RETURN
 1001 FORMAT(20(1X,I5))
 1002 FORMAT(10(1X,1PE11.4))
      END