Télécharger chaga1.eso

Retour à la liste

Numérotation des lignes :

  1. C CHAGA1 SOURCE PASCAL 19/11/19 21:15:08 10384
  2.  
  3. C=======================================================================
  4. C= C H A G A 1 =
  5. C= ----------- =
  6. C= =
  7. C= Fonction : =
  8. C= ---------- =
  9. C= =
  10. C= Creation du MCHAML de SOURCE de chaleur GAUSSIENNE decrit par les =
  11. C= caracteristiques du modele passees en entree. =
  12. C= =
  13. C= =
  14. C= Entrees : =
  15. C= --------- =
  16. C= =
  17. C= IPMCHA : pointeur sur segment MCHAML de la sous-zone traitee =
  18. C= =
  19. C= IPMAIL : pointeur sur segment MELEME du maillage ou creer la =
  20. C= source de chaleur =
  21. C= =
  22. C= IPINTE : pointeur sur segment MINTE de l'element finis =
  23. C= =
  24. C= IK : indicateur du "type" de distribution gaussienne : =
  25. C= IK = 1 : source gaussienne ISOTROPE =
  26. C= IK = 2 : source gaussienne ISOTROPE-TRANSVERSE =
  27. C= =
  28. C= =
  29. C= Sortie : =
  30. C= -------- =
  31. C= =
  32. C= IPQGAU : pointeur sur segment MELVAL des valeurs de la source de =
  33. C= chaleur GAUSSIENNE =
  34. C= =
  35. C= XQ0 : valeur de la quantite de chaleur imposee, utilisee en =
  36. C= sortie dans chamas pour "renormaliser" le champ a QTOT =
  37. C= =
  38. C=======================================================================
  39.  
  40. SUBROUTINE CHAGA1(IPMCHA,IPMAIL,IPINTE,IK,IPQGAU,XQ0)
  41.  
  42. IMPLICIT INTEGER(I-N)
  43. IMPLICIT REAL*8(A-H,O-Z)
  44.  
  45. REAL*8 XCO1(3),XCD1(3),XCX1(3)
  46. CHARACTER*8 TYPC1
  47. CHARACTER*4 MOCAR(5),NOMC1
  48.  
  49. DATA MOCAR /'QTOT','ORIG','RGAU','DIRE','ZGAU'/
  50.  
  51. -INC CCOPTIO
  52. -INC SMCOORD
  53. -INC SMELEME
  54. -INC SMCHAML
  55. -INC SMINTE
  56.  
  57. IPQGAU = 0
  58.  
  59. C==== Recuperation des caracteristiques de la source de chaleur
  60. C
  61. C Initialisation des valeurs des parametres de la source
  62. C XQ0 : valeur de QTOT
  63. C NPO1, NPD1 : numeros points origine & direction
  64. C RX0, ZX0 : valeurs de RGAU et ZGAU
  65. XQ0 = 0.D0
  66. NPO1 = 0
  67. NPD1 = 0
  68. RX0 = 0.D0
  69. ZX0 = 0.D0
  70. C
  71. C NCAR1 : nombre de caracteristiques a lire
  72. NCAR1 = 3
  73. IF (IK.EQ.2) NCAR1 = 5
  74. C
  75. MCHAM1=IPMCHA
  76. C SEGACT,MCHAM1
  77. NCO1 = MCHAM1.IELVAL(/1)
  78. DO 100 I=1,NCAR1
  79. NOMC1(1:4) = MOCAR(I)
  80. CALL PLACE(MCHAM1.NOMCHE,NCO1,IPLAC,NOMC1)
  81. c write(6,*) 'NONC1 =',NOMC1
  82. c write(6,*) 'MCHAM1.NOMCHE =',(MCHAM1.NOMCHE(ii),ii=1,NCO1)
  83. IF (IPLAC.EQ.0) THEN
  84. GOTO 997
  85. ELSE
  86. TYPC1 = MCHAM1.TYPCHE(IPLAC)(1:8)
  87. MELVA1 = MCHAM1.IELVAL(IPLAC)
  88. IF (MELVA1.VELCHE(/1).GT.1
  89. & .OR.MELVA1.VELCHE(/2).GT.1) GOTO 999
  90. C
  91. C Lecture QTOT
  92. IF (I.EQ.1) THEN
  93. IF (TYPC1.NE.'REAL*8 ') GOTO 998
  94. SEGACT,MELVA1
  95. XQ0 = MELVA1.VELCHE(1,1)
  96. C SEGDES,MELVA1
  97. C
  98. C Lecture ORIG
  99. ELSEIF (I.EQ.2) THEN
  100. IF (TYPC1.NE.'POINTEUR') GOTO 998
  101. MELVA1 = MCHAM1.IELVAL(IPLAC)
  102. SEGACT,MELVA1
  103. NPO1 = MELVA1.IELCHE(1,1)
  104. C SEGDES,MELVA1
  105. C
  106. C Lecture RGAU
  107. ELSEIF (I.EQ.3) THEN
  108. IF (TYPC1.NE.'REAL*8 ') GOTO 998
  109. MELVA1 = MCHAM1.IELVAL(IPLAC)
  110. SEGACT,MELVA1
  111. RX0 = MELVA1.VELCHE(1,1)
  112. C SEGDES,MELVA1
  113. C
  114. C Lecture DIRE
  115. ELSEIF (I.EQ.4) THEN
  116. IF (TYPC1.NE.'POINTEUR') GOTO 998
  117. MELVA1 = MCHAM1.IELVAL(IPLAC)
  118. SEGACT,MELVA1
  119. NPD1 = MELVA1.IELCHE(1,1)
  120. C SEGDES,MELVA1
  121. C
  122. C Lecture ZGAU
  123. ELSEIF (I.EQ.5) THEN
  124. IF (TYPC1.NE.'REAL*8 ') GOTO 998
  125. MELVA1 = MCHAM1.IELVAL(IPLAC)
  126. SEGACT,MELVA1
  127. ZX0 = MELVA1.VELCHE(1,1)
  128. C SEGDES,MELVA1
  129. ENDIF
  130. ENDIF
  131. 100 CONTINUE
  132. C SEGDES,MCHAM1
  133. C
  134. C Remplissage du vecteur de coordonnes de ORIG
  135. IDIMP1 = IDIM+1
  136. IF (NPO1.EQ.0.OR.NPO1.GT.(XCOOR(/1)/IDIMP1)) THEN
  137. NOMC1='ORIG '
  138. GOTO 998
  139. ELSE
  140. DO 120 ID1=1,IDIM
  141. XCO1(ID1)=XCOOR((NPO1-1)*IDIMP1+ID1)
  142. 120 CONTINUE
  143. ENDIF
  144. C
  145. C Remplissage du vecteur de coordonnes de DIRE
  146. C XN1 : norme de DIRE au carre
  147. XN1 = 1.D0
  148. IF (IK.EQ.1) THEN
  149. ZX0 = RX0
  150. XCD1(1)=1.D0
  151. IF (IDIM.GT.1) THEN
  152. DO 130 ID1=2,IDIM
  153. XCD1(ID1)=0.D0
  154. 130 CONTINUE
  155. ENDIF
  156. ELSEIF (IK.EQ.2) THEN
  157. XN1 = 0.D0
  158. DO 140 ID1=1,IDIM
  159. XCD1(ID1)=XCOOR((NPD1-1)*IDIMP1+ID1)
  160. XN1 = XCD1(ID1) ** 2 + XN1
  161. 140 CONTINUE
  162. ELSE
  163. WRITE(IOIMP,*) ' *** Dans CHAGA1, cas (IK) non prevu'
  164. CALL ERREUR(5)
  165. RETURN
  166. ENDIF
  167. C write(6,*) 'XQ0 =',XQ0
  168. C write(6,*) 'RX0 =',RX0
  169. C write(6,*) 'ZX0 =',ZX0
  170. C write(6,*) 'NPO1 =',NPO1
  171. C write(6,*) 'NPD1 =',NPD1
  172. C write(6,*) 'XCO1 =',(XCO1(i),i=1,IDIM)
  173. C write(6,*) 'XCD1 =',(XCD1(i),i=1,IDIM)
  174.  
  175.  
  176. C==== Construction du MELVAL de la distribution Gaussienne de chaleur
  177.  
  178. C Activation du maillage
  179. IPT1 = IPMAIL
  180. SEGACT,IPT1
  181. NBPT1 = IPT1.NUM(/1)
  182. NBEL1 = IPT1.NUM(/2)
  183.  
  184. C Petite verif. sous-zone elementaire
  185. NBS1 = IPT1.LISOUS(/1)
  186. IF (NBS1.NE.0) THEN
  187. WRITE(6,*) 'Dans CHAGA1 : le maillage a plusieurs sous-zones ?'
  188. CALL ERREUR(21)
  189. RETURN
  190. ENDIF
  191. C
  192. C Activation du segment MINTE
  193. C write(6,*) 'IPINTE=',IPINTE
  194. MINTE1 = IPINTE
  195. SEGACT,MINTE1
  196.  
  197. C Creation du MELVAL
  198. N1PTEL = MINTE1.POIGAU(/1)
  199. N1EL = NBEL1
  200. N2PTEL = 0
  201. N2EL = 0
  202. SEGINI,MELVA2
  203.  
  204. C Boucle sur les elements du maillage
  205. DO 200 IEL1=1,NBEL1
  206. C
  207. C Boucle sur les pts de Gauss
  208. C et calcul de la fonction Gaussienne
  209. C RR1 : distance a l'origine ORIG au carre
  210. C ZX1 : distance a la direction DIRE au carre
  211. C RX1 : rayon dans le plan orthog. a DIRE au carre
  212. DO 201 IG1=1,N1PTEL
  213. RR1 = 0.D0
  214. RX1 = 0.D0
  215. ZX1 = 0.D0
  216. DO 203 ID1=1,IDIM
  217. C XPG1 : coordonnees ID1 du Pt de Gauss
  218. XPG1 = 0.D0
  219. DO 202 JPT1=1,NBPT1
  220. NPTJM1 = IPT1.NUM(JPT1,IEL1)-1
  221. XPTJ1 = XCOOR(NPTJM1*IDIMP1+ID1)
  222. VNJ1 = MINTE1.SHPTOT(1,JPT1,IG1)
  223. XPG1 = XPG1 + XPTJ1*VNJ1
  224. 202 CONTINUE
  225. XCX1(ID1) = XPG1 - XCO1(ID1)
  226. RR1 = XCX1(ID1) ** 2 + RR1
  227. ZX1 = XCX1(ID1) * XCD1(ID1) + ZX1
  228. 203 CONTINUE
  229. ZX1 = ZX1 * ZX1 / XN1
  230. RX1 = RR1 - ZX1
  231. c write(6,*) 'RR1,ZX1,RX1=',RR1,ZX1,RX1
  232. c write(6,*) 'XCX1(i)=',(XCX1(i),i=1,idim)
  233. XS1 = RX1 / RX0 / RX0
  234. XS1 = ZX1 / ZX0 / ZX0 + XS1
  235. XS1 = EXP(-1.D0 * XS1)
  236. MELVA2.VELCHE(IG1,IEL1) = XS1
  237. 201 CONTINUE
  238. 200 CONTINUE
  239. C SEGDES,IPT1,MINTE1,MELVA2
  240. C
  241. C==== Affectation du resultat et sortie
  242. IPQGAU = MELVA2
  243. C
  244. RETURN
  245.  
  246. C==== Gestion erreurs et fin
  247.  
  248. C Il manque la donnee d'une composante
  249. 997 CONTINUE
  250. CALL ERREUR(80)
  251. RETURN
  252.  
  253. C Le type de la composante NOMC1 n'est pas celui attendu
  254. 998 CONTINUE
  255. MOTERR(1:8)=NOMC1
  256. CALL ERREUR(679)
  257. RETURN
  258.  
  259. C La composante est attendue constante par sous-zones
  260. 999 CONTINUE
  261. MOTERR(1:4)=NOMC1
  262. MOTERR(5:20)='CARACTERISTIQUES'
  263. CALL ERREUR(1065)
  264. RETURN
  265.  
  266. END
  267.  
  268.  
  269.  

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