Télécharger infpgs.eso

Retour à la liste

Numérotation des lignes :

  1. C INFPGS SOURCE GOUNAND 08/08/08 21:15:18 6142
  2. SUBROUTINE INFPGS(MYFPGS,MYPGS,IMPR,IRET)
  3. IMPLICIT REAL*8 (A-H,O-Z)
  4. IMPLICIT INTEGER (I-N)
  5. C***********************************************************************
  6. C NOM : INFPGS
  7. C PROJET : Noyau linéaire NLIN
  8. C DESCRIPTION : Initialise le segment contenant les informations sur
  9. C l'ensemble des familles de méthodes d'intégration
  10. C
  11. C LANGAGE : ESOPE
  12. C AUTEUR : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF)
  13. C mél : gounand@semt2.smts.cea.fr
  14. C***********************************************************************
  15. C APPELES : INIFPG, FILFPG, PRFPG (initialisations, impression)
  16. C APPELE PAR : PRNLI2
  17. C***********************************************************************
  18. C ENTREES : * MYPGS (type POGAUS) : segment de description
  19. C des méthodes d'intégration.
  20. C ENTREES/SORTIES : -
  21. C SORTIES : * MYFPGS (type FAPGS) : segment de description
  22. C des familles de méthodes d'intégration.
  23. C TRAVAIL : * FACOUR (type FAPG) : famille courante.
  24. C * NBDFA (type ENTIER) : nombre total de familles
  25. C de méthodes d'intégration.
  26. C * INBDFA (type ENTIER) : indice de boucle sur les
  27. C familles de méthodes d'intégration.
  28. C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  29. C***********************************************************************
  30. C VERSION : v1, 16/07/02, version initiale
  31. C HISTORIQUE : v1, 16/07/02, création
  32. C HISTORIQUE :
  33. C HISTORIQUE :
  34. C***********************************************************************
  35. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  36. C en cas de modification de ce sous-programme afin de faciliter
  37. C la maintenance !
  38. C***********************************************************************
  39. -INC CCOPTIO
  40. CBEGININCLUDE SPOGAU
  41. SEGMENT POGAU
  42. CHARACTER*(LNNPG) NOMPG
  43. CHARACTER*(LNTPG) TYPMPG
  44. CHARACTER*(LNFPG) FORLPG
  45. INTEGER NORDPG
  46. REAL*8 XCOPG(NDLPG,NBPG)
  47. REAL*8 XPOPG(NBPG)
  48. ENDSEGMENT
  49. SEGMENT POGAUS
  50. POINTEUR LISPG(0).POGAU
  51. ENDSEGMENT
  52. CENDINCLUDE SPOGAU
  53. POINTEUR MYPGS.POGAUS
  54. CBEGININCLUDE SFAPG
  55. SEGMENT FAPG
  56. CHARACTER*(LNNFAP) NOMFAP
  57. INTEGER NBQUAF(NBMPG)
  58. POINTEUR MPOGAU(NBMPG).POGAU
  59. ENDSEGMENT
  60. SEGMENT FAPGS
  61. POINTEUR LISFPG(0).FAPG
  62. ENDSEGMENT
  63. CENDINCLUDE SFAPG
  64. POINTEUR MYFPGS.FAPGS
  65. POINTEUR FACOUR.FAPG
  66. *
  67. INTEGER IMPR,IRET
  68. *
  69. INTEGER NBDFA,INBDFA
  70. LOGICAL LAXI
  71. *
  72. * Executable statements
  73. *
  74. IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans infpgs'
  75. SEGINI MYFPGS
  76. LAXI=(IFOUR.EQ.0)
  77. *
  78. * Famille de nom : GAM1 Gauss pour la masse (éléments linéaires)
  79. *
  80. * In INIFPG : SEGINI FACOUR
  81. CALL INIFPG('GAM1',
  82. $ FACOUR,
  83. $ IMPR,IRET)
  84. IF (IRET.NE.0) GOTO 9999
  85. CALL FILFPG(FACOUR,MYPGS,'SEG3','GAC1-3-2',IMPR,IRET)
  86. IF (IRET.NE.0) GOTO 9999
  87. IF (LAXI) THEN
  88. CALL FILFPG(FACOUR,MYPGS,'TRI7','GAT2-5-7',IMPR,IRET)
  89. IF (IRET.NE.0) GOTO 9999
  90. ELSE
  91. CALL FILFPG(FACOUR,MYPGS,'TRI7','GPT2-3-4',IMPR,IRET)
  92. IF (IRET.NE.0) GOTO 9999
  93. ENDIF
  94. IF (LAXI) THEN
  95. CALL FILFPG(FACOUR,MYPGS,'QUA9','GPC2-5-9',IMPR,IRET)
  96. IF (IRET.NE.0) GOTO 9999
  97. ELSE
  98. CALL FILFPG(FACOUR,MYPGS,'QUA9','GPC2-3-4',IMPR,IRET)
  99. IF (IRET.NE.0) GOTO 9999
  100. ENDIF
  101. CALL FILFPG(FACOUR,MYPGS,'TE15','GAT3-2-4B',IMPR,IRET)
  102. IF (IRET.NE.0) GOTO 9999
  103. CALL FILFPG(FACOUR,MYPGS,'PY19','GAPY-2-5',IMPR,IRET)
  104. IF (IRET.NE.0) GOTO 9999
  105. CALL FILFPG(FACOUR,MYPGS,'PR21','GPPR-2-6',IMPR,IRET)
  106. IF (IRET.NE.0) GOTO 9999
  107. CALL FILFPG(FACOUR,MYPGS,'CU27','GPC3-3-8',IMPR,IRET)
  108. IF (IRET.NE.0) GOTO 9999
  109. SEGDES FACOUR
  110. MYFPGS.LISFPG(**)=FACOUR
  111. *
  112. * Famille de nom : GAM2 Gauss pour la masse (éléments quadratiques)
  113. *
  114. * In INIFPG : SEGINI FACOUR
  115. CALL INIFPG('GAM2',
  116. $ FACOUR,
  117. $ IMPR,IRET)
  118. IF (IRET.NE.0) GOTO 9999
  119. IF (LAXI) THEN
  120. CALL FILFPG(FACOUR,MYPGS,'SEG3','GAC1-7-4',IMPR,IRET)
  121. ELSE
  122. CALL FILFPG(FACOUR,MYPGS,'SEG3','GAC1-5-3',IMPR,IRET)
  123. ENDIF
  124. IF (IRET.NE.0) GOTO 9999
  125. CALL FILFPG(FACOUR,MYPGS,'TRI7','GAT2-5-7',IMPR,IRET)
  126. IF (IRET.NE.0) GOTO 9999
  127. IF (LAXI) THEN
  128. CALL FILFPG(FACOUR,MYPGS,'QUA9','GPC2-7-16',IMPR,IRET)
  129. IF (IRET.NE.0) GOTO 9999
  130. ELSE
  131. CALL FILFPG(FACOUR,MYPGS,'QUA9','GPC2-5-9',IMPR,IRET)
  132. IF (IRET.NE.0) GOTO 9999
  133. ENDIF
  134. CALL FILFPG(FACOUR,MYPGS,'TE15','GAT3-3-8B',IMPR,IRET)
  135. IF (IRET.NE.0) GOTO 9999
  136. CALL FILFPG(FACOUR,MYPGS,'PY19','GAPY-5-27',IMPR,IRET)
  137. IF (IRET.NE.0) GOTO 9999
  138. CALL FILFPG(FACOUR,MYPGS,'PR21','GPPR-5-21',IMPR,IRET)
  139. IF (IRET.NE.0) GOTO 9999
  140. CALL FILFPG(FACOUR,MYPGS,'CU27','GPC3-5-27',IMPR,IRET)
  141. IF (IRET.NE.0) GOTO 9999
  142. SEGDES FACOUR
  143. MYFPGS.LISFPG(**)=FACOUR
  144. *
  145. * Famille de nom : GAR1 Gauss pour la rigidité (éléments linéaires)
  146. *
  147. * In INIFPG : SEGINI FACOUR
  148. CALL INIFPG('GAR1',
  149. $ FACOUR,
  150. $ IMPR,IRET)
  151. IF (IRET.NE.0) GOTO 9999
  152. CALL FILFPG(FACOUR,MYPGS,'SEG3','GAC1-3-2',IMPR,IRET)
  153. IF (IRET.NE.0) GOTO 9999
  154. CALL FILFPG(FACOUR,MYPGS,'TRI7','GAT2-1-1',IMPR,IRET)
  155. IF (IRET.NE.0) GOTO 9999
  156. CALL FILFPG(FACOUR,MYPGS,'QUA9','GPC2-3-4',IMPR,IRET)
  157. IF (IRET.NE.0) GOTO 9999
  158. CALL FILFPG(FACOUR,MYPGS,'TE15','GAT3-1-1',IMPR,IRET)
  159. IF (IRET.NE.0) GOTO 9999
  160. CALL FILFPG(FACOUR,MYPGS,'PY19','GAPY-2-5',IMPR,IRET)
  161. IF (IRET.NE.0) GOTO 9999
  162. CALL FILFPG(FACOUR,MYPGS,'PR21','GPPR-2-6',IMPR,IRET)
  163. IF (IRET.NE.0) GOTO 9999
  164. CALL FILFPG(FACOUR,MYPGS,'CU27','GPC3-3-8',IMPR,IRET)
  165. IF (IRET.NE.0) GOTO 9999
  166. SEGDES FACOUR
  167. MYFPGS.LISFPG(**)=FACOUR
  168. *
  169. * Famille de nom : GAR2 Gauss pour la rigidité (éléments quadratiques)
  170. *
  171. * In INIFPG : SEGINI FACOUR
  172. CALL INIFPG('GAR2',
  173. $ FACOUR,
  174. $ IMPR,IRET)
  175. IF (IRET.NE.0) GOTO 9999
  176. IF (LAXI) THEN
  177. CALL FILFPG(FACOUR,MYPGS,'SEG3','GAC1-7-4',IMPR,IRET)
  178. ELSE
  179. CALL FILFPG(FACOUR,MYPGS,'SEG3','GAC1-5-3',IMPR,IRET)
  180. ENDIF
  181. IF (IRET.NE.0) GOTO 9999
  182. IF (LAXI) THEN
  183. CALL FILFPG(FACOUR,MYPGS,'TRI7','GAT2-5-7',IMPR,IRET)
  184. IF (IRET.NE.0) GOTO 9999
  185. ELSE
  186. CALL FILFPG(FACOUR,MYPGS,'TRI7','GPT2-3-4',IMPR,IRET)
  187. IF (IRET.NE.0) GOTO 9999
  188. ENDIF
  189. CALL FILFPG(FACOUR,MYPGS,'QUA9','GPC2-5-9',IMPR,IRET)
  190. IF (IRET.NE.0) GOTO 9999
  191. CALL FILFPG(FACOUR,MYPGS,'TE15','GAT3-3-8B',IMPR,IRET)
  192. IF (IRET.NE.0) GOTO 9999
  193. CALL FILFPG(FACOUR,MYPGS,'PY19','GAPY-5-27',IMPR,IRET)
  194. IF (IRET.NE.0) GOTO 9999
  195. CALL FILFPG(FACOUR,MYPGS,'PR21','GPPR-5-21',IMPR,IRET)
  196. IF (IRET.NE.0) GOTO 9999
  197. CALL FILFPG(FACOUR,MYPGS,'CU27','GPC3-5-27',IMPR,IRET)
  198. IF (IRET.NE.0) GOTO 9999
  199. SEGDES FACOUR
  200. MYFPGS.LISFPG(**)=FACOUR
  201. *
  202. * Famille de nom : NC1 Newton-Cotes
  203. * Méthodes d'intégration d'ordre au moins 1
  204. * 6 éléments : segment, triangle, carré, tétraèdre, prisme, cube
  205. *
  206. * In INIFPG : SEGINI FACOUR
  207. CALL INIFPG('NC1 ',
  208. $ FACOUR,
  209. $ IMPR,IRET)
  210. IF (IRET.NE.0) GOTO 9999
  211. CALL FILFPG(FACOUR,MYPGS,'SEG3','NCC1-1-2',IMPR,IRET)
  212. IF (IRET.NE.0) GOTO 9999
  213. CALL FILFPG(FACOUR,MYPGS,'TRI7','NCT2-1-3',IMPR,IRET)
  214. IF (IRET.NE.0) GOTO 9999
  215. CALL FILFPG(FACOUR,MYPGS,'QUA9','NCC2-1-4',IMPR,IRET)
  216. IF (IRET.NE.0) GOTO 9999
  217. CALL FILFPG(FACOUR,MYPGS,'TE15','NCT3-1-4',IMPR,IRET)
  218. IF (IRET.NE.0) GOTO 9999
  219. CALL FILFPG(FACOUR,MYPGS,'PY19','NCPY-0-5',IMPR,IRET)
  220. IF (IRET.NE.0) GOTO 9999
  221. CALL FILFPG(FACOUR,MYPGS,'PR21','NCPR-1-6',IMPR,IRET)
  222. IF (IRET.NE.0) GOTO 9999
  223. CALL FILFPG(FACOUR,MYPGS,'CU27','NCC3-1-8',IMPR,IRET)
  224. IF (IRET.NE.0) GOTO 9999
  225. SEGDES FACOUR
  226. MYFPGS.LISFPG(**)=FACOUR
  227. *
  228. * Famille de nom : NC3 Newton-Cotes
  229. * Méthodes d'intégration d'ordre au moins 3
  230. * 6 éléments : segment, triangle, carré, tétraèdre, prisme, cube
  231. * In INIFPG : SEGINI FACOUR
  232. CALL INIFPG('NC3 ',
  233. $ FACOUR,
  234. $ IMPR,IRET)
  235. IF (IRET.NE.0) GOTO 9999
  236. CALL FILFPG(FACOUR,MYPGS,'SEG3','NCC1-3-3',IMPR,IRET)
  237. IF (IRET.NE.0) GOTO 9999
  238. CALL FILFPG(FACOUR,MYPGS,'TRI7','NCT2-3-7',IMPR,IRET)
  239. IF (IRET.NE.0) GOTO 9999
  240. CALL FILFPG(FACOUR,MYPGS,'QUA9','NCC2-3-9',IMPR,IRET)
  241. IF (IRET.NE.0) GOTO 9999
  242. * Pas vraiment du Newton-Cotes, mais je ne sais pas quoi mettre
  243. CALL FILFPG(FACOUR,MYPGS,'TE15','GAT3-3-8B',IMPR,IRET)
  244. IF (IRET.NE.0) GOTO 9999
  245. CALL FILFPG(FACOUR,MYPGS,'PR21','NCPR-3-21',IMPR,IRET)
  246. IF (IRET.NE.0) GOTO 9999
  247. CALL FILFPG(FACOUR,MYPGS,'CU27','NCC3-3-27',IMPR,IRET)
  248. IF (IRET.NE.0) GOTO 9999
  249. SEGDES FACOUR
  250. MYFPGS.LISFPG(**)=FACOUR
  251. *
  252. * Famille de nom : GAU1
  253. * Méthodes d'intégration d'ordre au moins 1
  254. * 6 éléments : segment, triangle, carré, tétraèdre, prisme, cube
  255. *
  256. * In INIFPG : SEGINI FACOUR
  257. CALL INIFPG('GAU1',
  258. $ FACOUR,
  259. $ IMPR,IRET)
  260. IF (IRET.NE.0) GOTO 9999
  261. CALL FILFPG(FACOUR,MYPGS,'SEG3','GAC1-1-1',IMPR,IRET)
  262. IF (IRET.NE.0) GOTO 9999
  263. CALL FILFPG(FACOUR,MYPGS,'TRI7','GAT2-1-1',IMPR,IRET)
  264. IF (IRET.NE.0) GOTO 9999
  265. CALL FILFPG(FACOUR,MYPGS,'QUA9','GAC2-1-1',IMPR,IRET)
  266. IF (IRET.NE.0) GOTO 9999
  267. CALL FILFPG(FACOUR,MYPGS,'TE15','GAT3-1-1',IMPR,IRET)
  268. IF (IRET.NE.0) GOTO 9999
  269. CALL FILFPG(FACOUR,MYPGS,'PY19','GAPY-1-1',IMPR,IRET)
  270. IF (IRET.NE.0) GOTO 9999
  271. CALL FILFPG(FACOUR,MYPGS,'PR21','GPPR-1-1',IMPR,IRET)
  272. IF (IRET.NE.0) GOTO 9999
  273. CALL FILFPG(FACOUR,MYPGS,'CU27','GAC3-1-1',IMPR,IRET)
  274. IF (IRET.NE.0) GOTO 9999
  275. SEGDES FACOUR
  276. MYFPGS.LISFPG(**)=FACOUR
  277. *
  278. * Famille de nom : GAU2
  279. * Méthodes d'intégration d'ordre au moins 2
  280. * 6 éléments : segment, triangle, carré, tétraèdre, prisme, cube
  281. *
  282. * In INIFPG : SEGINI FACOUR
  283. CALL INIFPG('GAU2',
  284. $ FACOUR,
  285. $ IMPR,IRET)
  286. IF (IRET.NE.0) GOTO 9999
  287. CALL FILFPG(FACOUR,MYPGS,'SEG3','GAC1-3-2',IMPR,IRET)
  288. IF (IRET.NE.0) GOTO 9999
  289. CALL FILFPG(FACOUR,MYPGS,'TRI7','GAT2-2-3A',IMPR,IRET)
  290. IF (IRET.NE.0) GOTO 9999
  291. CALL FILFPG(FACOUR,MYPGS,'QUA9','GAC2-2-3',IMPR,IRET)
  292. IF (IRET.NE.0) GOTO 9999
  293. CALL FILFPG(FACOUR,MYPGS,'TE15','GAT3-2-4B',IMPR,IRET)
  294. IF (IRET.NE.0) GOTO 9999
  295. CALL FILFPG(FACOUR,MYPGS,'PY19','GAPY-2-5',IMPR,IRET)
  296. IF (IRET.NE.0) GOTO 9999
  297. CALL FILFPG(FACOUR,MYPGS,'PR21','GPPR-2-6',IMPR,IRET)
  298. IF (IRET.NE.0) GOTO 9999
  299. CALL FILFPG(FACOUR,MYPGS,'CU27','GAC3-3-6A',IMPR,IRET)
  300. IF (IRET.NE.0) GOTO 9999
  301. SEGDES FACOUR
  302. MYFPGS.LISFPG(**)=FACOUR
  303. *
  304. * Famille de nom : GAU3
  305. * Méthodes d'intégration d'ordre au moins 3
  306. * 6 éléments : segment, triangle, carré, tétraèdre, prisme, cube
  307. *
  308. * In INIFPG : SEGINI FACOUR
  309. CALL INIFPG('GAU3',
  310. $ FACOUR,
  311. $ IMPR,IRET)
  312. IF (IRET.NE.0) GOTO 9999
  313. CALL FILFPG(FACOUR,MYPGS,'SEG3','GAC1-3-2',IMPR,IRET)
  314. IF (IRET.NE.0) GOTO 9999
  315. CALL FILFPG(FACOUR,MYPGS,'TRI7','GPT2-3-4',IMPR,IRET)
  316. IF (IRET.NE.0) GOTO 9999
  317. CALL FILFPG(FACOUR,MYPGS,'QUA9','GAC2-3-4A',IMPR,IRET)
  318. IF (IRET.NE.0) GOTO 9999
  319. CALL FILFPG(FACOUR,MYPGS,'TE15','GAT3-3-8B',IMPR,IRET)
  320. IF (IRET.NE.0) GOTO 9999
  321. CALL FILFPG(FACOUR,MYPGS,'PY19','GAPY-5-27',IMPR,IRET)
  322. IF (IRET.NE.0) GOTO 9999
  323. CALL FILFPG(FACOUR,MYPGS,'PR21','GPPR-3-8',IMPR,IRET)
  324. IF (IRET.NE.0) GOTO 9999
  325. CALL FILFPG(FACOUR,MYPGS,'CU27','GAC3-3-6A',IMPR,IRET)
  326. IF (IRET.NE.0) GOTO 9999
  327. SEGDES FACOUR
  328. MYFPGS.LISFPG(**)=FACOUR
  329. *
  330. * Famille de nom : GAU4
  331. * Méthodes d'intégration d'ordre au moins 4
  332. * 6 éléments : segment, triangle, carré, tétraèdre, prisme, cube
  333. *
  334. * In INIFPG : SEGINI FACOUR
  335. CALL INIFPG('GAU4',
  336. $ FACOUR,
  337. $ IMPR,IRET)
  338. IF (IRET.NE.0) GOTO 9999
  339. CALL FILFPG(FACOUR,MYPGS,'SEG3','GAC1-5-3',IMPR,IRET)
  340. IF (IRET.NE.0) GOTO 9999
  341. CALL FILFPG(FACOUR,MYPGS,'TRI7','GAT2-4-6A',IMPR,IRET)
  342. IF (IRET.NE.0) GOTO 9999
  343. CALL FILFPG(FACOUR,MYPGS,'QUA9','GAC2-4-6C',IMPR,IRET)
  344. IF (IRET.NE.0) GOTO 9999
  345. CALL FILFPG(FACOUR,MYPGS,'TE15','GAT3-5-14',IMPR,IRET)
  346. IF (IRET.NE.0) GOTO 9999
  347. CALL FILFPG(FACOUR,MYPGS,'PY19','GAPY-5-27',IMPR,IRET)
  348. IF (IRET.NE.0) GOTO 9999
  349. CALL FILFPG(FACOUR,MYPGS,'PR21','GPPR-4-18',IMPR,IRET)
  350. IF (IRET.NE.0) GOTO 9999
  351. CALL FILFPG(FACOUR,MYPGS,'CU27','GAC3-5-14',IMPR,IRET)
  352. IF (IRET.NE.0) GOTO 9999
  353. SEGDES FACOUR
  354. MYFPGS.LISFPG(**)=FACOUR
  355. *
  356. * Famille de nom : GAU5
  357. * Méthodes d'intégration d'ordre au moins 5
  358. * 6 éléments : segment, triangle, carré, tétraèdre, prisme, cube
  359. *
  360. * In INIFPG : SEGINI FACOUR
  361. CALL INIFPG('GAU5',
  362. $ FACOUR,
  363. $ IMPR,IRET)
  364. IF (IRET.NE.0) GOTO 9999
  365. CALL FILFPG(FACOUR,MYPGS,'SEG3','GAC1-5-3',IMPR,IRET)
  366. IF (IRET.NE.0) GOTO 9999
  367. CALL FILFPG(FACOUR,MYPGS,'TRI7','GAT2-5-7',IMPR,IRET)
  368. IF (IRET.NE.0) GOTO 9999
  369. CALL FILFPG(FACOUR,MYPGS,'QUA9','GAC2-5-7A',IMPR,IRET)
  370. IF (IRET.NE.0) GOTO 9999
  371. CALL FILFPG(FACOUR,MYPGS,'TE15','GAT3-5-14',IMPR,IRET)
  372. IF (IRET.NE.0) GOTO 9999
  373. CALL FILFPG(FACOUR,MYPGS,'PY19','GAPY-5-27',IMPR,IRET)
  374. IF (IRET.NE.0) GOTO 9999
  375. CALL FILFPG(FACOUR,MYPGS,'PR21','GPPR-5-21',IMPR,IRET)
  376. IF (IRET.NE.0) GOTO 9999
  377. CALL FILFPG(FACOUR,MYPGS,'CU27','GAC3-5-14',IMPR,IRET)
  378. IF (IRET.NE.0) GOTO 9999
  379. SEGDES FACOUR
  380. MYFPGS.LISFPG(**)=FACOUR
  381. *
  382. * Famille de nom : GAU6
  383. * Méthodes d'intégration d'ordre au moins 6
  384. * 6 éléments : segment, triangle, carré, tétraèdre, prisme, cube
  385. *
  386. * In INIFPG : SEGINI FACOUR
  387. CALL INIFPG('GAU6',
  388. $ FACOUR,
  389. $ IMPR,IRET)
  390. IF (IRET.NE.0) GOTO 9999
  391. CALL FILFPG(FACOUR,MYPGS,'SEG3','GAC1-7-4',IMPR,IRET)
  392. IF (IRET.NE.0) GOTO 9999
  393. CALL FILFPG(FACOUR,MYPGS,'TRI7','GAT2-7-12',IMPR,IRET)
  394. IF (IRET.NE.0) GOTO 9999
  395. CALL FILFPG(FACOUR,MYPGS,'QUA9','GAC2-6-10C',IMPR,IRET)
  396. IF (IRET.NE.0) GOTO 9999
  397. CALL FILFPG(FACOUR,MYPGS,'TE15','GAT3-6-24',IMPR,IRET)
  398. IF (IRET.NE.0) GOTO 9999
  399. CALL FILFPG(FACOUR,MYPGS,'PR21','GPPR-7-48',IMPR,IRET)
  400. IF (IRET.NE.0) GOTO 9999
  401. CALL FILFPG(FACOUR,MYPGS,'CU27','GPC3-7-64',IMPR,IRET)
  402. IF (IRET.NE.0) GOTO 9999
  403. SEGDES FACOUR
  404. MYFPGS.LISFPG(**)=FACOUR
  405. *
  406. * Famille de nom : GAU7
  407. * Méthodes d'intégration d'ordre au moins 7
  408. * 6 éléments : segment, triangle, carré, tétraèdre, prisme, cube
  409. *
  410. * In INIFPG : SEGINI FACOUR
  411. CALL INIFPG('GAU7',
  412. $ FACOUR,
  413. $ IMPR,IRET)
  414. IF (IRET.NE.0) GOTO 9999
  415. CALL FILFPG(FACOUR,MYPGS,'SEG3','GAC1-7-4',IMPR,IRET)
  416. IF (IRET.NE.0) GOTO 9999
  417. CALL FILFPG(FACOUR,MYPGS,'TRI7','GAT2-7-12',IMPR,IRET)
  418. IF (IRET.NE.0) GOTO 9999
  419. CALL FILFPG(FACOUR,MYPGS,'QUA9','GAC2-7-12A',IMPR,IRET)
  420. IF (IRET.NE.0) GOTO 9999
  421. CALL FILFPG(FACOUR,MYPGS,'TE15','GPT3-7-64',IMPR,IRET)
  422. IF (IRET.NE.0) GOTO 9999
  423. CALL FILFPG(FACOUR,MYPGS,'PR21','GPPR-7-48',IMPR,IRET)
  424. IF (IRET.NE.0) GOTO 9999
  425. CALL FILFPG(FACOUR,MYPGS,'CU27','GPC3-7-64',IMPR,IRET)
  426. IF (IRET.NE.0) GOTO 9999
  427. SEGDES FACOUR
  428. MYFPGS.LISFPG(**)=FACOUR
  429. *
  430. * Famille de nom : GAP3
  431. * Méthodes d'intégration produit d'ordre au moins 3
  432. * 3 éléments : segment, triangle, carré
  433. *
  434. * In INIFPG : SEGINI FACOUR
  435. CALL INIFPG('GAP3',
  436. $ FACOUR,
  437. $ IMPR,IRET)
  438. IF (IRET.NE.0) GOTO 9999
  439. CALL FILFPG(FACOUR,MYPGS,'SEG3','GAC1-3-2',IMPR,IRET)
  440. IF (IRET.NE.0) GOTO 9999
  441. CALL FILFPG(FACOUR,MYPGS,'TRI7','GPT2-3-4',IMPR,IRET)
  442. IF (IRET.NE.0) GOTO 9999
  443. CALL FILFPG(FACOUR,MYPGS,'QUA9','GPC2-3-4',IMPR,IRET)
  444. IF (IRET.NE.0) GOTO 9999
  445. CALL FILFPG(FACOUR,MYPGS,'TE15','GAT3-3-8B',IMPR,IRET)
  446. IF (IRET.NE.0) GOTO 9999
  447. CALL FILFPG(FACOUR,MYPGS,'PY19','GAPY-5-27',IMPR,IRET)
  448. IF (IRET.NE.0) GOTO 9999
  449. CALL FILFPG(FACOUR,MYPGS,'PR21','GPPR-3-8',IMPR,IRET)
  450. IF (IRET.NE.0) GOTO 9999
  451. CALL FILFPG(FACOUR,MYPGS,'CU27','GPC3-3-8',IMPR,IRET)
  452. IF (IRET.NE.0) GOTO 9999
  453. SEGDES FACOUR
  454. MYFPGS.LISFPG(**)=FACOUR
  455. *
  456. * Famille de nom : GAP5
  457. * Méthodes d'intégration produit d'ordre au moins 5
  458. * 3 éléments : segment, triangle, carré
  459. *
  460. * In INIFPG : SEGINI FACOUR
  461. CALL INIFPG('GAP5',
  462. $ FACOUR,
  463. $ IMPR,IRET)
  464. IF (IRET.NE.0) GOTO 9999
  465. CALL FILFPG(FACOUR,MYPGS,'SEG3','GAC1-5-3',IMPR,IRET)
  466. IF (IRET.NE.0) GOTO 9999
  467. CALL FILFPG(FACOUR,MYPGS,'TRI7','GPT2-5-9',IMPR,IRET)
  468. IF (IRET.NE.0) GOTO 9999
  469. CALL FILFPG(FACOUR,MYPGS,'QUA9','GPC2-5-9',IMPR,IRET)
  470. IF (IRET.NE.0) GOTO 9999
  471. CALL FILFPG(FACOUR,MYPGS,'TE15','GPT3-5-27',IMPR,IRET)
  472. IF (IRET.NE.0) GOTO 9999
  473. CALL FILFPG(FACOUR,MYPGS,'PY19','GAPY-5-27',IMPR,IRET)
  474. IF (IRET.NE.0) GOTO 9999
  475. CALL FILFPG(FACOUR,MYPGS,'PR21','GPPR-5-21',IMPR,IRET)
  476. IF (IRET.NE.0) GOTO 9999
  477. CALL FILFPG(FACOUR,MYPGS,'CU27','GPC3-5-27',IMPR,IRET)
  478. IF (IRET.NE.0) GOTO 9999
  479. SEGDES FACOUR
  480. MYFPGS.LISFPG(**)=FACOUR
  481. *
  482. * Famille de nom : GAP7
  483. * Méthodes d'intégration produit d'ordre au moins 7
  484. * 4 éléments : segment, triangle, carré, tétraèdre
  485. *
  486. * In INIFPG : SEGINI FACOUR
  487. CALL INIFPG('GAP7',
  488. $ FACOUR,
  489. $ IMPR,IRET)
  490. IF (IRET.NE.0) GOTO 9999
  491. CALL FILFPG(FACOUR,MYPGS,'SEG3','GAC1-7-4',IMPR,IRET)
  492. IF (IRET.NE.0) GOTO 9999
  493. CALL FILFPG(FACOUR,MYPGS,'TRI7','GPT2-7-16',IMPR,IRET)
  494. IF (IRET.NE.0) GOTO 9999
  495. CALL FILFPG(FACOUR,MYPGS,'QUA9','GPC2-7-16',IMPR,IRET)
  496. IF (IRET.NE.0) GOTO 9999
  497. CALL FILFPG(FACOUR,MYPGS,'TE15','GPT3-7-64',IMPR,IRET)
  498. IF (IRET.NE.0) GOTO 9999
  499. CALL FILFPG(FACOUR,MYPGS,'PR21','GPPR-7-48',IMPR,IRET)
  500. IF (IRET.NE.0) GOTO 9999
  501. CALL FILFPG(FACOUR,MYPGS,'CU27','GPC3-7-64',IMPR,IRET)
  502. IF (IRET.NE.0) GOTO 9999
  503. SEGDES FACOUR
  504. MYFPGS.LISFPG(**)=FACOUR
  505. *
  506. * Impression finale
  507. *
  508. NBDFA=MYFPGS.LISFPG(/1)
  509. IF (IMPR.GT.1) THEN
  510. *! WRITE(IOIMP,*) 'Nom, QUAF, Meth. integ'
  511. DO 3 INBDFA=1,NBDFA
  512. WRITE(IOIMP,*) 'Famille de méthodes d''intégration ',INBDFA
  513. FACOUR=MYFPGS.LISFPG(INBDFA)
  514. CALL PRFPG(FACOUR,IMPR,IRET)
  515. IF (IRET.NE.0) GOTO 9999
  516. 3 CONTINUE
  517. ENDIF
  518. SEGDES MYFPGS
  519. *
  520. * Normal termination
  521. *
  522. IRET=0
  523. RETURN
  524. *
  525. * Format handling
  526. *
  527. *
  528. * Error handling
  529. *
  530. 9999 CONTINUE
  531. IRET=1
  532. WRITE(IOIMP,*) 'An error was detected in subroutine infpgs'
  533. RETURN
  534. *
  535. * End of subroutine INFPGS
  536. *
  537. END
  538.  
  539.  
  540.  
  541.  

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