Télécharger chaco2.eso

Retour à la liste

Numérotation des lignes :

  1. C CHACO2 SOURCE PASCAL 19/11/19 21:15:01 10384
  2. SUBROUTINE CHACO2(IPSONO,IPSON1,IPSON2,IEP,IPGEOM,IPINTE,
  3. . IPINT1,IPCHEQ,IPCHE1,IPCHE2)
  4. IMPLICIT INTEGER(I-N)
  5. IMPLICIT REAL*8(A-H,O-Z)
  6. ************************************************************************
  7. *
  8. * C H A C O 2
  9. * -----------
  10. *
  11. * FONCTION:
  12. * ---------
  13. * CAS DES SOURCES VOLUMIQUES
  14. * COQ6 COQ8 ET COQ4
  15. *
  16. * MODULES UTILISES:
  17. * -----------------
  18. *
  19.  
  20. -INC PPARAM
  21. -INC CCOPTIO
  22. -INC CCREEL
  23. -INC SMCHAML
  24. -INC SMELEME
  25. -INC SMINTE
  26. -INC SMCOORD
  27. *
  28. * PARAMETRES: (E)=ENTREE (S)=SORTIE (+ = CONTENU DANS UN COMMUN)
  29. * -----------
  30. *
  31. * IPSONO (E) POINTEURS SUR DES SEGMENTS MELVAL CONTENANT LES
  32. * IPSON1 SOURCES
  33. * IPSON2
  34. * IEP (E) POINTEUR SUR UN SEGMENT MELVAL COTENANT LES EPAISSEUR
  35. * IPGEOM (E) POINTEUR SUR UN OBJET MAILLAGE ELEMENTAIRE
  36. * IPINTE (E) POINTEUR SUR UN SEGMENT MINTE CONTENANT LES
  37. * CARACTERISTIQUES D'INTEGRATION
  38. * IPINT1 (E) POINTEUR SUR UN SEGMENT MINTE CONTENANT LES
  39. * LES VALEURS DE FONCTION DE FORME AUX NOEUD
  40. * +IDIM (E) VOIR CCOPTIO
  41. * +XPI (E) VOIR CCREEL
  42. * IPCHEQ (S) POINTEURS SUR DES SEGMENTS MELVAL CONTENANT LES
  43. * IPCHE1 CHALEURS NODALES EQUIVALENTES
  44. * IPCHE2
  45. *
  46. * VARIABLES:
  47. * ----------
  48. *
  49. * XE(3,NBPTEL) = COORDONNEES DES ELEMENTS DANS LE REPERE GLOBAL
  50. * DJAC = DETERMINANT DU JACOBIEN EN UN POINT DE GAUSS
  51. * A ET A1 = TABLEAUX DE TRAVAIL
  52. *
  53. *
  54. REAL*8 XJ(3,3)
  55. SEGMENT,MMAT1
  56. REAL*8 XE(3,NBPTEL),A(NBE,NBE),FORME(NBNO),A1(NBNO,NBNO)
  57. REAL*8 EXC(NBNO),EPAI(NBNO),TXR(3,3,NBNO)
  58. ENDSEGMENT
  59. *
  60. * CONSTANTES:
  61. * -----------
  62. *
  63. PARAMETER ( O1=1.D0,O2=2.D0)
  64. DATA X577/.577350269189626D0/
  65. *
  66. * AUTEUR, DATE DE CREATION:
  67. * -------------------------
  68. *
  69. * P. DOWLATYARI AOUT 90
  70. *
  71. * LANGAGE:
  72. * --------
  73. *
  74. * ESOPE + FORTRAN77
  75. *
  76. ************************************************************************
  77. *
  78. * ON RECUPERE LES VALEURS DES SOURCES
  79. *
  80. MELVA1=IPSONO
  81. SEGACT,MELVA1
  82. NBPTE1=MELVA1.VELCHE(/1)
  83. NEL1=MELVA1.VELCHE(/2)
  84. MELVA2=IPSON1
  85. SEGACT,MELVA2
  86. MELVA3=IPSON2
  87. SEGACT,MELVA3
  88. *
  89. * ON RECUPERE LES CARACTERISTIQUES D'INTEGRATION
  90. *
  91. MINTE=IPINTE
  92. SEGACT,MINTE
  93. NBPGAU=POIGAU(/1)
  94. NBNO=SHPTOT(/2)
  95. MINTE1 = IPINT1
  96. SEGACT,MINTE1
  97. *
  98. * ON RECUPERE UN DES MAILLAGES ELEMENTAIRES DE L'ENVELOPPE
  99. *
  100. MELEME=IPGEOM
  101. SEGACT,MELEME
  102. NBPTEL=NUM(/1)
  103. NEL=NUM(/2)
  104. *
  105. * INITIALISATION DES MELVALS QUI CONTIENDRA LES CHALEURS EQUIVALENTE
  106. *
  107. N1PTEL=NBPTEL
  108. N1EL=NEL
  109. N2PTEL=0
  110. N2EL=0
  111. NBE=3*NBPTEL
  112. SEGINI,MELVAL
  113. IPCHEQ=MELVAL
  114. SEGINI,MELVA4
  115. IPCHE1=MELVA4
  116. SEGINI,MELVA5
  117. IPCHE2=MELVA5
  118. SEGINI,MMAT1
  119. CALL ZERO(EXC,NBNO,1)
  120. MELVA6=IEP
  121. SEGACT,MELVA6
  122. *
  123. * BOUCLE SUR LES ELEMENTS
  124. *
  125. DO 10 IEL=1,NEL
  126. *
  127. * ON CHERCHE LES COORDONNEES DES NOEUDS DANS LE REPERE GLOBAL
  128. *
  129. CALL DOXE(XCOOR,IDIM,NBPTEL,NUM,IEL,XE)
  130. *
  131. * CALCUL DES AXES LOCAUX AUX NOEUDS DE L'ELEMENT
  132. *
  133. CALL CQ8LOC(XE,NBPTEL,MINTE1.SHPTOT,TXR,IRR)
  134. *
  135. IF(IRR.EQ.0)THEN
  136. *
  137. * EHEC DANS LE CALCUL DES AXES LOCAUX
  138. *
  139. CALL ERREUR (515)
  140. SEGSUP,MMAT1,MELVAL,MELVA4,MELVA5
  141. RETURN
  142. ENDIF
  143. *
  144. *
  145. * ON CREE LE TABLEAU DES EPAISSEURS
  146. *
  147. IBMN=MIN(IEL,MELVA6.VELCHE(/2))
  148. DO 5 INO = 1,NBNO
  149. INMN=MIN(INO,MELVA6.VELCHE(/1))
  150. EPAI(INO) =MELVA6.VELCHE(INMN,IBMN)
  151. 5 CONTINUE
  152. *
  153. CALL ZERO (A,NBE,NBE)
  154. *
  155. * BOUCLE SUR LES POINTS DE GAUSS
  156. *
  157. *
  158. DO 40 IGAU = 1, NBPGAU
  159. *
  160. CALL ZERO (A1,NBNO,NBNO)
  161. *
  162. E3=DZEGAU(IGAU)
  163. *
  164. *
  165. * CALCUL DU JACABIEN
  166. *
  167. CALL CQ8JCE (IGAU,NBPTEL,E3,XE,EPAI,EXC,TXR,SHPTOT,
  168. . XJ,DJAC,IRR)
  169. *
  170. IF(IRR.LT.0)THEN
  171. *
  172. * JACOBIEN NUL DANS L'ELEMENT IEL
  173. *
  174. INTERR(1)=IEL
  175. CALL ERREUR (405)
  176. SEGSUP,MMAT1,MELVAL,MELVA4,MELVA5
  177. RETURN
  178. ENDIF
  179. *
  180. * CALCUL DE FORME (TRANSPOSEE)*FORME CONCERNANT LA SURFACE
  181. * MOYENNE
  182. DO 50 INO=1,NBNO
  183. FORME(INO)=SHPTOT(1,INO,IGAU)
  184. 50 CONTINUE
  185. *
  186. DJAC = DJAC*POIGAU(IGAU)
  187. *
  188. CALL NTNST (FORME,DJAC,NBNO,1,A1)
  189. *
  190. * ON AJOUTE L'EFFET DE L'EPAISSEUR
  191. *
  192. C1=(E3/O2)*(E3-O1)
  193. C2=O1-E3*E3
  194. C3=(E3/O2)*(E3+O1)
  195. *
  196. DO 60 I=1,NBE
  197. DO 61 J=1,NBE
  198. IF(I.LE.NBNO)THEN
  199. II=I
  200. IF(J.LE.NBNO)THEN
  201. JJ=J
  202. FACT=C1*C1
  203. ELSEIF(J.GT.NBNO.AND.J.LE.(2*NBNO))THEN
  204. JJ=J-NBNO
  205. FACT=C1*C2
  206. ELSE
  207. JJ=J-2*NBNO
  208. FACT=C1*C3
  209. ENDIF
  210. ELSEIF(I.GT.NBNO.AND.I.LE.(2*NBNO))THEN
  211. II=I-NBNO
  212. IF(J.LE.NBNO)THEN
  213. JJ=J
  214. FACT=C2*C1
  215. ELSEIF(J.GT.NBNO.AND.J.LE.(2*NBNO))THEN
  216. JJ=J-NBNO
  217. FACT=C2*C2
  218. ELSE
  219. JJ=J-2*NBNO
  220. FACT=C2*C3
  221. ENDIF
  222. ELSE
  223. II=I-2*NBNO
  224. IF(J.LE.NBNO)THEN
  225. JJ=J
  226. FACT=C3*C1
  227. ELSEIF(J.GT.NBNO.AND.J.LE.(2*NBNO))THEN
  228. JJ=J-NBNO
  229. FACT=C3*C2
  230. ELSE
  231. JJ=J-2*NBNO
  232. FACT=C3*C3
  233. ENDIF
  234. ENDIF
  235. A(I,J)=A(I,J)+FACT*A1(II,JJ)
  236. 61 CONTINUE
  237. 60 CONTINUE
  238. * FIN DE BOUCLE SUR LES POINTS D'INTEGRATION
  239. 40 CONTINUE
  240. *
  241. * (INTEGRAL DE HTH)*VALEURS NODALES DES SOURCES
  242. *
  243. IEMIN=MIN(NEL1,IEL)
  244. DO 70 INO3=1,NBE
  245. DO 71 INO4=1,NBE
  246. IF(INO3.LE.NBPTEL)THEN
  247. IF(INO4.LE.NBPTEL)THEN
  248. INMIN=MIN(NBPTE1,INO4)
  249. VELCHE(INO3,IEL)=VELCHE(INO3,IEL)+MELVA1.VELCHE(INMIN,IEMIN)*
  250. 1 A(INO4,INO3)
  251. ELSEIF(INO4.GT.NBPTEL.AND.INO4.LE.(2*NBPTEL))THEN
  252. INO5=INO4-NBPTEL
  253. INMIN=MIN(NBPTE1,INO5)
  254. VELCHE(INO3,IEL)=VELCHE(INO3,IEL)+MELVA2.VELCHE(INMIN,IEMIN)*
  255. 1 A(INO4,INO3)
  256. ELSE
  257. INO5=INO4-2*NBPTEL
  258. INMIN=MIN(NBPTE1,INO5)
  259. VELCHE(INO3,IEL)=VELCHE(INO3,IEL)+MELVA3.VELCHE(INMIN,IEMIN)*
  260. 1 A(INO4,INO3)
  261. ENDIF
  262. ELSEIF(INO3.GT.NBPTEL.AND.INO3.LE.(2*NBPTEL))THEN
  263. INO6=INO3 - NBPTEL
  264. IF(INO4.LE.NBPTEL)THEN
  265. INMIN=MIN(NBPTE1,INO4)
  266. MELVA4.VELCHE(INO6,IEL)=MELVA4.VELCHE(INO6,IEL)+
  267. 1 MELVA1.VELCHE(INMIN,IEMIN)*A(INO4,INO3)
  268. ELSEIF(INO4.GT.NBPTEL.AND.INO4.LE.(2*NBPTEL))THEN
  269. INO5=INO4-NBPTEL
  270. INMIN=MIN(NBPTE1,INO5)
  271. MELVA4.VELCHE(INO6,IEL)=MELVA4.VELCHE(INO6,IEL)+
  272. 1 MELVA2.VELCHE(INMIN,IEMIN)*A(INO4,INO3)
  273. ELSE
  274. INO5=INO4-2*NBPTEL
  275. INMIN=MIN(NBPTE1,INO5)
  276. MELVA4.VELCHE(INO6,IEL)=MELVA4.VELCHE(INO6,IEL)+
  277. 1 MELVA3.VELCHE(INMIN,IEMIN)*A(INO4,INO3)
  278. ENDIF
  279. ELSE
  280. INO6=INO3 -2*NBPTEL
  281. IF(INO4.LE.NBPTEL)THEN
  282. INMIN=MIN(NBPTE1,INO4)
  283. MELVA5.VELCHE(INO6,IEL)=MELVA5.VELCHE(INO6,IEL)+
  284. 1 MELVA1.VELCHE(INMIN,IEMIN)*A(INO4,INO3)
  285. ELSEIF(INO4.GT.NBPTEL.AND.INO4.LE.(2*NBPTEL))THEN
  286. INO5=INO4-NBPTEL
  287. INMIN=MIN(NBPTE1,INO5)
  288. MELVA5.VELCHE(INO6,IEL)=MELVA5.VELCHE(INO6,IEL)+
  289. 1 MELVA2.VELCHE(INMIN,IEMIN)*A(INO4,INO3)
  290. ELSE
  291. INO5=INO4-2*NBPTEL
  292. INMIN=MIN(NBPTE1,INO5)
  293. MELVA5.VELCHE(INO6,IEL)=MELVA5.VELCHE(INO6,IEL)+
  294. 1 MELVA3.VELCHE(INMIN,IEMIN)*A(INO4,INO3)
  295. ENDIF
  296. ENDIF
  297. 71 CONTINUE
  298. 70 CONTINUE
  299. * END DO
  300. 10 CONTINUE
  301. * END DO
  302. *
  303. SEGSUP,MMAT1
  304. END
  305.  
  306.  
  307.  
  308.  

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