Télécharger ingacu.eso

Retour à la liste

Numérotation des lignes :

  1. C INGACU SOURCE PV 07/11/23 21:17:16 5978
  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. -INC CCOPTIO
  37. CBEGININCLUDE SPOGAU
  38. SEGMENT POGAU
  39. CHARACTER*(LNNPG) NOMPG
  40. CHARACTER*(LNTPG) TYPMPG
  41. CHARACTER*(LNFPG) FORLPG
  42. INTEGER NORDPG
  43. REAL*8 XCOPG(NDLPG,NBPG)
  44. REAL*8 XPOPG(NBPG)
  45. ENDSEGMENT
  46. SEGMENT POGAUS
  47. POINTEUR LISPG(0).POGAU
  48. ENDSEGMENT
  49. CENDINCLUDE SPOGAU
  50. POINTEUR MYPGS.POGAUS
  51. POINTEUR PGCOUR.POGAU
  52. *
  53. INTEGER IMPR,IRET
  54. integer PGPRO1,PGPRO2
  55. *
  56. INTEGER DIMSRF
  57. PARAMETER(DIMSRF=3)
  58. REAL*8 XCOR(DIMSRF)
  59. *
  60. * Générateurs pour la cubature de degré 1 à 1 point : GAC3-1-1 :
  61. * - [ Fully symmetric ]
  62. REAL*8 X1D1,Y1D1,Z1D1,P1D1
  63. PARAMETER (X1D1=0.D0)
  64. PARAMETER (Y1D1=0.D0)
  65. PARAMETER (Z1D1=0.D0)
  66. PARAMETER (P1D1=8.D0)
  67. *
  68. * Générateurs pour la cubature de degré 3 à 6 points : GAC3-3-6A :
  69. * - [ Fully symmetric ]
  70. REAL*8 X1D3,Y1D3,Z1D3,P1D3
  71. PARAMETER (X1D3=1.D0)
  72. PARAMETER (Y1D3=0.D0)
  73. PARAMETER (Z1D3=0.D0)
  74. PARAMETER (P1D3=4.D0/3.D0)
  75. *
  76. * Générateurs pour la cubature de degré 5 à 14 points : GAC3-5-14 :
  77. * - [ Fully symmetric ]
  78. REAL*8 X1D5,Y1D5,Z1D5,P1D5
  79. PARAMETER (X1D5=0.795822425754221463264548820476135D0)
  80. PARAMETER (Y1D5=0.D0)
  81. PARAMETER (Z1D5=0.D0)
  82. PARAMETER (P1D5=0.886426592797783933518005540166204D0)
  83. * - [ Fully symmetric ]
  84. REAL*8 X2D5,Y2D5,Z2D5,P2D5
  85. PARAMETER (X2D5=0.758786910639328146269034278112267D0)
  86. PARAMETER (Y2D5=0.758786910639328146269034278112267D0)
  87. PARAMETER (Z2D5=0.758786910639328146269034278112267D0)
  88. PARAMETER (P2D5=0.335180055401662049861495844875346D0)
  89. *
  90. INTEGER NOPG
  91. *
  92. * Executable statements
  93. *
  94. IF (IMPR.GT.6) WRITE(IOIMP,*) 'Entrée dans ingacu'
  95. *
  96. * Méthode de nom : NCC3-1-8
  97. * Sur un cube : cubature d'ordre 1 à 8 points
  98. * espace de référence de dimension 3
  99. *
  100. * In INIPG : SEGINI PGCOUR
  101. CALL INIPG('NCC3-1-8','NEWTON-COTES','CUBE',
  102. $ 1,8,3,
  103. $ PGCOUR,
  104. $ IMPR,IRET)
  105. IF (IRET.NE.0) GOTO 9999
  106. CALL FIPG('NCC2-1-4',MYPGS,PGPRO1,IMPR,IRET)
  107. IF (IRET.NE.0) GOTO 9999
  108. CALL FIPG('NCC1-1-2',MYPGS,PGPRO2,IMPR,IRET)
  109. IF (IRET.NE.0) GOTO 9999
  110. CALL PROPG(PGPRO1,PGPRO2,PGCOUR,IMPR,IRET)
  111. IF (IRET.NE.0) GOTO 9999
  112. SEGDES PGCOUR
  113. MYPGS.LISPG(**)=PGCOUR
  114. *
  115. * Méthode de nom : NCC3-3-27
  116. * Sur un cube : cubature d'ordre 3 à 27 points
  117. * espace de référence de dimension 3
  118. *
  119. * In INIPG : SEGINI PGCOUR
  120. CALL INIPG('NCC3-3-27','NEWTON-COTES','CUBE',
  121. $ 3,27,3,
  122. $ PGCOUR,
  123. $ IMPR,IRET)
  124. IF (IRET.NE.0) GOTO 9999
  125. CALL FIPG('NCC2-3-9',MYPGS,PGPRO1,IMPR,IRET)
  126. IF (IRET.NE.0) GOTO 9999
  127. CALL FIPG('NCC1-3-3',MYPGS,PGPRO2,IMPR,IRET)
  128. IF (IRET.NE.0) GOTO 9999
  129. CALL PROPG(PGPRO1,PGPRO2,PGCOUR,IMPR,IRET)
  130. IF (IRET.NE.0) GOTO 9999
  131. SEGDES PGCOUR
  132. MYPGS.LISPG(**)=PGCOUR
  133. *
  134. * Méthode de nom : GAC3-1-1
  135. * Sur un cube : cubature d'ordre 1 à 1 point
  136. * espace de référence de dimension 3
  137. *
  138. * In INIPG : SEGINI PGCOUR
  139. CALL INIPG('GAC3-1-1','GAUSS','CUBE',
  140. $ 1,1,3,
  141. $ PGCOUR,
  142. $ IMPR,IRET)
  143. IF (IRET.NE.0) GOTO 9999
  144. NOPG=0
  145. XCOR(1)=X1D1
  146. XCOR(2)=Y1D1
  147. XCOR(3)=Z1D1
  148. CALL GCSINO(PGCOUR,NOPG,DIMSRF,XCOR,P1D1,IMPR,IRET)
  149. IF (IRET.NE.0) GOTO 9999
  150. SEGDES PGCOUR
  151. MYPGS.LISPG(**)=PGCOUR
  152. *
  153. * Méthode de nom : GAC3-3-6A
  154. * Sur un cube : cubature d'ordre 3 à 6 points
  155. * espace de référence de dimension 3
  156. *
  157. * In INIPG : SEGINI PGCOUR
  158. CALL INIPG('GAC3-3-6A','GAUSS','CUBE',
  159. $ 3,6,3,
  160. $ PGCOUR,
  161. $ IMPR,IRET)
  162. IF (IRET.NE.0) GOTO 9999
  163. NOPG=0
  164. XCOR(1)=X1D3
  165. XCOR(2)=Y1D3
  166. XCOR(3)=Z1D3
  167. CALL GCFS2(PGCOUR,NOPG,DIMSRF,XCOR,P1D3,IMPR,IRET)
  168. IF (IRET.NE.0) GOTO 9999
  169. SEGDES PGCOUR
  170. MYPGS.LISPG(**)=PGCOUR
  171. *
  172. * Méthode de nom : GPC3-3-8
  173. * Sur un cube : méthode gauss-produit d'ordre 3 à 8 points
  174. * espace de référence de dimension 3
  175. *
  176. * In INIPG : SEGINI PGCOUR
  177. CALL INIPG('GPC3-3-8','GAUSS-PRODUIT','CUBE',
  178. $ 3,8,3,
  179. $ PGCOUR,
  180. $ IMPR,IRET)
  181. IF (IRET.NE.0) GOTO 9999
  182. CALL FIPG('GPC2-3-4',MYPGS,PGPRO1,IMPR,IRET)
  183. IF (IRET.NE.0) GOTO 9999
  184. CALL FIPG('GAC1-3-2',MYPGS,PGPRO2,IMPR,IRET)
  185. IF (IRET.NE.0) GOTO 9999
  186. CALL PROPG(PGPRO1,PGPRO2,PGCOUR,IMPR,IRET)
  187. IF (IRET.NE.0) GOTO 9999
  188. SEGDES PGCOUR
  189. MYPGS.LISPG(**)=PGCOUR
  190. *
  191. * Méthode de nom : GAC3-5-14
  192. * Sur un cube : cubature d'ordre 5 à 14 points
  193. * espace de référence de dimension 3
  194. *
  195. * In INIPG : SEGINI PGCOUR
  196. CALL INIPG('GAC3-5-14','GAUSS','CUBE',
  197. $ 5,14,3,
  198. $ PGCOUR,
  199. $ IMPR,IRET)
  200. IF (IRET.NE.0) GOTO 9999
  201. NOPG=0
  202. XCOR(1)=X1D5
  203. XCOR(2)=Y1D5
  204. XCOR(3)=Z1D5
  205. CALL GCFS2(PGCOUR,NOPG,DIMSRF,XCOR,P1D5,IMPR,IRET)
  206. IF (IRET.NE.0) GOTO 9999
  207. XCOR(1)=X2D5
  208. XCOR(2)=Y2D5
  209. XCOR(3)=Z2D5
  210. CALL GCRESY(PGCOUR,NOPG,DIMSRF,XCOR,P2D5,IMPR,IRET)
  211. IF (IRET.NE.0) GOTO 9999
  212. SEGDES PGCOUR
  213. MYPGS.LISPG(**)=PGCOUR
  214. *
  215. * Méthode de nom : GPC3-5-27
  216. * Sur un cube : méthode gauss-produit d'ordre 5 à 27 points
  217. * espace de référence de dimension 3
  218. *
  219. * In INIPG : SEGINI PGCOUR
  220. CALL INIPG('GPC3-5-27','GAUSS-PRODUIT','CUBE',
  221. $ 5,27,3,
  222. $ PGCOUR,
  223. $ IMPR,IRET)
  224. IF (IRET.NE.0) GOTO 9999
  225. CALL FIPG('GPC2-5-9',MYPGS,PGPRO1,IMPR,IRET)
  226. IF (IRET.NE.0) GOTO 9999
  227. CALL FIPG('GAC1-5-3',MYPGS,PGPRO2,IMPR,IRET)
  228. IF (IRET.NE.0) GOTO 9999
  229. CALL PROPG(PGPRO1,PGPRO2,PGCOUR,IMPR,IRET)
  230. IF (IRET.NE.0) GOTO 9999
  231. SEGDES PGCOUR
  232. MYPGS.LISPG(**)=PGCOUR
  233. *
  234. * Méthode de nom : GPC3-7-64
  235. * Sur un cube : méthode gauss-produit d'ordre 7 à 64 points
  236. * espace de référence de dimension 3
  237. *
  238. * In INIPG : SEGINI PGCOUR
  239. CALL INIPG('GPC3-7-64','GAUSS-PRODUIT','CUBE',
  240. $ 7,64,3,
  241. $ PGCOUR,
  242. $ IMPR,IRET)
  243. IF (IRET.NE.0) GOTO 9999
  244. CALL FIPG('GPC2-7-16',MYPGS,PGPRO1,IMPR,IRET)
  245. IF (IRET.NE.0) GOTO 9999
  246. CALL FIPG('GAC1-7-4',MYPGS,PGPRO2,IMPR,IRET)
  247. IF (IRET.NE.0) GOTO 9999
  248. CALL PROPG(PGPRO1,PGPRO2,PGCOUR,IMPR,IRET)
  249. IF (IRET.NE.0) GOTO 9999
  250. SEGDES PGCOUR
  251. MYPGS.LISPG(**)=PGCOUR
  252. *
  253. * Normal termination
  254. *
  255. IRET=0
  256. RETURN
  257. *
  258. * Format handling
  259. *
  260. *
  261. * Error handling
  262. *
  263. 9999 CONTINUE
  264. IRET=1
  265. WRITE(IOIMP,*) 'An error was detected in subroutine ingacu'
  266. RETURN
  267. *
  268. * End of subroutine INGACU
  269. *
  270. END
  271.  
  272.  
  273.  
  274.  
  275.  

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