C INFPGS SOURCE GOUNAND 08/08/08 21:15:18 6142 SUBROUTINE INFPGS(MYFPGS,MYPGS,IMPR,IRET) IMPLICIT REAL*8 (A-H,O-Z) IMPLICIT INTEGER (I-N) C*********************************************************************** C NOM : INFPGS C PROJET : Noyau linéaire NLIN C DESCRIPTION : Initialise le segment contenant les informations sur C l'ensemble des familles de méthodes d'intégration C C LANGAGE : ESOPE C AUTEUR : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF) C mél : gounand@semt2.smts.cea.fr C*********************************************************************** C APPELES : INIFPG, FILFPG, PRFPG (initialisations, impression) C APPELE PAR : PRNLI2 C*********************************************************************** C ENTREES : * MYPGS (type POGAUS) : segment de description C des méthodes d'intégration. C ENTREES/SORTIES : - C SORTIES : * MYFPGS (type FAPGS) : segment de description C des familles de méthodes d'intégration. C TRAVAIL : * FACOUR (type FAPG) : famille courante. C * NBDFA (type ENTIER) : nombre total de familles C de méthodes d'intégration. C * INBDFA (type ENTIER) : indice de boucle sur les C familles de méthodes d'intégration. C CODE RETOUR (IRET) : = 0 si tout s'est bien passé C*********************************************************************** C VERSION : v1, 16/07/02, version initiale C HISTORIQUE : v1, 16/07/02, création C HISTORIQUE : C HISTORIQUE : C*********************************************************************** C Prière de PRENDRE LE TEMPS de compléter les commentaires C en cas de modification de ce sous-programme afin de faciliter C la maintenance ! C*********************************************************************** -INC CCOPTIO CBEGININCLUDE SPOGAU SEGMENT POGAU CHARACTER*(LNNPG) NOMPG CHARACTER*(LNTPG) TYPMPG CHARACTER*(LNFPG) FORLPG INTEGER NORDPG REAL*8 XCOPG(NDLPG,NBPG) REAL*8 XPOPG(NBPG) ENDSEGMENT SEGMENT POGAUS POINTEUR LISPG(0).POGAU ENDSEGMENT CENDINCLUDE SPOGAU POINTEUR MYPGS.POGAUS CBEGININCLUDE SFAPG SEGMENT FAPG CHARACTER*(LNNFAP) NOMFAP INTEGER NBQUAF(NBMPG) POINTEUR MPOGAU(NBMPG).POGAU ENDSEGMENT SEGMENT FAPGS POINTEUR LISFPG(0).FAPG ENDSEGMENT CENDINCLUDE SFAPG POINTEUR MYFPGS.FAPGS POINTEUR FACOUR.FAPG * INTEGER IMPR,IRET * INTEGER NBDFA,INBDFA LOGICAL LAXI * * Executable statements * IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans infpgs' SEGINI MYFPGS LAXI=(IFOUR.EQ.0) * * Famille de nom : GAM1 Gauss pour la masse (éléments linéaires) * * In INIFPG : SEGINI FACOUR CALL INIFPG('GAM1', $ FACOUR, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'SEG3','GAC1-3-2',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 IF (LAXI) THEN CALL FILFPG(FACOUR,MYPGS,'TRI7','GAT2-5-7',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 ELSE CALL FILFPG(FACOUR,MYPGS,'TRI7','GPT2-3-4',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 ENDIF IF (LAXI) THEN CALL FILFPG(FACOUR,MYPGS,'QUA9','GPC2-5-9',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 ELSE CALL FILFPG(FACOUR,MYPGS,'QUA9','GPC2-3-4',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 ENDIF CALL FILFPG(FACOUR,MYPGS,'TE15','GAT3-2-4B',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'PY19','GAPY-2-5',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'PR21','GPPR-2-6',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'CU27','GPC3-3-8',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 SEGDES FACOUR MYFPGS.LISFPG(**)=FACOUR * * Famille de nom : GAM2 Gauss pour la masse (éléments quadratiques) * * In INIFPG : SEGINI FACOUR CALL INIFPG('GAM2', $ FACOUR, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 IF (LAXI) THEN CALL FILFPG(FACOUR,MYPGS,'SEG3','GAC1-7-4',IMPR,IRET) ELSE CALL FILFPG(FACOUR,MYPGS,'SEG3','GAC1-5-3',IMPR,IRET) ENDIF IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'TRI7','GAT2-5-7',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 IF (LAXI) THEN CALL FILFPG(FACOUR,MYPGS,'QUA9','GPC2-7-16',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 ELSE CALL FILFPG(FACOUR,MYPGS,'QUA9','GPC2-5-9',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 ENDIF CALL FILFPG(FACOUR,MYPGS,'TE15','GAT3-3-8B',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'PY19','GAPY-5-27',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'PR21','GPPR-5-21',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'CU27','GPC3-5-27',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 SEGDES FACOUR MYFPGS.LISFPG(**)=FACOUR * * Famille de nom : GAR1 Gauss pour la rigidité (éléments linéaires) * * In INIFPG : SEGINI FACOUR CALL INIFPG('GAR1', $ FACOUR, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'SEG3','GAC1-3-2',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'TRI7','GAT2-1-1',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'QUA9','GPC2-3-4',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'TE15','GAT3-1-1',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'PY19','GAPY-2-5',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'PR21','GPPR-2-6',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'CU27','GPC3-3-8',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 SEGDES FACOUR MYFPGS.LISFPG(**)=FACOUR * * Famille de nom : GAR2 Gauss pour la rigidité (éléments quadratiques) * * In INIFPG : SEGINI FACOUR CALL INIFPG('GAR2', $ FACOUR, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 IF (LAXI) THEN CALL FILFPG(FACOUR,MYPGS,'SEG3','GAC1-7-4',IMPR,IRET) ELSE CALL FILFPG(FACOUR,MYPGS,'SEG3','GAC1-5-3',IMPR,IRET) ENDIF IF (IRET.NE.0) GOTO 9999 IF (LAXI) THEN CALL FILFPG(FACOUR,MYPGS,'TRI7','GAT2-5-7',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 ELSE CALL FILFPG(FACOUR,MYPGS,'TRI7','GPT2-3-4',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 ENDIF CALL FILFPG(FACOUR,MYPGS,'QUA9','GPC2-5-9',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'TE15','GAT3-3-8B',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'PY19','GAPY-5-27',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'PR21','GPPR-5-21',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'CU27','GPC3-5-27',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 SEGDES FACOUR MYFPGS.LISFPG(**)=FACOUR * * Famille de nom : NC1 Newton-Cotes * Méthodes d'intégration d'ordre au moins 1 * 6 éléments : segment, triangle, carré, tétraèdre, prisme, cube * * In INIFPG : SEGINI FACOUR CALL INIFPG('NC1 ', $ FACOUR, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'SEG3','NCC1-1-2',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'TRI7','NCT2-1-3',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'QUA9','NCC2-1-4',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'TE15','NCT3-1-4',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'PY19','NCPY-0-5',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'PR21','NCPR-1-6',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'CU27','NCC3-1-8',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 SEGDES FACOUR MYFPGS.LISFPG(**)=FACOUR * * Famille de nom : NC3 Newton-Cotes * Méthodes d'intégration d'ordre au moins 3 * 6 éléments : segment, triangle, carré, tétraèdre, prisme, cube * In INIFPG : SEGINI FACOUR CALL INIFPG('NC3 ', $ FACOUR, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'SEG3','NCC1-3-3',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'TRI7','NCT2-3-7',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'QUA9','NCC2-3-9',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 * Pas vraiment du Newton-Cotes, mais je ne sais pas quoi mettre CALL FILFPG(FACOUR,MYPGS,'TE15','GAT3-3-8B',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'PR21','NCPR-3-21',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'CU27','NCC3-3-27',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 SEGDES FACOUR MYFPGS.LISFPG(**)=FACOUR * * Famille de nom : GAU1 * Méthodes d'intégration d'ordre au moins 1 * 6 éléments : segment, triangle, carré, tétraèdre, prisme, cube * * In INIFPG : SEGINI FACOUR CALL INIFPG('GAU1', $ FACOUR, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'SEG3','GAC1-1-1',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'TRI7','GAT2-1-1',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'QUA9','GAC2-1-1',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'TE15','GAT3-1-1',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'PY19','GAPY-1-1',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'PR21','GPPR-1-1',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'CU27','GAC3-1-1',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 SEGDES FACOUR MYFPGS.LISFPG(**)=FACOUR * * Famille de nom : GAU2 * Méthodes d'intégration d'ordre au moins 2 * 6 éléments : segment, triangle, carré, tétraèdre, prisme, cube * * In INIFPG : SEGINI FACOUR CALL INIFPG('GAU2', $ FACOUR, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'SEG3','GAC1-3-2',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'TRI7','GAT2-2-3A',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'QUA9','GAC2-2-3',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'TE15','GAT3-2-4B',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'PY19','GAPY-2-5',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'PR21','GPPR-2-6',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'CU27','GAC3-3-6A',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 SEGDES FACOUR MYFPGS.LISFPG(**)=FACOUR * * Famille de nom : GAU3 * Méthodes d'intégration d'ordre au moins 3 * 6 éléments : segment, triangle, carré, tétraèdre, prisme, cube * * In INIFPG : SEGINI FACOUR CALL INIFPG('GAU3', $ FACOUR, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'SEG3','GAC1-3-2',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'TRI7','GPT2-3-4',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'QUA9','GAC2-3-4A',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'TE15','GAT3-3-8B',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'PY19','GAPY-5-27',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'PR21','GPPR-3-8',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'CU27','GAC3-3-6A',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 SEGDES FACOUR MYFPGS.LISFPG(**)=FACOUR * * Famille de nom : GAU4 * Méthodes d'intégration d'ordre au moins 4 * 6 éléments : segment, triangle, carré, tétraèdre, prisme, cube * * In INIFPG : SEGINI FACOUR CALL INIFPG('GAU4', $ FACOUR, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'SEG3','GAC1-5-3',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'TRI7','GAT2-4-6A',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'QUA9','GAC2-4-6C',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'TE15','GAT3-5-14',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'PY19','GAPY-5-27',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'PR21','GPPR-4-18',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'CU27','GAC3-5-14',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 SEGDES FACOUR MYFPGS.LISFPG(**)=FACOUR * * Famille de nom : GAU5 * Méthodes d'intégration d'ordre au moins 5 * 6 éléments : segment, triangle, carré, tétraèdre, prisme, cube * * In INIFPG : SEGINI FACOUR CALL INIFPG('GAU5', $ FACOUR, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'SEG3','GAC1-5-3',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'TRI7','GAT2-5-7',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'QUA9','GAC2-5-7A',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'TE15','GAT3-5-14',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'PY19','GAPY-5-27',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'PR21','GPPR-5-21',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'CU27','GAC3-5-14',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 SEGDES FACOUR MYFPGS.LISFPG(**)=FACOUR * * Famille de nom : GAU6 * Méthodes d'intégration d'ordre au moins 6 * 6 éléments : segment, triangle, carré, tétraèdre, prisme, cube * * In INIFPG : SEGINI FACOUR CALL INIFPG('GAU6', $ FACOUR, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'SEG3','GAC1-7-4',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'TRI7','GAT2-7-12',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'QUA9','GAC2-6-10C',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'TE15','GAT3-6-24',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'PR21','GPPR-7-48',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'CU27','GPC3-7-64',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 SEGDES FACOUR MYFPGS.LISFPG(**)=FACOUR * * Famille de nom : GAU7 * Méthodes d'intégration d'ordre au moins 7 * 6 éléments : segment, triangle, carré, tétraèdre, prisme, cube * * In INIFPG : SEGINI FACOUR CALL INIFPG('GAU7', $ FACOUR, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'SEG3','GAC1-7-4',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'TRI7','GAT2-7-12',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'QUA9','GAC2-7-12A',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'TE15','GPT3-7-64',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'PR21','GPPR-7-48',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'CU27','GPC3-7-64',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 SEGDES FACOUR MYFPGS.LISFPG(**)=FACOUR * * Famille de nom : GAP3 * Méthodes d'intégration produit d'ordre au moins 3 * 3 éléments : segment, triangle, carré * * In INIFPG : SEGINI FACOUR CALL INIFPG('GAP3', $ FACOUR, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'SEG3','GAC1-3-2',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'TRI7','GPT2-3-4',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'QUA9','GPC2-3-4',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'TE15','GAT3-3-8B',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'PY19','GAPY-5-27',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'PR21','GPPR-3-8',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'CU27','GPC3-3-8',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 SEGDES FACOUR MYFPGS.LISFPG(**)=FACOUR * * Famille de nom : GAP5 * Méthodes d'intégration produit d'ordre au moins 5 * 3 éléments : segment, triangle, carré * * In INIFPG : SEGINI FACOUR CALL INIFPG('GAP5', $ FACOUR, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'SEG3','GAC1-5-3',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'TRI7','GPT2-5-9',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'QUA9','GPC2-5-9',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'TE15','GPT3-5-27',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'PY19','GAPY-5-27',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'PR21','GPPR-5-21',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'CU27','GPC3-5-27',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 SEGDES FACOUR MYFPGS.LISFPG(**)=FACOUR * * Famille de nom : GAP7 * Méthodes d'intégration produit d'ordre au moins 7 * 4 éléments : segment, triangle, carré, tétraèdre * * In INIFPG : SEGINI FACOUR CALL INIFPG('GAP7', $ FACOUR, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'SEG3','GAC1-7-4',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'TRI7','GPT2-7-16',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'QUA9','GPC2-7-16',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'TE15','GPT3-7-64',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'PR21','GPPR-7-48',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILFPG(FACOUR,MYPGS,'CU27','GPC3-7-64',IMPR,IRET) IF (IRET.NE.0) GOTO 9999 SEGDES FACOUR MYFPGS.LISFPG(**)=FACOUR * * Impression finale * NBDFA=MYFPGS.LISFPG(/1) IF (IMPR.GT.1) THEN *! WRITE(IOIMP,*) 'Nom, QUAF, Meth. integ' DO 3 INBDFA=1,NBDFA WRITE(IOIMP,*) 'Famille de méthodes d''intégration ',INBDFA FACOUR=MYFPGS.LISFPG(INBDFA) CALL PRFPG(FACOUR,IMPR,IRET) IF (IRET.NE.0) GOTO 9999 3 CONTINUE ENDIF SEGDES MYFPGS * * Normal termination * IRET=0 RETURN * * Format handling * * * Error handling * 9999 CONTINUE IRET=1 WRITE(IOIMP,*) 'An error was detected in subroutine infpgs' RETURN * * End of subroutine INFPGS * END