C KALPBG SOURCE CB215821 20/11/25 13:30:46 10792 SUBROUTINE KALPBG(NOME,DISCR,IZFFM) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> C C CE SOUS PROGRAMME CREE DES OBJETS DE TYPE FONFORM OU FONFORM0 C SUIVANT QUE ITYPI = 1 OU 0 ET CONTENANT LES FONCTIONS DE FORME C DU TYPE D'ELEMENT CONSIDERE C C ARGUMENTS D'ENTREE NOMI CHARACTER*8 TYPE ELEMENT DS TYPELT C (COMMON CCHAMTR) C ITYPI ENTIER 1 INTEGRATION NORMALE C 0 SOUS INTEGRATION C NOM2= PRP1 -> vitesses quadratiques pression P1 C NOM2= PRP0 -> vitesses quadratiques pression P0 C NOM2= PFP1 -> vitesses quadratiques pression P1 C C NOM2= MCP1 -> vitesses Iso-P2 pression P1 C NOM2= MCP0 -> vitesses Iso-P2 pression P0 C NOM2= MCF1 -> vitesses Iso-P2 pression P1/Q1 C C C IZFFM POINTEUR DE L'OBJET CR{{ C C IES=IDIM EST LA DIMENSION DE L ESPACE DE CALCUL C NES EST LA DIMENSION DE L ESPACE DE L ELEMENT DE REFERENC C NP NB DE PTS DE L ELEMENT C MP NB DE PTS PRESSION C NPG NB DE PTS D'INTEGRATION POUR LA VITESSE C MPG NB DE PTS D'INTEGRATION POUR LA PRESSION C C FN(NP,NPG) ) ELEMENT DE REF C GR(NES,NP,NPG) ) C FM(MP,NPG) ) C GM(NES,MP,NPG) ) C C HR(IES,NP,NPG) ) GRADIENT DANS LE REPERE GLOBAL DEFINI ICI C MAIS CHARGE DANS LES CALJ.. C IES=NES SI L ELEMENT EST DROIT C IES=IES SI L ELEMENT EST GAUCHE C PG(NPG) C C ----------------------------------------------------------------- C*** C C Modification du 12/01/99 : les elements dont les fonctions de formes C n'existent pas sont en commentaires C Cela correspond aux subroutines suivantes : PB602, PB802, PRPB15, C PB2003 C*** * 15/06/00 : ajout tétraèdre quadratique par gounand * * REAL*8 X(64),Y(64),Z(64) PARAMETER (NBELT=21) CHARACTER*(*) NOME,DISCR CHARACTER*8 TYPELT(NBELT),NOM1 CHARACTER*4 NOM2 -INC PPARAM -INC CCOPTIO -INC SIZFFB POINTEUR IZF1.IZFFM,IZF2.IZFFM CBEGININCLUDE SELREF SEGMENT ELREF CHARACTER*(LNNOM) NOMLRF CHARACTER*(LNFORM) FORME CHARACTER*(LNTYPL) TYPEL CHARACTER*(LNESP) ESPACE INTEGER DEGRE REAL*8 XCONOD(NDIMEL,NBNOD) INTEGER NPQUAF(NBDDL) INTEGER NUMCMP(NBDDL) INTEGER QUENOD(NBDDL) INTEGER ORDDER(NDIMEL,NBDDL) POINTEUR MBPOLY.POLYNS ENDSEGMENT SEGMENT ELREFS POINTEUR LISEL(0).ELREF ENDSEGMENT CENDINCLUDE SELREF POINTEUR MYLRFS.ELREFS POINTEUR ELVIT.ELREF POINTEUR ELPRES.ELREF CBEGININCLUDE SFALRF SEGMENT FALRF CHARACTER*(LNNFA) NOMFA INTEGER NUQUAF(NBLRF) POINTEUR ELEMF(NBLRF).ELREF ENDSEGMENT SEGMENT FALRFS POINTEUR LISFA(0).FALRF ENDSEGMENT CENDINCLUDE SFALRF POINTEUR MYFALS.FALRFS 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 POINTEUR PGCOUR.POGAU CBEGININCLUDE SMCHAEL SEGMENT MCHAEL POINTEUR IMACHE(N1).MELEME POINTEUR ICHEVA(N1).MCHEVA ENDSEGMENT SEGMENT MCHEVA REAL*8 VELCHE(NBLIG,NBCOL,N2LIG,N2COL,NBPOI,NBELM) ENDSEGMENT SEGMENT LCHEVA POINTEUR LISCHE(NBCHE).MCHEVA ENDSEGMENT CENDINCLUDE SMCHAEL POINTEUR FFPGV.MCHEVA POINTEUR DFFPGV.MCHEVA POINTEUR FFPGP.MCHEVA POINTEUR DFFPGP.MCHEVA C DATA TYPELT/'SEG2 ','TRI3 ','QUA4 ', & 'PRI6 ','CUB8 ','TET4 ','PYR5 ', C speciaux iso-P2 p1/p0 & 'TRI6 ','PR18 ','TE10 ','PY14xxxx', C quadratiques & 'SEG3 ','TRI7 ','QUA9 ', & 'PR21 ','CU27 ','TE15 ','PY19xxxx', C lineaires b & 'TRI4 ','TET5 ', C cubiques & 'SEG4 '/ C*** * * Initialisation du segment contenant les informations sur les * éléments de référence. * * SEGINI MYLRFS.LISEL(*) IMPR=0 CALL INLRFS(MYLRFS,IMPR,IRET) IF (IRET.NE.0) GOTO 9999 * * Initialisation du segment contenant les informations sur les * méthodes d'intégration (type Gauss). * * SEGINI MYPGS.LISPG(*) CALL INPGS(MYPGS,IMPR,IRET) IF (IRET.NE.0) GOTO 9999 * IZFFM=0 IF(DISCR.EQ.'FONFORM0')THEN ITYPI=0 ELSEIF(DISCR.EQ.'FONFORM ')THEN ITYPI=1 ELSEIF(DISCR.EQ.'LOBATTO ')THEN ITYPI=2 ELSE C Impossible d'utiliser cet opérateur pour la formulation %m1:8 MOTERR(1:8) = DISCR CALL ERREUR(193) RETURN ENDIF C IES=IDIM NOM1=NOME(1:4) NOM2=NOME(5:8) C WRITE(6,*)'KALPBG NOM1=',NOM1,' NOM2=',NOM2,':' CALL OPTLI(IP,TYPELT,NOM1,NBELT) C IF(IP.EQ.0)THEN WRITE(6,1981)NOME 1981 FORMAT(/10X,' SUB KALPBG : ',1X,A8,' TYPE D''ELEMENT NON ENCORE PR &EVU') RETURN ENDIF C GO TO ( & 201 ,302 ,402 ,603 ,803 ,403 ,503 , & 612 , 1813, 1013,1413, & 301 ,702 ,902 ,2103,2703,1503,1903, & 9402,9503, & 401),IP C C C100 CONTINUE C? NP=1 C? NES=0 C? NG=1 C? NPG=1 C? N1=0 C? N2=2 C? CALL ZDFM(NP,NPG,NES,IES,N1,N2,IZFFM,1) C? CALL ZDFM(NP,NPG,NES,IES,0,0,IPKKZZ,0) C? KZHR(1)=IPKKZZ C? NOMEL=TYPELT(IP) C? FN(1,1)=1.D0 C? GO TO 1 C************************** ELEMENTS LINE ****************************** C SEG2 201 CONTINUE NP=2 MP=1 IF(NOM2.EQ.'P1P1')MP=2 NES=1 NG=2 NPG=2 IF(ITYPI.EQ.0)NG=1 IF(ITYPI.EQ.0)NPG=1 N1=1 N2=2 CALL ZDFM(NP,NPG,NES,IES,N1,N2,IZFFM,1) CALL ZDFM(NP,NPG,NES,IES,0,0,IPKKZZ,0) CALL ZDFM(MP,NPG,NES,IES,0,0,IPKKZ2,0) KZHR(1)=IPKKZZ KZHR(2)=IPKKZ2 NOMEL=TYPELT(IP) CALL ZDFM(MP,NPG,NES,IES,0,1,IZF1,1) KTP(1)=IZF1 CALL PB201 &(XREF,X,PG,FN,GR,IZF1.FN,IZF1.GR,NES,NP,MP,NG,NPG,NOM2,ITYPI) GO TO 1 C TRI3 302 CONTINUE NP=3 MP=1 IF(NOM2.EQ.'P1P1')MP=3 NES=2 NPG=7 IF(ITYPI.EQ.0)NPG=1 IF(ITYPI.EQ.2)NPG=3 N1=1 N2=2 CALL ZDFM(NP,NPG,NES,IES,N1,N2,IZFFM,1) CALL ZDFM(NP,NPG,NES,IES,0,0,IPKKZZ,0) CALL ZDFM(MP,NPG,NES,IES,0,0,IPKKZ2,0) KZHR(1)=IPKKZZ KZHR(2)=IPKKZ2 NOMEL=TYPELT(IP) CALL ZDFM(MP,NPG,NES,IES,0,1,IZF1,1) KTP(1)=IZF1 CALL PB302 &(XREF,X,Y,PG,FN,GR,IZF1.FN,IZF1.GR,NES,NP,MP,NPG,NOM2,ITYPI) GO TO 1 C QUA4 402 CONTINUE NP=4 MP=1 IF(NOM2.EQ.'P1P1')MP=4 NES=2 NG=2 NPG=4 IF(ITYPI.EQ.0)NG=1 IF(ITYPI.EQ.0)NPG=1 N1=1 N2=2 CALL ZDFM(NP,NPG,NES,IES,N1,N2,IZFFM,1) CALL ZDFM(NP,NPG,NES,IES,0,0,IPKKZZ,0) CALL ZDFM(MP,NPG,NES,IES,0,0,IPKKZ2,0) KZHR(1)=IPKKZZ KZHR(2)=IPKKZ2 NOMEL=TYPELT(IP) CALL ZDFM(MP,NPG,NES,IES,0,1,IZF1,1) KTP(1)=IZF1 CALL PB402 &(XREF,X,Y,PG,FN,GR,IZF1.FN,IZF1.GR,NES,NP,MP,NG,NPG,NOM2,ITYPI) GO TO 1 C PRI6 603 CONTINUE NP=6 MP=1 IF(NOM2.EQ.'P1P1')MP=6 NES=3 NPG=6 IF(ITYPI.EQ.0)NPG=1 N1=1 N2=2 CALL ZDFM(NP,NPG,NES,IES,N1,N2,IZFFM,1) CALL ZDFM(NP,NPG,NES,IES,0,0,IPKKZZ,0) CALL ZDFM(MP,NPG,NES,IES,0,0,IPKKZ2,0) KZHR(1)=IPKKZZ KZHR(2)=IPKKZ2 CALL ZDFM(MP,NPG,NES,IES,0,1,IZF1,1) KTP(1)=IZF1 NOMEL=TYPELT(IP) CALL PB603 &(XREF,X,Y,Z,PG,FN,GR,IZF1.FN,IZF1.GR,NES,NP,MP,NPG,NOM2) GOTO 1 C CUB8 803 CONTINUE NP=8 MP=1 IF(NOM2.EQ.'P1P1')MP=8 NES=3 NG=2 NPG=8 IF(ITYPI.EQ.0)NG=1 IF(ITYPI.EQ.0)NPG=1 N1=1 N2=2 CALL ZDFM(NP,NPG,NES,IES,N1,N2,IZFFM,1) CALL ZDFM(NP,NPG,NES,IES,0,0,IPKKZZ,0) CALL ZDFM(MP,NPG,NES,IES,0,0,IPKKZ2,0) KZHR(1)=IPKKZZ KZHR(2)=IPKKZ2 CALL ZDFM(MP,NPG,NES,IES,0,1,IZF1,1) KTP(1)=IZF1 NOMEL=TYPELT(IP) CALL PB803 &(XREF,X,Y,Z,PG,FN,GR,IZF1.FN,IZF1.GR,NES,NP,MP,NG,NPG,NOM2) GO TO 1 C TET4 403 CONTINUE NP=4 MP=1 IF(NOM2.EQ.'P1P1')MP=4 NES=3 NPG=4 IF(ITYPI.EQ.0)NPG=1 N1=1 N2=2 CALL ZDFM(NP,NPG,NES,IES,N1,N2,IZFFM,1) CALL ZDFM(NP,NPG,NES,IES,0,0,IPKKZZ,0) CALL ZDFM(MP,NPG,NES,IES,0,0,IPKKZ2,0) KZHR(1)=IPKKZZ KZHR(2)=IPKKZ2 CALL ZDFM(MP,NPG,NES,IES,0,1,IZF1,1) KTP(1)=IZF1 NOMEL=TYPELT(IP) CALL PB403 &(XREF,X,Y,Z,PG,FN,GR,IZF1.FN,IZF1.GR,NES,NP,MP,NPG,NOM2) GO TO 1 C PYR5 503 CONTINUE NP=5 MP=1 IF(NOM2.EQ.'P1P1')MP=5 NES=3 NPG=5 IF(ITYPI.EQ.0)NPG=1 N1=1 N2=2 CALL ZDFM(NP,NPG,NES,IES,N1,N2,IZFFM,1) CALL ZDFM(NP,NPG,NES,IES,0,0,IPKKZZ,0) CALL ZDFM(MP,NPG,NES,IES,0,0,IPKKZ2,0) KZHR(1)=IPKKZZ KZHR(2)=IPKKZ2 CALL ZDFM(MP,NPG,NES,IES,0,1,IZF1,1) KTP(1)=IZF1 NOMEL=TYPELT(IP) CALL PB503 &(XREF,X,Y,Z,PG,FN,GR,IZF1.FN,IZF1.GR,NES,NP,MP,NPG,NOM2) GO TO 1 C************************** ELEMENTS LINB ****************************** C TRI4 9402 CONTINUE IMPR=0 CALL FILRF('H1D1TR4',MYLRFS,ELVIT,IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL FILRF('H1D1TR3',MYLRFS,ELPRES,IMPR,IRET) IF (ITYPI.EQ.0) THEN CALL FIPG('GAT2-1-1',MYPGS,PGCOUR,IMPR,IRET) IF (IRET.NE.0) GOTO 9999 ELSE CALL FIPG('GAT2-7-12',MYPGS,PGCOUR,IMPR,IRET) IF (IRET.NE.0) GOTO 9999 ENDIF * * Calculons les fns de forme de réf. et leurs dérivées aux * points de Gauss pour chaque type d'éléments... * CALL KFNREF(ELVIT,PGCOUR, $ FFPGV,DFFPGV, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL KFNREF(ELPRES,PGCOUR, $ FFPGP,DFFPGP, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 SEGACT PGCOUR SEGACT FFPGV SEGACT DFFPGV SEGACT FFPGP SEGACT DFFPGP NP =DFFPGV.VELCHE(/2) NES=DFFPGV.VELCHE(/4) NPG=DFFPGV.VELCHE(/5) MP =DFFPGP.VELCHE(/2) N1=1 N2=2 CALL ZDFM(NP,NPG,NES,IES,N1,N2,IZFFM,1) CALL ZDFM(NP,NPG,NES,IES,0,0,IPKKZZ,0) CALL ZDFM(MP,NPG,NES,IES,0,0,IPKKZ2,0) KZHR(1)=IPKKZZ KZHR(2)=IPKKZ2 CALL ZDFM(MP,NPG,NES,IES,0,1,IZF1,1) KTP(1)=IZF1 NOMEL=TYPELT(IP) CALL BB302(XREF,PGCOUR.XCOPG,PGCOUR.XPOPG, $ FFPGV.VELCHE,DFFPGV.VELCHE, $ FFPGP.VELCHE,DFFPGP.VELCHE, $ X,Y,PG,FN,GR,IZF1.FN,IZF1.GR,NES,NP,MP,NPG) SEGSUP FFPGV SEGSUP DFFPGV SEGSUP FFPGP SEGSUP DFFPGP SEGDES PGCOUR C NP=4 C MP=3 C NES=2 C NPG=7 C IF(ITYPI.EQ.0)NPG=1 C MPG=NPG C N1=1 C N2=2 C CALL ZDFM(NP,NPG,NES,IES,N1,N2,IZFFM,1) C CALL ZDFM(NP,NPG,NES,IES,0,0,IPKKZZ,0) C CALL ZDFM(MP,NPG,NES,IES,0,0,IPKKZ2,0) C KZHR(1)=IPKKZZ C KZHR(2)=IPKKZ2 C NOMEL=TYPELT(IP) C CALL ZDFM(MP,MPG,NES,IES,0,1,IZF1,1) C KTP(1)=IZF1 C CALL BB302(X,Y,PG,FN,GR,IZF1.FN,IZF1.GR,NES,NP,MP,NPG,MPG) GO TO 1 C TET5 9503 CONTINUE NP=5 MP=4 NES=3 NPG=4 IF(ITYPI.EQ.0)NG=1 IF(ITYPI.EQ.0)NPG=1 MPG=NPG N1=1 N2=2 CALL ZDFM(NP,NPG,NES,IES,N1,N2,IZFFM,1) CALL ZDFM(NP,NPG,NES,IES,0,0,IPKKZZ,0) CALL ZDFM(MP,NPG,NES,IES,0,0,IPKKZ2,0) KZHR(1)=IPKKZZ KZHR(2)=IPKKZ2 NOMEL=TYPELT(IP) CALL ZDFM(MP,MPG,NES,IES,0,1,IZF1,1) KTP(1)=IZF1 CALL BB403(X,Y,Z,PG,FN,GR,IZF1.FN,IZF1.GR,NES,NP,MP,NPG) GO TO 1 C************************** ELEMENTS MACRO ***************************** C TRI6 Iso-P2 P1/P0 612 CONTINUE NP=6 MP=3 IF(NOM2.EQ.'MCP0')MP=1 IF(NOM2.EQ.'MCP1')MP=3 IF(NOM2.EQ.'MCF1')MP=3 IF(ITYPI.EQ.0)MP=1 NES=2 NPG=7 C NPG=3 N1=1 N2=2 CALL ZDFM(NP,NPG,NES,IES,N1,N2,IZFFM,1) CALL ZDFM(NP,NPG,NES,IES,0,0,IPKKZZ,0) CALL ZDFM(MP,NPG,NES,IES,0,0,IPKKZ2,0) KZHR(1)=IPKKZZ KZHR(2)=IPKKZ2 NOMEL=TYPELT(IP) CALL ZDFM(MP,NPG,NES,IES,0,1,IZF1,1) KTP(1)=IZF1 CALL PB342 &(X,Y,PG,FN,GR,IZF1.FN,IZF1.GR,NES,NP,MP,NPG,NOM2) GO TO 1 C QUA9 Iso-P2 P1/P0 912 CONTINUE MP=3 IF(NOM2.EQ.'MCP0')MP=1 IF(NOM2.EQ.'MCP1')MP=3 IF(NOM2.EQ.'MCF1')MP=4 IF(ITYPI.EQ.0)MP=1 NP=9 NES=2 NG=2 NPG=16 N1=1 N2=2 CALL ZDFM(NP,NPG,NES,IES,N1,N2,IZFFM,1) CALL ZDFM(NP,NPG,NES,IES,0,0,IPKKZZ,0) CALL ZDFM(MP,NPG,NES,IES,0,0,IPKKZ2,0) KZHR(1)=IPKKZZ KZHR(2)=IPKKZ2 NOMEL=TYPELT(IP) CALL ZDFM(MP,NPG,NES,IES,0,1,IZF1,1) KTP(1)=IZF1 CALL PB442 &(X,Y,PG,FN,GR,IZF1.FN,IZF1.GR,NES,NP,MP,NG,NPG,NOM2) GO TO 1 C CU27 Iso-P2 P1/P0 2713 CONTINUE MP=4 IF(NOM2.EQ.'MCP0')MP=1 IF(NOM2.EQ.'MCP1')MP=4 IF(NOM2.EQ.'MCF1')MP=8 IF(ITYPI.EQ.0)MP=1 NP=27 NES=3 NG=2 NPG=64 C NG=1 C NPG=8 N1=1 N2=2 CALL ZDFM(NP,NPG,NES,IES,N1,N2,IZFFM,1) CALL ZDFM(NP,NPG,NES,IES,0 ,0 ,IPKKZZ,0) CALL ZDFM(MP,NPG,NES,IES,0,0,IPKKZ2,0) KZHR(1)=IPKKZZ KZHR(2)=IPKKZ2 NOMEL=TYPELT(IP) CALL ZDFM(MP,NPG,NES,IES,0,1,IZF1,1) KTP(1)=IZF1 CALL PB883 &(X,Y,Z,PG,FN,GR,IZF1.FN,IZF1.GR,NES,NP,MP,NG,NPG,NOM2) GO TO 1 C PR18 Iso-P2 P1/P0 1813 CONTINUE MP=4 IF(NOM2.EQ.'MCP0')MP=1 IF(NOM2.EQ.'MCP1')MP=4 IF(NOM2.EQ.'MCF1')MP=6 IF(ITYPI.EQ.0)MP=1 NP=18 NES=3 NG=6 NPG=48 C NG=1 C NPG=8 N1=1 N2=2 CALL ZDFM(NP,NPG,NES,IES,N1,N2,IZFFM,1) CALL ZDFM(NP,NPG,NES,IES,0 ,0 ,IPKKZZ,0) CALL ZDFM(MP,NPG,NES,IES,0,0,IPKKZ2,0) KZHR(1)=IPKKZZ KZHR(2)=IPKKZ2 NOMEL=TYPELT(IP) CALL ZDFM(MP,NPG,NES,IES,0,1,IZF1,1) KTP(1)=IZF1 CALL PB663 &(X,Y,Z,PG,FN,GR,IZF1.FN,IZF1.GR,NES,NP,MP,NG,NPG,NOM2) GO TO 1 C TE10 Iso-P2 P1/P0 1013 CONTINUE MP=4 IF(NOM2.EQ.'MCP0')MP=1 IF(NOM2.EQ.'MCP1')MP=4 IF(NOM2.EQ.'MCF1')MP=4 IF(ITYPI.EQ.0)MP=1 NP=10 NES=3 C NG=4 C NPG=32 NG=1 NPG=8 N1=1 N2=2 CALL ZDFM(NP,NPG,NES,IES,N1,N2,IZFFM,1) CALL ZDFM(NP,NPG,NES,IES,0 ,0 ,IPKKZZ,0) CALL ZDFM(MP,NPG,NES,IES,0,0,IPKKZ2,0) KZHR(1)=IPKKZZ KZHR(2)=IPKKZ2 NOMEL=TYPELT(IP) CALL ZDFM(MP,NPG,NES,IES,0,1,IZF1,1) KTP(1)=IZF1 CALL PB443 &(X,Y,Z,PG,FN,GR,IZF1.FN,IZF1.GR,NES,NP,MP,NG,NPG,NOM2) GO TO 1 C PY14 Iso-P2 P1/P0 1413 CONTINUE GO TO 1 C************************** ELEMENTS QUAF ****************************** C SEG3 301 CONTINUE MP=2 IF(NOM2.EQ.'PRP0')MP=1 IF(NOM2.EQ.'PRP1')MP=2 IF(NOM2.EQ.'PFP1')MP=2 IF(NOM2.EQ.'P1P1')MP=2 NP=3 NES=1 NG=3 NPG=3 IF(ITYPI.EQ.0)THEN NG=2 NPG=2 ENDIF IF(NOM2.EQ.'MCF1')THEN NG=4 NPG=4 ENDIF N1=1 N2=2 CALL ZDFM(NP,NPG,NES,IES,N1,N2,IZFFM,1) CALL ZDFM(NP,NPG,NES,IES,0,0,IPKKZZ,0) CALL ZDFM(MP,NPG,NES,IES,0,0,IPKKZ2,0) KZHR(1)=IPKKZZ KZHR(2)=IPKKZ2 NOMEL=TYPELT(IP) CALL ZDFM(MP,NPG,NES,IES,0,1,IZF1,1) KTP(1)=IZF1 CALL PB301 &(XREF,X,PG,FN,GR,IZF1.FN,IZF1.GR,NES,NP,MP,NG,NPG,NOM2,ITYPI) GO TO 1 C TRI7 702 CONTINUE MP=3 IF(NOM2.EQ.'PRP0')MP=1 IF(NOM2.EQ.'PRP1')MP=3 IF(NOM2.EQ.'PFP1')MP=3 NP=7 NES=2 NPG=7 IF(ITYPI.EQ.0)NPG=1 N1=1 N2=2 CALL ZDFM(NP,NPG,NES,IES,N1,N2,IZFFM,1) CALL ZDFM(NP,NPG,NES,IES,0,0,IPKKZZ,0) CALL ZDFM(MP,NPG,NES,IES,0,0,IPKKZ2,0) KZHR(1)=IPKKZZ KZHR(2)=IPKKZ2 CALL ZDFM(MP,NPG,NES,IES,0,1,IZF1,1) KTP(1)=IZF1 NOMEL=TYPELT(IP) CALL PB702 &(XREF,X,Y,PG,FN,GR,IZF1.FN,IZF1.GR,NES,NP,MP,NPG,NOM2,ITYPI) GO TO 1 C QUA9 902 CONTINUE IF(NOM2(1:2).EQ.'MC')GO TO 912 MP=3 IF(NOM2.EQ.'PRP0')MP=1 IF(NOM2.EQ.'PRP1')MP=3 IF(NOM2.EQ.'PFP1')MP=4 IF(NOM2.EQ.'PRQ1')MP=4 NP=9 NES=2 NG=4 NPG=16 IF(ITYPI.EQ.0)NG=3 IF(ITYPI.EQ.0)NPG=9 IF(ITYPI.EQ.2)NG=3 IF(ITYPI.EQ.2)NPG=9 N1=1 N2=2 CALL ZDFM(NP,NPG,NES,IES,N1,N2,IZFFM,1) CALL ZDFM(NP,NPG,NES,IES,0,0,IPKKZZ,0) CALL ZDFM(MP,NPG,NES,IES,0,0,IPKKZ2,0) KZHR(1)=IPKKZZ KZHR(2)=IPKKZ2 CALL ZDFM(MP,NPG,NES,IES,0,1,IZF1,1) KTP(1)=IZF1 NOMEL=TYPELT(IP) CALL PB902 &(XREF,X,Y,PG,FN,GR,IZF1.FN,IZF1.GR,NES,NP,MP,NG,NPG,NOM2,ITYPI) GO TO 1 C PR21 2103 CONTINUE MP=4 IF(NOM2.EQ.'PRP0')MP=1 IF(NOM2.EQ.'PRP1')MP=4 IF(NOM2.EQ.'PFP1')MP=6 NP=21 NES=3 NG=3 NGT=7 NPG=NG*NGT N1=1 N2=2 CALL ZDFM(NP,NPG,NES,IES,N1,N2,IZFFM,1) CALL ZDFM(NP,NPG,NES,IES,0,0,IPKKZZ,0) CALL ZDFM(MP,NPG,NES,IES,0,0,IPKKZ2,0) KZHR(1)=IPKKZZ KZHR(2)=IPKKZ2 CALL ZDFM(MP,NPG,NES,IES,0,1,IZF1,1) KTP(1)=IZF1 NOMEL=TYPELT(IP) CALL PB2103 &(XREF,X,Y,Z,PG,FN,GR,IZF1.FN,IZF1.GR,NES,NP,MP,NG,NGT,NPG,NOM2) GO TO 1 C CU27 2703 CONTINUE IF(NOM2(1:2).EQ.'MC')GO TO 2713 MP=4 IF(NOM2.EQ.'PRP0')MP=1 IF(NOM2.EQ.'PRP1')MP=4 IF(NOM2.EQ.'PFP1')MP=8 NP=27 NES=3 NG=3 NPG=27 IF(ITYPI.EQ.0)NG=2 IF(ITYPI.EQ.0)NPG=8 N1=1 N2=2 CALL ZDFM(NP,NPG,NES,IES,N1,N2,IZFFM,1) CALL ZDFM(NP,NPG,NES,IES,0,0,IPKKZZ,0) CALL ZDFM(MP,NPG,NES,IES,0,0,IPKKZ2,0) KZHR(1)=IPKKZZ KZHR(2)=IPKKZ2 CALL ZDFM(MP,NPG,NES,IES,0,1,IZF1,1) KTP(1)=IZF1 NOMEL=TYPELT(IP) CALL PB2703 &(XREF,X,Y,Z,PG,FN,GR,IZF1.FN,IZF1.GR,NES,NP,MP,NG,NPG,NOM2) GO TO 1 C TE15 1503 CONTINUE IMPR=0 CALL FILRF('H1D2TE15',MYLRFS,ELVIT,IMPR,IRET) IF (IRET.NE.0) GOTO 9999 IF (NOM2.EQ.'PRP0') THEN CALL FILRF('L2D0TE1',MYLRFS,ELPRES,IMPR,IRET) IF (IRET.NE.0) GOTO 9999 ELSEIF (NOM2.EQ.'PRP1') THEN CALL FILRF('L2D1TE4',MYLRFS,ELPRES,IMPR,IRET) IF (IRET.NE.0) GOTO 9999 ELSEIF (NOM2.EQ.'PFP1') THEN CALL FILRF('H1D1TE4',MYLRFS,ELPRES,IMPR,IRET) IF (IRET.NE.0) GOTO 9999 ELSE CALL FILRF('L2D1TE4',MYLRFS,ELPRES,IMPR,IRET) IF (IRET.NE.0) GOTO 9999 ENDIF CALL FIPG('GPT3-7-64',MYPGS,PGCOUR,IMPR,IRET) IF (IRET.NE.0) GOTO 9999 * * Calculons les fns de forme de réf. et leurs dérivées aux * points de Gauss pour chaque type d'éléments... * CALL KFNREF(ELVIT,PGCOUR, $ FFPGV,DFFPGV, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL KFNREF(ELPRES,PGCOUR, $ FFPGP,DFFPGP, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 SEGACT PGCOUR SEGACT FFPGV SEGACT DFFPGV SEGACT FFPGP SEGACT DFFPGP NP =DFFPGV.VELCHE(/2) NES=DFFPGV.VELCHE(/4) NPG=DFFPGV.VELCHE(/5) MP =DFFPGP.VELCHE(/2) N1=1 N2=2 CALL ZDFM(NP,NPG,NES,IES,N1,N2,IZFFM,1) CALL ZDFM(NP,NPG,NES,IES,0,0,IPKKZZ,0) CALL ZDFM(MP,NPG,NES,IES,0,0,IPKKZ2,0) KZHR(1)=IPKKZZ KZHR(2)=IPKKZ2 CALL ZDFM(MP,NPG,NES,IES,0,1,IZF1,1) KTP(1)=IZF1 NOMEL=TYPELT(IP) CALL PB1503(XREF,PGCOUR.XCOPG,PGCOUR.XPOPG, $ FFPGV.VELCHE,DFFPGV.VELCHE, $ FFPGP.VELCHE,DFFPGP.VELCHE, $ X,Y,Z,PG,FN,GR,IZF1.FN,IZF1.GR,NES,NP,MP,NPG) SEGSUP FFPGV SEGSUP DFFPGV SEGSUP FFPGP SEGSUP DFFPGP SEGDES PGCOUR GO TO 1 C PY19 1903 CONTINUE GO TO 1 C************************** ELEMENTS QUAD ****************************** C TRI6 602 CONTINUE C MP=3 C NP=6 C NES=2 C NPG=7 C IF(ITYPI.EQ.0)NPG=1 C N1=1 C N2=2 C CALL ZDFM(NP,NPG,NES,IES,N1,N2,IZFFM,1) C CALL ZDFM(NP,NPG,NES,IES,0,0,IPKKZZ,0) C KZHR(1)=IPKKZZ C CALL ZDFM(MP,NPG,NES,IES,0,1,IZF1,1) C KTP(1)=IZF1 C NOMEL=TYPELT(IP) C CALL PB602(X,Y,PG,FN,GR,IZF1.FN,IZF1.GR,NES,NP,MP,NPG) GO TO 1 C QUA8 802 CONTINUE C MP=4 C NP=8 C NES=2 C NG=3 C NPG=9 C IF(ITYPI.EQ.0)NG=2 C IF(ITYPI.EQ.0)NPG=4 C N1=1 C N2=2 C CALL ZDFM(NP,NPG,NES,IES,N1,N2,IZFFM,1) C CALL ZDFM(NP,NPG,NES,IES,0,0,IPKKZZ,0) C KZHR(1)=IPKKZZ C CALL ZDFM(MP,NPG,NES,IES,0,1,IZF1,1) C KTP(1)=IZF1 C NOMEL=TYPELT(IP) C CALL PB802(X,Y,PG,FN,GR,IZF1.FN,IZF1.GR,NES,NP,MP,NG,NPG) GO TO 1 C PR15 11503 CONTINUE C MP=6 C NP=15 C NES=3 C NG=3 C NGT=7 C NPG=NG*NGT C N1=1 C N2=2 C CALL ZDFM(NP,NPG,NES,IES,N1,N2,IZFFM,1) C CALL ZDFM(NP,NPG,NES,IES,0,0,IPKKZZ,0) C KZHR(1)=IPKKZZ C CALL ZDFM(MP,NPG,NES,IES,0,1,IZF1,1) C KTP(1)=IZF1 C NOMEL=TYPELT(IP) C CALL PBPR15(X,Y,Z,PG,FN,GR,IZF1.FN,IZF1.GR,NES,NP,MP,NG,NGT,NPG) GO TO 1 C CU20 2003 CONTINUE C MP=8 C NP=20 C NES=3 C NG=3 C NPG=27 C IF(ITYPI.EQ.0)NG=2 C IF(ITYPI.EQ.0)NPG=8 C N1=1 C N2=2 C CALL ZDFM(NP,NPG,NES,IES,N1,N2,IZFFM,1) C CALL ZDFM(NP,NPG,NES,IES,0,0,IPKKZZ,0) C KZHR(1)=IPKKZZ C CALL ZDFM(MP,NPG,NES,IES,0,1,IZF1,1) C KTP(1)=IZF1 C NOMEL=TYPELT(IP) C CALL PB2003(X,Y,Z,PG,FN,GR,IZF1.FN,IZF1.GR,NES,NP,MP,NG,NPG) GO TO 1 C TE10 1003 CONTINUE GO TO 1 C************************** ELEMENTS CUBIC ***************************** C SEG4 401 CONTINUE MP=3 IF(NOM2.EQ.'PRP0')MP=1 IF(NOM2.EQ.'PRP2')MP=3 NP=4 NES=1 NG=4 NPG=4 IF(ITYPI.EQ.0)NG=3 IF(ITYPI.EQ.0)NPG=3 MPG=NPG N1=1 N2=2 CALL ZDFM(NP,NPG,NES,IES,N1,N2,IZFFM,1) CALL ZDFM(NP,NPG,NES,IES,0,0,IPKKZZ,0) CALL ZDFM(MP,NPG,NES,IES,0,0,IPKKZ2,0) KZHR(1)=IPKKZZ KZHR(2)=IPKKZ2 NOMEL=TYPELT(IP) CALL ZDFM(MP,NPG,NES,IES,0,1,IZF1,1) KTP(1)=IZF1 CALL PB401(X,PG,FN,GR,IZF1.FN,IZF1.GR,NES,NP,MP,NG,NPG,MPG) GO TO 1 1 CONTINUE SEGACT MYLRFS*MOD SEGSUP MYLRFS.LISEL(*) SEGSUP MYLRFS SEGACT MYPGS*MOD SEGSUP MYPGS.LISPG(*) SEGSUP MYPGS C write(6,*)' Retour KALPBG' RETURN * * Error handling * 9999 CONTINUE WRITE(IOIMP,*) 'An error was detected in kalpbg.eso' * 153 2 * Opération illicite dans ce contexte CALL ERREUR(153) RETURN END