Télécharger ingate.eso

Retour à la liste

Numérotation des lignes :

  1. C INGATE SOURCE GOUNAND 05/12/21 21:32:21 5281
  2. SUBROUTINE INGATE(MYPGS,IMPR,IRET)
  3. IMPLICIT REAL*8 (A-H,O-Z)
  4. IMPLICIT INTEGER (I-N)
  5. C***********************************************************************
  6. C NOM : INGATE
  7. C PROJET : Noyau linéaire NLIN
  8. C DESCRIPTION : Remplit le segment des méthodes d'intégration
  9. C avec des méthodes d'intégration numérique de cubature
  10. C type Gauss pour le tétraèdre (ordre 1 à 7).
  11. C
  12. C REFERENCES : Le site de Cools (avec 32 chiffres sign.)
  13. C (essentiellement Stroud et al.) dont on reprend la
  14. C nomenclature...
  15. C LANGAGE : ESOPE
  16. C AUTEUR : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF)
  17. C mél : gounand@semt2.smts.cea.fr
  18. C***********************************************************************
  19. C APPELES : INIPG, GTSINO, GTRO3I, GT3FS9, GT3F10,
  20. C FIPG, CPROPG
  21. C APPELE PAR : INPGS
  22. C***********************************************************************
  23. C ENTREES : -
  24. C ENTREES/SORTIES : MYPGS (actif en *MOD)
  25. C SORTIES : -
  26. C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  27. C***********************************************************************
  28. C VERSION : v1, 22/10/99, version initiale
  29. C HISTORIQUE : v1, 22/10/99, création
  30. C HISTORIQUE : 29/5/00 rajout ordre 6
  31. C HISTORIQUE :
  32. C***********************************************************************
  33. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  34. C en cas de modification de ce sous-programme afin de faciliter
  35. C la maintenance !
  36. C***********************************************************************
  37. -INC CCOPTIO
  38. CBEGININCLUDE SPOGAU
  39. SEGMENT POGAU
  40. CHARACTER*(LNNPG) NOMPG
  41. CHARACTER*(LNTPG) TYPMPG
  42. CHARACTER*(LNFPG) FORLPG
  43. INTEGER NORDPG
  44. REAL*8 XCOPG(NDLPG,NBPG)
  45. REAL*8 XPOPG(NBPG)
  46. ENDSEGMENT
  47. SEGMENT POGAUS
  48. POINTEUR LISPG(0).POGAU
  49. ENDSEGMENT
  50. CENDINCLUDE SPOGAU
  51. POINTEUR MYPGS.POGAUS
  52. POINTEUR PGCOUR.POGAU
  53. POINTEUR PGPRO1.POGAU
  54. POINTEUR PGPRO2.POGAU
  55. *
  56. INTEGER IMPR,IRET
  57. * On travaille en coordonnées barycentriques.
  58. * D'après le Dhatt et Touzot
  59. * L1 = 1 - \ksi - \eta -\zeta
  60. * L2 = \ksi
  61. * L3 = \eta
  62. * L4 = \zeta
  63. INTEGER DIMSRF
  64. PARAMETER(DIMSRF=3)
  65. REAL*8 XCOR(DIMSRF+1)
  66. *
  67. * Générateurs pour la cubature de degré 1 à 1 point : GAT3-1-1 :
  68. * - [ Fully symmetric ]
  69. REAL*8 X1D1,Y1D1,Z1D1,P1D1
  70. PARAMETER (X1D1=1.D0/4.D0)
  71. PARAMETER (Y1D1=1.D0/4.D0)
  72. PARAMETER (Z1D1=1.D0/4.D0)
  73. PARAMETER (P1D1=1.D0/6.D0)
  74. *
  75. * Générateurs pour la cubature de degré 2 à 4 points : GAT3-2-4B :
  76. * - [ Fully symmetric ]
  77. REAL*8 X1D2,Y1D2,Z1D2,P1D2
  78. PARAMETER (X1D2=0.138196601125010515179541316563436D0)
  79. PARAMETER (Y1D2=0.138196601125010515179541316563436D0)
  80. PARAMETER (Z1D2=0.138196601125010515179541316563436D0)
  81. PARAMETER (P1D2=1.D0/24.D0)
  82. *
  83. * Générateurs pour la cubature de degré 3 à 8 points : GAT3-3-8B :
  84. * - [ Fully symmetric ]
  85. REAL*8 X1D3,Y1D3,Z1D3,P1D3
  86. PARAMETER (X1D3=1.D0)
  87. PARAMETER (Y1D3=0.D0)
  88. PARAMETER (Z1D3=0.D0)
  89. PARAMETER (P1D3=4.16666666666666666666666666666666D-3)
  90. * - [ Fully symmetric ]
  91. REAL*8 X2D3,Y2D3,Z2D3,P2D3
  92. PARAMETER (X2D3=1.D0/3.D0)
  93. PARAMETER (Y2D3=1.D0/3.D0)
  94. PARAMETER (Z2D3=1.D0/3.D0)
  95. PARAMETER (P2D3=0.0375D0)
  96. *
  97. * Générateurs pour la cubature de degré 5 à 14 points : GAT3-5-14A :
  98. * - [ Fully symmetric ]
  99. REAL*8 X1D5,Y1D5,Z1D5,P1D5
  100. PARAMETER (X1D5=0.0927352503108912264023239137370306D0)
  101. PARAMETER (Y1D5=0.0927352503108912264023239137370306D0)
  102. PARAMETER (Z1D5=0.0927352503108912264023239137370306D0)
  103. PARAMETER (P1D5=0.0122488405193936582572850342477212D0)
  104. * - [ Fully symmetric ]
  105. REAL*8 X2D5,Y2D5,Z2D5,P2D5
  106. PARAMETER (X2D5=0.310885919263300609797345733763457D0)
  107. PARAMETER (Y2D5=0.310885919263300609797345733763457D0)
  108. PARAMETER (Z2D5=0.310885919263300609797345733763457D0)
  109. PARAMETER (P2D5=0.0187813209530026417998642753888810D0)
  110. * - [ Fully symmetric ]
  111. REAL*8 X3D5,Y3D5,Z3D5,P3D5
  112. PARAMETER (X3D5=0.454496295874350350508119473720660D0)
  113. PARAMETER (Y3D5=0.454496295874350350508119473720660D0)
  114. PARAMETER (Z3D5=0.0455037041256496494918805262793394D0)
  115. PARAMETER (P3D5=7.09100346284691107301157135337624D-3)
  116. *
  117. * Générateurs pour la cubature de degré 6 à 24 points : GAT3-6-24 :
  118. * - [ Fully symmetric ]
  119. REAL*8 X1D6,Y1D6,Z1D6,P1D6
  120. PARAMETER (X1D6=0.214602871259152029288839219386284D0)
  121. PARAMETER (Y1D6=0.214602871259152029288839219386284D0)
  122. PARAMETER (Z1D6=0.214602871259152029288839219386284D0)
  123. PARAMETER (P1D6=6.65379170969458201661510459291332D-3)
  124. * - [ Fully symmetric ]
  125. REAL*8 X2D6,Y2D6,Z2D6,P2D6
  126. PARAMETER (X2D6=0.0406739585346113531155794489564100D0)
  127. PARAMETER (Y2D6=0.0406739585346113531155794489564100D0)
  128. PARAMETER (Z2D6=0.0406739585346113531155794489564100D0)
  129. PARAMETER (P2D6=1.67953517588677382466887290765614D-3)
  130. * - [ Fully symmetric ]
  131. REAL*8 X3D6,Y3D6,Z3D6,P3D6
  132. PARAMETER (X3D6=0.322337890142275510343994470762492D0)
  133. PARAMETER (Y3D6=0.322337890142275510343994470762492D0)
  134. PARAMETER (Z3D6=0.322337890142275510343994470762492D0)
  135. PARAMETER (P3D6=9.22619692394245368252554630895433D-3)
  136. * - [ Fully symmetric ]
  137. REAL*8 X4D6,Y4D6,Z4D6,P4D6
  138. PARAMETER (X4D6=0.0636610018750175252992355276057269D0)
  139. PARAMETER (Y4D6=0.0636610018750175252992355276057269D0)
  140. PARAMETER (Z4D6=0.269672331458315808034097805727606D0)
  141. PARAMETER (P4D6=8.03571428571428571428571428571428D-3)
  142. *
  143. INTEGER NOPG
  144. *
  145. * Executable statements
  146. *
  147. IF (IMPR.GT.6) WRITE(IOIMP,*) 'Entrée dans ingate'
  148. *
  149. * Méthode de nom : NCT3-1-4
  150. * Sur un tétraèdre : cubature d'ordre 1 à 4 points
  151. * espace de référence de dimension 3
  152. *
  153. * In INIPG : SEGINI PGCOUR
  154. CALL INIPG('NCT3-1-4','NEWTON-COTES','TETRAEDRE',
  155. $ 1,4,3,
  156. $ PGCOUR,
  157. $ IMPR,IRET)
  158. IF (IRET.NE.0) GOTO 9999
  159. NOPG=0
  160. XCOR(1)=1.D0
  161. XCOR(2)=0.D0
  162. XCOR(3)=0.D0
  163. XCOR(4)=1-XCOR(1)-XCOR(2)-XCOR(3)
  164. CALL GTRO3I(PGCOUR,NOPG,DIMSRF,XCOR,P1D2,IMPR,IRET)
  165. IF (IRET.NE.0) GOTO 9999
  166. SEGDES PGCOUR
  167. MYPGS.LISPG(**)=PGCOUR
  168. *
  169. * Méthode de nom : GAT3-1-1
  170. * Sur un tétraèdre : cubature d'ordre 1 à 1 point
  171. * espace de référence de dimension 3
  172. *
  173. * In INIPG : SEGINI PGCOUR
  174. CALL INIPG('GAT3-1-1','GAUSS','TETRAEDRE',
  175. $ 1,1,3,
  176. $ PGCOUR,
  177. $ IMPR,IRET)
  178. IF (IRET.NE.0) GOTO 9999
  179. NOPG=0
  180. XCOR(1)=X1D1
  181. XCOR(2)=Y1D1
  182. XCOR(3)=Z1D1
  183. XCOR(4)=1-XCOR(1)-XCOR(2)-XCOR(3)
  184. CALL GTSINO(PGCOUR,NOPG,DIMSRF,XCOR,P1D1,IMPR,IRET)
  185. IF (IRET.NE.0) GOTO 9999
  186. SEGDES PGCOUR
  187. MYPGS.LISPG(**)=PGCOUR
  188. *
  189. * Méthode de nom : GAT3-2-4B
  190. * Sur un tétraèdre : cubature d'ordre 2 à 4 points
  191. * espace de référence de dimension 3
  192. *
  193. * In INIPG : SEGINI PGCOUR
  194. CALL INIPG('GAT3-2-4B','GAUSS','TETRAEDRE',
  195. $ 2,4,3,
  196. $ PGCOUR,
  197. $ IMPR,IRET)
  198. IF (IRET.NE.0) GOTO 9999
  199. NOPG=0
  200. XCOR(1)=X1D2
  201. XCOR(2)=Y1D2
  202. XCOR(3)=Z1D2
  203. XCOR(4)=1-XCOR(1)-XCOR(2)-XCOR(3)
  204. CALL GTRO3I(PGCOUR,NOPG,DIMSRF,XCOR,P1D2,IMPR,IRET)
  205. IF (IRET.NE.0) GOTO 9999
  206. SEGDES PGCOUR
  207. MYPGS.LISPG(**)=PGCOUR
  208. *
  209. * Méthode de nom : GAT3-3-8B
  210. * Sur un tétraèdre : cubature d'ordre 3 à 8 points
  211. * espace de référence de dimension 3
  212. *
  213. * In INIPG : SEGINI PGCOUR
  214. CALL INIPG('GAT3-3-8B','GAUSS','TETRAEDRE',
  215. $ 3,8,3,
  216. $ PGCOUR,
  217. $ IMPR,IRET)
  218. IF (IRET.NE.0) GOTO 9999
  219. NOPG=0
  220. XCOR(1)=X1D3
  221. XCOR(2)=Y1D3
  222. XCOR(3)=Z1D3
  223. XCOR(4)=1-XCOR(1)-XCOR(2)-XCOR(3)
  224. CALL GTRO3I(PGCOUR,NOPG,DIMSRF,XCOR,P1D3,IMPR,IRET)
  225. IF (IRET.NE.0) GOTO 9999
  226. XCOR(1)=X2D3
  227. XCOR(2)=Y2D3
  228. XCOR(3)=Z2D3
  229. XCOR(4)=1-XCOR(1)-XCOR(2)-XCOR(3)
  230. CALL GTRO3I(PGCOUR,NOPG,DIMSRF,XCOR,P2D3,IMPR,IRET)
  231. IF (IRET.NE.0) GOTO 9999
  232. SEGDES PGCOUR
  233. MYPGS.LISPG(**)=PGCOUR
  234. *
  235. * Méthode de nom : GAT3-5-14
  236. * Sur un tétraèdre : cubature d'ordre 5 à 14 points
  237. * espace de référence de dimension 3
  238. *
  239. * In INIPG : SEGINI PGCOUR
  240. CALL INIPG('GAT3-5-14','GAUSS','TETRAEDRE',
  241. $ 5,14,3,
  242. $ PGCOUR,
  243. $ IMPR,IRET)
  244. IF (IRET.NE.0) GOTO 9999
  245. NOPG=0
  246. XCOR(1)=X1D5
  247. XCOR(2)=Y1D5
  248. XCOR(3)=Z1D5
  249. XCOR(4)=1-XCOR(1)-XCOR(2)-XCOR(3)
  250. CALL GTRO3I(PGCOUR,NOPG,DIMSRF,XCOR,P1D5,IMPR,IRET)
  251. IF (IRET.NE.0) GOTO 9999
  252. XCOR(1)=X2D5
  253. XCOR(2)=Y2D5
  254. XCOR(3)=Z2D5
  255. XCOR(4)=1-XCOR(1)-XCOR(2)-XCOR(3)
  256. CALL GTRO3I(PGCOUR,NOPG,DIMSRF,XCOR,P2D5,IMPR,IRET)
  257. IF (IRET.NE.0) GOTO 9999
  258. XCOR(1)=X3D5
  259. XCOR(2)=Y3D5
  260. XCOR(3)=Z3D5
  261. XCOR(4)=1-XCOR(1)-XCOR(2)-XCOR(3)
  262. CALL GT3FS9(PGCOUR,NOPG,DIMSRF,XCOR,P3D5,IMPR,IRET)
  263. IF (IRET.NE.0) GOTO 9999
  264. SEGDES PGCOUR
  265. MYPGS.LISPG(**)=PGCOUR
  266. *
  267. * Méthode de nom : GPT3-5-21
  268. * Sur un tétraèdre : méthode gauss-produit conique d'ordre 5 à 21 points
  269. * espace de référence de dimension 3
  270. *
  271. * In INIPG : SEGINI PGCOUR
  272. CALL INIPG('GPT3-5-21','GAUSS-PRODUIT','TETRAEDRE',
  273. $ 5,21,3,
  274. $ PGCOUR,
  275. $ IMPR,IRET)
  276. IF (IRET.NE.0) GOTO 9999
  277. CALL FIPG('GAT2-5-7',MYPGS,PGPRO1,IMPR,IRET)
  278. IF (IRET.NE.0) GOTO 9999
  279. CALL FIPG('GJ20-5-3',MYPGS,PGPRO2,IMPR,IRET)
  280. IF (IRET.NE.0) GOTO 9999
  281. CALL CPROPG(PGPRO1,PGPRO2,PGCOUR,IMPR,IRET)
  282. IF (IRET.NE.0) GOTO 9999
  283. SEGDES PGCOUR
  284. MYPGS.LISPG(**)=PGCOUR
  285. *
  286. * Méthode de nom : GPT3-5-27
  287. * Sur un tétraèdre : méthode gauss-produit conique d'ordre 5 à 27 points
  288. * espace de référence de dimension 3
  289. *
  290. * In INIPG : SEGINI PGCOUR
  291. CALL INIPG('GPT3-5-27','GAUSS-PRODUIT','TETRAEDRE',
  292. $ 5,27,3,
  293. $ PGCOUR,
  294. $ IMPR,IRET)
  295. IF (IRET.NE.0) GOTO 9999
  296. CALL FIPG('GPT2-5-9',MYPGS,PGPRO1,IMPR,IRET)
  297. IF (IRET.NE.0) GOTO 9999
  298. CALL FIPG('GJ20-5-3',MYPGS,PGPRO2,IMPR,IRET)
  299. IF (IRET.NE.0) GOTO 9999
  300. CALL CPROPG(PGPRO1,PGPRO2,PGCOUR,IMPR,IRET)
  301. IF (IRET.NE.0) GOTO 9999
  302. SEGDES PGCOUR
  303. MYPGS.LISPG(**)=PGCOUR
  304. *
  305. * Méthode de nom : GAT3-6-24
  306. * Sur un tétraèdre : cubature d'ordre 6 à 24 points
  307. * espace de référence de dimension 3
  308. *
  309. * In INIPG : SEGINI PGCOUR
  310. CALL INIPG('GAT3-6-24','GAUSS','TETRAEDRE',
  311. $ 6,24,3,
  312. $ PGCOUR,
  313. $ IMPR,IRET)
  314. IF (IRET.NE.0) GOTO 9999
  315. NOPG=0
  316. XCOR(1)=X1D6
  317. XCOR(2)=Y1D6
  318. XCOR(3)=Z1D6
  319. XCOR(4)=1-XCOR(1)-XCOR(2)-XCOR(3)
  320. CALL GTRO3I(PGCOUR,NOPG,DIMSRF,XCOR,P1D6,IMPR,IRET)
  321. IF (IRET.NE.0) GOTO 9999
  322. XCOR(1)=X2D6
  323. XCOR(2)=Y2D6
  324. XCOR(3)=Z2D6
  325. XCOR(4)=1-XCOR(1)-XCOR(2)-XCOR(3)
  326. CALL GTRO3I(PGCOUR,NOPG,DIMSRF,XCOR,P2D6,IMPR,IRET)
  327. IF (IRET.NE.0) GOTO 9999
  328. XCOR(1)=X3D6
  329. XCOR(2)=Y3D6
  330. XCOR(3)=Z3D6
  331. XCOR(4)=1-XCOR(1)-XCOR(2)-XCOR(3)
  332. CALL GTRO3I(PGCOUR,NOPG,DIMSRF,XCOR,P3D6,IMPR,IRET)
  333. IF (IRET.NE.0) GOTO 9999
  334. XCOR(1)=X4D6
  335. XCOR(2)=Y4D6
  336. XCOR(3)=Z4D6
  337. XCOR(4)=1-XCOR(1)-XCOR(2)-XCOR(3)
  338. CALL GT3F10(PGCOUR,NOPG,DIMSRF,XCOR,P4D6,IMPR,IRET)
  339. IF (IRET.NE.0) GOTO 9999
  340. SEGDES PGCOUR
  341. MYPGS.LISPG(**)=PGCOUR
  342. *
  343. * Méthode de nom : GPT3-7-64
  344. * Sur un tétraèdre : méthode gauss-produit conique d'ordre 7 à 64 points
  345. * espace de référence de dimension 3
  346. *
  347. * In INIPG : SEGINI PGCOUR
  348. CALL INIPG('GPT3-7-64','GAUSS-PRODUIT','TETRAEDRE',
  349. $ 7,64,3,
  350. $ PGCOUR,
  351. $ IMPR,IRET)
  352. IF (IRET.NE.0) GOTO 9999
  353. CALL FIPG('GPT2-7-16',MYPGS,PGPRO1,IMPR,IRET)
  354. IF (IRET.NE.0) GOTO 9999
  355. CALL FIPG('GJ20-7-4',MYPGS,PGPRO2,IMPR,IRET)
  356. IF (IRET.NE.0) GOTO 9999
  357. CALL CPROPG(PGPRO1,PGPRO2,PGCOUR,IMPR,IRET)
  358. IF (IRET.NE.0) GOTO 9999
  359. SEGDES PGCOUR
  360. MYPGS.LISPG(**)=PGCOUR
  361. *
  362. * Normal termination
  363. *
  364. IRET=0
  365. RETURN
  366. *
  367. * Format handling
  368. *
  369. *
  370. * Error handling
  371. *
  372. 9999 CONTINUE
  373. IRET=1
  374. WRITE(IOIMP,*) 'An error was detected in subroutine ingate'
  375. RETURN
  376. *
  377. * End of subroutine INGATE
  378. *
  379. END
  380.  
  381.  
  382.  
  383.  

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