Télécharger melbou.eso

Retour à la liste

Numérotation des lignes :

  1. C MELBOU SOURCE BP208322 16/11/18 21:19:10 9177
  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
  42. CALL LEKTAB(MTABD,'MAILLAGE',MELEME)
  43.  
  44. SEGACT MELEME
  45.  
  46. L1=72
  47. N1=MAX(1,LISOUS(/1))
  48. N2=1
  49. N3=6
  50. SEGINI MCHELM
  51.  
  52. C-------------------------------------------------------------------------
  53.  
  54. SEGACT MCHEL1,MCHEL2,MCHEL3
  55.  
  56. DO 191 L=1,MAX(1,LISOUS(/1))
  57. IPT1=MELEME
  58. IF(LISOUS(/1).NE.0)IPT1=LISOUS(L)
  59. SEGACT IPT1
  60.  
  61. NOM0 = NOMS(IPT1.ITYPEL)//' '
  62. CALL KALPBG(NOM0,'FONFORM ',IZFFM)
  63. SEGACT IZFFM
  64. IZHR=KZHR(1)
  65. IZF1=KTP(1)
  66. IZH2=KZHR(2)
  67. SEGACT IZHR*MOD
  68.  
  69. NES=GR(/1)
  70. NPG=GR(/3)
  71.  
  72. NBNN =IPT1.NUM(/1)
  73. NBELEM=IPT1.NUM(/2)
  74. SEGINI MCHAML
  75.  
  76. N1PTEL=NPG*IDIM
  77. N1EL =NBELEM
  78. N2PTEL=0
  79. N2EL=0
  80. IMACHE(L)=IPT1
  81. ICHAML(L)=MCHAML
  82.  
  83. SEGINI MELVAL
  84. IELVAL(1)=MELVAL
  85.  
  86.  
  87. MCHAM1=MCHEL1.ICHAML(L)
  88. SEGACT MCHAM1
  89. MELVA1=MCHAM1.IELVAL(1)
  90. SEGACT MELVA1
  91. NIL1=MELVA1.VELCHE(/2)
  92. IF(NIL1.EQ.1)THEN
  93. IK1=1
  94. ELSE
  95. IK1=0
  96. ENDIF
  97. MCHAM2=MCHEL2.ICHAML(L)
  98. SEGACT MCHAM2
  99. MELVA2=MCHAM2.IELVAL(1)
  100. SEGACT MELVA2
  101. NIL2=MELVA2.VELCHE(/2)
  102. IF(NIL2.EQ.1)THEN
  103. IK2=1
  104. ELSE
  105. IK2=0
  106. ENDIF
  107.  
  108. MCHAM3=MCHEL3.ICHAML(L)
  109. SEGACT MCHAM3
  110. MELVA3=MCHAM3.IELVAL(1)
  111. SEGACT MELVA3
  112. NIL3=MELVA3.VELCHE(/2)
  113. IF(NIL3.EQ.1)THEN
  114. IK3=1
  115. ELSE
  116. IK3=0
  117. ENDIF
  118.  
  119. DO 192 K=1,N1EL
  120. NK1=K + IK1*(1 - K)
  121. NK2=K + IK2*(1 - K)
  122. NK3=K + IK3*(1 - K)
  123. DO 194 N=1,IDIM
  124. DO 194 LG=1,NPG
  125. VELCHE(LG+(N-1)*NPG,K)=MELVA1.VELCHE(LG+(N-1)*NPG,NK1)*
  126. & (MELVA3.VELCHE(LG,NK3) - MELVA2.VELCHE(LG,NK2))
  127. 194 CONTINUE
  128. 192 CONTINUE
  129.  
  130.  
  131. SEGSUP MELVA1,MELVA2,MELVA3
  132. SEGSUP MCHAM1,MCHAM2,MCHAM3
  133.  
  134. SEGDES MELVAL
  135. SEGDES IPT1,MCHAML
  136. SEGSUP IZFFM,IZHR,IZF1,IZH2
  137. 191 CONTINUE
  138. SEGDES MCHELM,MELEME
  139. SEGSUP MCHEL1,MCHEL2,MCHEL3
  140. MCHELS=MCHELM
  141.  
  142. C*************************************************************************
  143.  
  144. c write(6,*)' FIN MELBOU '
  145. RETURN
  146. 1001 FORMAT(20(1X,I5))
  147. 1002 FORMAT(10(1X,1PE11.4))
  148. END
  149.  
  150.  
  151.  
  152.  
  153.  
  154.  
  155.  
  156.  
  157.  
  158.  
  159.  
  160.  

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