Esope source files

   1 : C MELBOU    SOURCE    MAGN      10/05/18    21:16:21     6675           
   2 :       SUBROUTINE MELBOU(MTABD,MCHELS,MCHEL1,MCHEL2,MCHEL3)
   3 :       IMPLICIT INTEGER(I-N)
   4 :       IMPLICIT REAL*8 (A-H,O-Z)                                                 
   5 : C***********************************************************************
   6 : C
   7 : C  Ce Sp crée un MCHAML résultat Boussinesq
   8 : C Le MCHAML en retour est jetable et est calcule aux pts d'integrations
   9 : C Quel que soit le type de l'objet récupéré, l'objet retourné est un
  10 : C MCHAML. 
  11 : C----------------------------------------------------------------------
  12 : C
  13 : C
  14 : C----------------------------------------------------------------------
  15 : C HISTORIQUE : 20/10/01 : Création
  16 : C
  17 : C HISTORIQUE :
  18 : C                                                                               
  19 : C                                                                               
  20 : C---------------------------
  21 : C Paramètres Entrée/Sortie :
  22 : C---------------------------
  23 : C                                                                               
  24 : C E/  MTABD  : Objet model de la zone
  25 : C----------------------------------------------------------------------
  26 : C************************************************************************       
  27 : 
  28 : -INC SIZFFB
  29 :       POINTEUR IZF1.IZFFM,IZH2.IZHR,IZFD.IZFFM
  30 : -INC SMCHAML
  31 : -INC SMELEME
  32 : -INC CCOPTIO
  33 : -INC CCGEOME
  34 :       CHARACTER*8 NOM0
  35 : C*****************************************************************************
  36 : CMELBOU
  37 : C     write(6,*)' DEBUT MELBOU '
  38 :       XPETI=1.D-30
  39 :       IAXI=0
  40 :       IF(IFOMOD.EQ.0)IAXI=2
  41 : C                                                                               
  41 :       CALL LEKTAB(MTABD,'MAILLAGE',MELEME)
  42 : 
  43 :       SEGACT MELEME
  44 : 
  45 :       L1=72
  46 :       N1=MAX(1,LISOUS(/1))
  47 :       N2=1
  48 :       N3=6
  49 :       SEGINI MCHELM
  50 : 
  51 : C-------------------------------------------------------------------------
  52 : 
  53 :       SEGACT MCHEL1,MCHEL2,MCHEL3
  54 : 
  55 :       DO 191 L=1,MAX(1,LISOUS(/1))
  56 :       IPT1=MELEME
  57 :       IF(LISOUS(/1).NE.0)IPT1=LISOUS(L)
  58 :       SEGACT IPT1
  59 : 
  60 :       NOM0 = NOMS(IPT1.ITYPEL)//'    '
  60 :       CALL KALPBG(NOM0,'FONFORM ',IZFFM)
  61 :       SEGACT IZFFM
  62 :       IZHR=KZHR(1)
  63 :       IZF1=KTP(1)
  64 :       IZH2=KZHR(2)
  65 :       SEGACT IZHR*MOD
  66 : 
  67 :       NES=GR(/1)
  68 :       NPG=GR(/3)
  69 : 
  70 :       NBNN  =IPT1.NUM(/1)
  71 :       NBELEM=IPT1.NUM(/2)
  72 :       SEGINI MCHAML
  73 : 
  74 :       N1PTEL=NPG*IDIM
  75 :       N1EL  =NBELEM
  76 :       N2PTEL=0
  77 :       N2EL=0
  78 :       IMACHE(L)=IPT1
  79 :       ICHAML(L)=MCHAML
  80 : 
  81 :       SEGINI MELVAL
  82 :       IELVAL(1)=MELVAL
  83 : 
  84 : 
  85 :         MCHAM1=MCHEL1.ICHAML(L)
  86 :         SEGACT MCHAM1
  87 :         MELVA1=MCHAM1.IELVAL(1)
  88 :         SEGACT MELVA1
  89 :         NIL1=MELVA1.VELCHE(/2)
  90 :         IF(NIL1.EQ.1)THEN
  91 :         IK1=1
  92 :         ELSE
  93 :         IK1=0
  94 :         ENDIF
  95 :         MCHAM2=MCHEL2.ICHAML(L)
  96 :         SEGACT MCHAM2
  97 :         MELVA2=MCHAM2.IELVAL(1)
  98 :         SEGACT MELVA2
  99 :         NIL2=MELVA2.VELCHE(/2)
 100 :         IF(NIL2.EQ.1)THEN
 101 :         IK2=1
 102 :         ELSE
 103 :         IK2=0
 104 :         ENDIF
 105 : 
 106 :         MCHAM3=MCHEL3.ICHAML(L)
 107 :         SEGACT MCHAM3
 108 :         MELVA3=MCHAM3.IELVAL(1)
 109 :         SEGACT MELVA3
 110 :         NIL3=MELVA3.VELCHE(/2)
 111 :         IF(NIL3.EQ.1)THEN
 112 :         IK3=1
 113 :         ELSE
 114 :         IK3=0
 115 :         ENDIF
 116 : 
 117 :       DO 192 K=1,N1EL
 118 :         NK1=K + IK1*(1 - K)
 119 :         NK2=K + IK2*(1 - K)
 120 :         NK3=K + IK3*(1 - K)
 121 :       DO 194 N=1,IDIM
 122 :       DO 194 LG=1,NPG
 123 :       VELCHE(LG+(N-1)*NPG,K)=MELVA1.VELCHE(LG+(N-1)*NPG,NK1)*
 124 :      & (MELVA3.VELCHE(LG,NK3) - MELVA2.VELCHE(LG,NK2))
 125 :  194  CONTINUE
 126 :  192  CONTINUE
 127 : 
 128 : 
 129 :       SEGSUP MELVA1,MELVA2,MELVA3
 130 :       SEGSUP MCHAM1,MCHAM2,MCHAM3
 131 : 
 132 :       SEGDES MELVAL
 133 :       SEGDES IPT1,MCHAML
 134 :       SEGSUP IZFFM,IZHR,IZF1,IZH2
 135 :  191  CONTINUE
 136 :       SEGDES MCHELM,MELEME
 137 :       SEGSUP MCHEL1,MCHEL2,MCHEL3
 138 :       MCHELS=MCHELM
 139 : 
 140 : C*************************************************************************
 141 : 
 142 : c     write(6,*)' FIN MELBOU '
 143 :       RETURN
 144 :  1001 FORMAT(20(1X,I5))
 145 :  1002 FORMAT(10(1X,1PE11.4))
 146 :       END
 147 :  
 148 :  
 149 :  
 150 :  
 151 :  
 152 :  
 153 :  
 154 :  
 155 :