Télécharger ingacu.eso

Retour à la liste

Numérotation des lignes :

ingacu
  1. C INGACU SOURCE GOUNAND 21/06/02 21:16:37 11022
  2. SUBROUTINE INGACU(MYPGS,IMPR,IRET)
  3. IMPLICIT REAL*8 (A-H,O-Z)
  4. IMPLICIT INTEGER (I-N)
  5. C***********************************************************************
  6. C NOM : INGACU
  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 cube (ordre 1 à 5).
  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, GCSINO, GCFS2, GCRESY
  20. C APPELE PAR : INPGS
  21. C***********************************************************************
  22. C ENTREES : -
  23. C ENTREES/SORTIES : MYPGS (actif en *MOD)
  24. C SORTIES : -
  25. C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  26. C***********************************************************************
  27. C VERSION : v1, 11/05/00, version initiale
  28. C HISTORIQUE : v1, 11/05/00, création
  29. C HISTORIQUE :
  30. C HISTORIQUE :
  31. C***********************************************************************
  32. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  33. C en cas de modification de ce sous-programme afin de faciliter
  34. C la maintenance !
  35. C***********************************************************************
  36.  
  37. -INC PPARAM
  38. -INC CCOPTIO
  39. -INC TNLIN
  40. *-INC SPOGAU
  41. POINTEUR MYPGS.POGAUS
  42. POINTEUR PGCOUR.POGAU
  43. *
  44. INTEGER IMPR,IRET
  45. integer PGPRO1,PGPRO2
  46. *
  47. INTEGER DIMSRF
  48. PARAMETER(DIMSRF=3)
  49. REAL*8 XCOR(DIMSRF)
  50. *
  51. * Générateurs pour la cubature de degré 1 à 1 point : GAC3-1-1 :
  52. * - [ Fully symmetric ]
  53. REAL*8 X1D1,Y1D1,Z1D1,P1D1
  54. PARAMETER (X1D1=0.D0)
  55. PARAMETER (Y1D1=0.D0)
  56. PARAMETER (Z1D1=0.D0)
  57. PARAMETER (P1D1=8.D0)
  58. *
  59. * Générateurs pour la cubature de degré 3 à 6 points : GAC3-3-6A :
  60. * - [ Fully symmetric ]
  61. REAL*8 X1D3,Y1D3,Z1D3,P1D3
  62. PARAMETER (X1D3=1.D0)
  63. PARAMETER (Y1D3=0.D0)
  64. PARAMETER (Z1D3=0.D0)
  65. PARAMETER (P1D3=4.D0/3.D0)
  66. *
  67. * Générateurs pour la cubature de degré 5 à 14 points : GAC3-5-14 :
  68. * - [ Fully symmetric ]
  69. REAL*8 X1D5,Y1D5,Z1D5,P1D5
  70. PARAMETER (X1D5=0.795822425754221463264548820476135D0)
  71. PARAMETER (Y1D5=0.D0)
  72. PARAMETER (Z1D5=0.D0)
  73. PARAMETER (P1D5=0.886426592797783933518005540166204D0)
  74. * - [ Fully symmetric ]
  75. REAL*8 X2D5,Y2D5,Z2D5,P2D5
  76. PARAMETER (X2D5=0.758786910639328146269034278112267D0)
  77. PARAMETER (Y2D5=0.758786910639328146269034278112267D0)
  78. PARAMETER (Z2D5=0.758786910639328146269034278112267D0)
  79. PARAMETER (P2D5=0.335180055401662049861495844875346D0)
  80. *
  81. INTEGER NOPG
  82. *
  83. * Executable statements
  84. *
  85. IF (IMPR.GT.6) WRITE(IOIMP,*) 'Entrée dans ingacu'
  86. *
  87. * Méthode de nom : NCC3-1-8
  88. * Sur un cube : cubature d'ordre 1 à 8 points
  89. * espace de référence de dimension 3
  90. *
  91. * In INIPG : SEGINI PGCOUR
  92. CALL INIPG('NCC3-1-8','NEWTON-COTES','CUBE',
  93. $ 1,8,3,
  94. $ PGCOUR,
  95. $ IMPR,IRET)
  96. IF (IRET.NE.0) GOTO 9999
  97. CALL FIPG('NCC2-1-4',MYPGS,PGPRO1,IMPR,IRET)
  98. IF (IRET.NE.0) GOTO 9999
  99. CALL FIPG('NCC1-1-2',MYPGS,PGPRO2,IMPR,IRET)
  100. IF (IRET.NE.0) GOTO 9999
  101. CALL PROPG(PGPRO1,PGPRO2,PGCOUR,IMPR,IRET)
  102. IF (IRET.NE.0) GOTO 9999
  103. SEGDES PGCOUR
  104. MYPGS.LISPG(**)=PGCOUR
  105. *
  106. * Méthode de nom : NCC3-3-27
  107. * Sur un cube : cubature d'ordre 3 à 27 points
  108. * espace de référence de dimension 3
  109. *
  110. * In INIPG : SEGINI PGCOUR
  111. CALL INIPG('NCC3-3-27','NEWTON-COTES','CUBE',
  112. $ 3,27,3,
  113. $ PGCOUR,
  114. $ IMPR,IRET)
  115. IF (IRET.NE.0) GOTO 9999
  116. CALL FIPG('NCC2-3-9',MYPGS,PGPRO1,IMPR,IRET)
  117. IF (IRET.NE.0) GOTO 9999
  118. CALL FIPG('NCC1-3-3',MYPGS,PGPRO2,IMPR,IRET)
  119. IF (IRET.NE.0) GOTO 9999
  120. CALL PROPG(PGPRO1,PGPRO2,PGCOUR,IMPR,IRET)
  121. IF (IRET.NE.0) GOTO 9999
  122. SEGDES PGCOUR
  123. MYPGS.LISPG(**)=PGCOUR
  124. *
  125. * Méthode de nom : GAC3-1-1
  126. * Sur un cube : cubature d'ordre 1 à 1 point
  127. * espace de référence de dimension 3
  128. *
  129. * In INIPG : SEGINI PGCOUR
  130. CALL INIPG('GAC3-1-1','GAUSS','CUBE',
  131. $ 1,1,3,
  132. $ PGCOUR,
  133. $ IMPR,IRET)
  134. IF (IRET.NE.0) GOTO 9999
  135. NOPG=0
  136. XCOR(1)=X1D1
  137. XCOR(2)=Y1D1
  138. XCOR(3)=Z1D1
  139. CALL GCSINO(PGCOUR,NOPG,DIMSRF,XCOR,P1D1,IMPR,IRET)
  140. IF (IRET.NE.0) GOTO 9999
  141. SEGDES PGCOUR
  142. MYPGS.LISPG(**)=PGCOUR
  143. *
  144. * Méthode de nom : GAC3-3-6A
  145. * Sur un cube : cubature d'ordre 3 à 6 points
  146. * espace de référence de dimension 3
  147. *
  148. * In INIPG : SEGINI PGCOUR
  149. CALL INIPG('GAC3-3-6A','GAUSS','CUBE',
  150. $ 3,6,3,
  151. $ PGCOUR,
  152. $ IMPR,IRET)
  153. IF (IRET.NE.0) GOTO 9999
  154. NOPG=0
  155. XCOR(1)=X1D3
  156. XCOR(2)=Y1D3
  157. XCOR(3)=Z1D3
  158. CALL GCFS2(PGCOUR,NOPG,DIMSRF,XCOR,P1D3,IMPR,IRET)
  159. IF (IRET.NE.0) GOTO 9999
  160. SEGDES PGCOUR
  161. MYPGS.LISPG(**)=PGCOUR
  162. *
  163. * Méthode de nom : GPC3-3-8
  164. * Sur un cube : méthode gauss-produit d'ordre 3 à 8 points
  165. * espace de référence de dimension 3
  166. *
  167. * In INIPG : SEGINI PGCOUR
  168. CALL INIPG('GPC3-3-8','GAUSS-PRODUIT','CUBE',
  169. $ 3,8,3,
  170. $ PGCOUR,
  171. $ IMPR,IRET)
  172. IF (IRET.NE.0) GOTO 9999
  173. CALL FIPG('GPC2-3-4',MYPGS,PGPRO1,IMPR,IRET)
  174. IF (IRET.NE.0) GOTO 9999
  175. CALL FIPG('GAC1-3-2',MYPGS,PGPRO2,IMPR,IRET)
  176. IF (IRET.NE.0) GOTO 9999
  177. CALL PROPG(PGPRO1,PGPRO2,PGCOUR,IMPR,IRET)
  178. IF (IRET.NE.0) GOTO 9999
  179. SEGDES PGCOUR
  180. MYPGS.LISPG(**)=PGCOUR
  181. *
  182. * Méthode de nom : GAC3-5-14
  183. * Sur un cube : cubature d'ordre 5 à 14 points
  184. * espace de référence de dimension 3
  185. *
  186. * In INIPG : SEGINI PGCOUR
  187. CALL INIPG('GAC3-5-14','GAUSS','CUBE',
  188. $ 5,14,3,
  189. $ PGCOUR,
  190. $ IMPR,IRET)
  191. IF (IRET.NE.0) GOTO 9999
  192. NOPG=0
  193. XCOR(1)=X1D5
  194. XCOR(2)=Y1D5
  195. XCOR(3)=Z1D5
  196. CALL GCFS2(PGCOUR,NOPG,DIMSRF,XCOR,P1D5,IMPR,IRET)
  197. IF (IRET.NE.0) GOTO 9999
  198. XCOR(1)=X2D5
  199. XCOR(2)=Y2D5
  200. XCOR(3)=Z2D5
  201. CALL GCRESY(PGCOUR,NOPG,DIMSRF,XCOR,P2D5,IMPR,IRET)
  202. IF (IRET.NE.0) GOTO 9999
  203. SEGDES PGCOUR
  204. MYPGS.LISPG(**)=PGCOUR
  205. *
  206. * Méthode de nom : GPC3-5-27
  207. * Sur un cube : méthode gauss-produit d'ordre 5 à 27 points
  208. * espace de référence de dimension 3
  209. *
  210. * In INIPG : SEGINI PGCOUR
  211. CALL INIPG('GPC3-5-27','GAUSS-PRODUIT','CUBE',
  212. $ 5,27,3,
  213. $ PGCOUR,
  214. $ IMPR,IRET)
  215. IF (IRET.NE.0) GOTO 9999
  216. CALL FIPG('GPC2-5-9',MYPGS,PGPRO1,IMPR,IRET)
  217. IF (IRET.NE.0) GOTO 9999
  218. CALL FIPG('GAC1-5-3',MYPGS,PGPRO2,IMPR,IRET)
  219. IF (IRET.NE.0) GOTO 9999
  220. CALL PROPG(PGPRO1,PGPRO2,PGCOUR,IMPR,IRET)
  221. IF (IRET.NE.0) GOTO 9999
  222. SEGDES PGCOUR
  223. MYPGS.LISPG(**)=PGCOUR
  224. *
  225. * Méthode de nom : GPC3-7-64
  226. * Sur un cube : méthode gauss-produit d'ordre 7 à 64 points
  227. * espace de référence de dimension 3
  228. *
  229. * In INIPG : SEGINI PGCOUR
  230. CALL INIPG('GPC3-7-64','GAUSS-PRODUIT','CUBE',
  231. $ 7,64,3,
  232. $ PGCOUR,
  233. $ IMPR,IRET)
  234. IF (IRET.NE.0) GOTO 9999
  235. CALL FIPG('GPC2-7-16',MYPGS,PGPRO1,IMPR,IRET)
  236. IF (IRET.NE.0) GOTO 9999
  237. CALL FIPG('GAC1-7-4',MYPGS,PGPRO2,IMPR,IRET)
  238. IF (IRET.NE.0) GOTO 9999
  239. CALL PROPG(PGPRO1,PGPRO2,PGCOUR,IMPR,IRET)
  240. IF (IRET.NE.0) GOTO 9999
  241. SEGDES PGCOUR
  242. MYPGS.LISPG(**)=PGCOUR
  243. *
  244. * Normal termination
  245. *
  246. IRET=0
  247. RETURN
  248. *
  249. * Format handling
  250. *
  251. *
  252. * Error handling
  253. *
  254. 9999 CONTINUE
  255. IRET=1
  256. WRITE(IOIMP,*) 'An error was detected in subroutine ingacu'
  257. RETURN
  258. *
  259. * End of subroutine INGACU
  260. *
  261. END
  262.  
  263.  
  264.  
  265.  
  266.  
  267.  

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