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

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