Télécharger rlex.eso

Retour à la liste

Numérotation des lignes :

  1. C RLEX SOURCE KK2000 14/04/10 21:15:37 8032
  2. SUBROUTINE RLEX(MCHPOI,MCHPO1,MCHPO2,MCHPO3,MTABD)
  3. C
  4. C Subroutine de reconstruction lineaire exacte d'un
  5. C Champoint centre au sommet des elements.
  6. C
  7. C*********************************************************
  8. C
  9. C Cette subroutine est appelee par KLNO
  10. C
  11. C*********************************************************
  12. C
  13. C Date : 27/11/98
  14. C
  15. C Auteur : R. MOREL DRN/DMT/SEMT/TTMF
  16. C 21.01.04 : A. Beccantini correction E/S
  17. C correction 3D
  18. C
  19. C*********************************************************
  20. C
  21. C ENTREES : MCHPO1 : CHPOINT centre contenant la fonction
  22. C
  23. C MCHPO2 : CHPOINT centre contenant le gradient
  24. C
  25. C MCHPO3 : CHPOINT centre contenant le limiteur
  26. C
  27. C MTABD : Table domaine
  28. C
  29. C SORTIE : MCHPOI : CHPOINT sommet contenant la fonction
  30. C
  31. C*********************************************************
  32. IMPLICIT INTEGER(I-N)
  33. IMPLICIT REAL*8(A-H,O-Z)
  34.  
  35. -INC CCOPTIO
  36. -INC SMCOORD
  37. -INC SMELEME
  38. POINTEUR MELEMS.MELEME,MELEMC.MELEME
  39. -INC SMCHPOI
  40. -INC SMLENTI
  41. -INC SMLMOTS
  42. C
  43. C Declaration
  44. C
  45. INTEGER MTABD, INDIC, NBCOMP, IGEOMB
  46. & , JGN, JGM, NSOM, NBSOUS, L, NP, NEL, J, K
  47. & , ISOM, LSOM, NCENT, NK
  48. REAL*8 XC, YC, ZC, FC, GX, GY, GZ, GLIM, XS, YS, ZS
  49. & , DX, DY, DZ, DF, FS
  50. CHARACTER*4 MOT
  51. CHARACTER*8 TYPC
  52. C
  53. C Lecture des maillages de la table domaine
  54. C Verification que les maillages correspondent
  55. C
  56. CALL LEKTAB(MTABD,'SOMMET',MELEMS)
  57. IF(IERR.NE.0)RETURN
  58. CALL LEKTAB(MTABD,'MAILLAGE',MELEME)
  59. IF(IERR.NE.0)RETURN
  60. CALL LEKTAB(MTABD,'CENTRE',MELEMC)
  61. IF(IERR.NE.0)RETURN
  62. C
  63. C**** We chech the geom. support of MCHPOi
  64. C
  65. INDIC = 1
  66. NBCOMP = 1
  67. MOT = 'SCAL'
  68. CALL QUEPOI(MCHPO1, MELEMC, INDIC, NBCOMP, MOT)
  69. IF(IERR.NE.0)RETURN
  70. C
  71. JGN = 4
  72. JGM = IDIM
  73. SEGINI MLMOTS
  74. MLMOTS.MOTS(1) = 'P1DX'
  75. MLMOTS.MOTS(2) = 'P1DY'
  76. IF(IDIM .EQ. 3) MLMOTS.MOTS(3) = 'P1DZ'
  77. CALL QUEPO1(MCHPO2, MELEMC, MLMOTS)
  78. IF(IERR.NE.0)RETURN
  79. SEGSUP MLMOTS
  80. C
  81. INDIC = 1
  82. NBCOMP = 1
  83. MOT = 'P1'
  84. CALL QUEPOI(MCHPO3, MELEMC, INDIC, NBCOMP, MOT)
  85. IF(IERR.NE.0)RETURN
  86. C
  87. C**** We read the function
  88. C
  89. CALL LICHT(MCHPO1,MPOVA1,TYPC,IGEOMB)
  90. C In LICHT, SEGACT MPOVA1
  91. IF(IERR.NE.0)RETURN
  92. C
  93. CALL KRIPAD(MELEMS,MLENTI)
  94. IF(IERR.NE.0)RETURN
  95. C In KRIPAD, SEGINI MLENTI
  96. C
  97. C Lecture du gradient
  98. C
  99. CALL LICHT(MCHPO2,MPOVA2,TYPC,IGEOMB)
  100. C In LICHT, SEGACT MPOVA2
  101. IF(IERR.NE.0) RETURN
  102. C
  103. C Lecture du limiteur
  104. C
  105. CALL LICHT(MCHPO3,MPOVA3,TYPC,IGEOMB)
  106. C In LICHT, SEGACT MPOVA3
  107. C
  108. C Creation du chpoint sommet
  109. C
  110. JGN = 4
  111. JGM = 1
  112. SEGINI MLMOTS
  113. MLMOTS.MOTS(1) = 'SCAL'
  114. TYPC = 'CHPOINT '
  115. CALL KRCHP1(TYPC, MELEMS, MCHPOI, MLMOTS)
  116. IF(IERR.NE.0) RETURN
  117. SEGSUP MLMOTS
  118. CALL LICHT(MCHPOI,MPOVAL,TYPC,IGEOMB)
  119. C In LICHT, SEGACT MPOVAL
  120. IF(IERR.NE.0) RETURN
  121.  
  122. NSOM=MPOVAL.VPOCHA(/1)
  123. C MPOVA4 contient le nombre de centre contribuant a un sommet
  124. SEGINI, MPOVA4=MPOVAL
  125. C
  126. CC
  127. C On fait une boucle sur les elements du maillage
  128. C A chaque sommet on ajoute la contribution du centre de
  129. C l'element
  130. C
  131. SEGACT MELEME
  132. SEGACT MELEMC
  133. SEGACT MELEMS
  134. NBSOUS=MELEME.LISOUS(/1)
  135. IF(NBSOUS.EQ.0)NBSOUS=1
  136. C
  137. NK=0
  138. IPT1=MELEME
  139. DO L=1,NBSOUS,1
  140. IF(NBSOUS.NE.1)IPT1=LISOUS(L)
  141. SEGACT IPT1
  142. NP=IPT1.NUM(/1)
  143. NEL=IPT1.NUM(/2)
  144. C
  145. DO J=1,NEL,1
  146. NK=NK+1
  147. NCENT=MELEMC.NUM(1,NK)
  148. C Coordonnee du centre
  149. XC=XCOOR((NCENT-1)*(IDIM+1)+1)
  150. YC=XCOOR((NCENT-1)*(IDIM+1)+2)
  151. ZC=0.0D0
  152. IF (IDIM .EQ. 3) ZC=XCOOR((NCENT-1)*(IDIM+1)+3)
  153. C Valeurs de la fonction sur l'element
  154. FC=MPOVA1.VPOCHA(NK,1)
  155. GX=MPOVA2.VPOCHA(NK,1)
  156. GY=MPOVA2.VPOCHA(NK,2)
  157. GZ=0.0D0
  158. IF (IDIM .EQ. 3) GZ=MPOVA2.VPOCHA(NK,3)
  159. GLIM=MPOVA3.VPOCHA(NK,1)
  160. DO K=1,NP,1
  161. ISOM=IPT1.NUM(K,J)
  162. LSOM=MLENTI.LECT(ISOM)
  163. MPOVA4.VPOCHA(LSOM,1)=MPOVA4.VPOCHA(LSOM,1)+1.0D0
  164. XS=XCOOR((ISOM-1)*(IDIM+1)+1)
  165. YS=XCOOR((ISOM-1)*(IDIM+1)+2)
  166. ZS=0.0D0
  167. IF (IDIM .EQ. 3) ZS=XCOOR((ISOM-1)*(IDIM+1)+3)
  168. DX=XS-XC
  169. DY=YS-YC
  170. DZ=ZS-ZC
  171. DF=(DX*GX+DY*GY+DZ*GZ)*GLIM
  172. FS=FC+DF
  173. MPOVAL.VPOCHA(LSOM,1)=MPOVAL.VPOCHA(LSOM,1)+FS
  174. ENDDO
  175. ENDDO
  176. IF(NBSOUS.NE.1) SEGDES IPT1
  177. ENDDO
  178. C
  179. DO J=1,NSOM,1
  180. MPOVAL.VPOCHA(J,1)=MPOVAL.VPOCHA(J,1)/MPOVA4.VPOCHA(J,1)
  181. ENDDO
  182. C
  183. SEGSUP MLENTI
  184. SEGSUP MPOVA4
  185. C
  186. SEGDES MELEME
  187. SEGDES MELEMC
  188. SEGDES MELEMS
  189. C
  190. SEGDES MPOVAL
  191. SEGDES MPOVA1
  192. SEGDES MPOVA2
  193. SEGDES MPOVA3
  194. C
  195. RETURN
  196. END
  197.  
  198.  
  199.  
  200.  
  201.  
  202.  
  203.  

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