C NIF SOURCE FANDEUR 22/05/02 21:15:27 11359 SUBROUTINE NIF(LRFVOL,JXCOPG,PNM1, $ FNPG,DFNPG, $ IMPR,IRET) IMPLICIT REAL*8 (A-H,O-Z) IMPLICIT INTEGER (I-N) C*********************************************************************** C NOM : NIF C PROJET : Noyau linéaire NLIN C DESCRIPTION : Calcul des valeurs des fonctions de forme et des C valeurs de leurs dérivées premières aux points de Gauss. C C On utilise la relation (produit) suivante : C C < Ni (point) > = < Pi (point) > [Pn]^{-1} C C avec (cf. CALPN) : C [PN] = ( P1(ksi1) ..... Pn(ksi1)) C ( ... ..... ... ) C ( P1(ksin) ..... Pn(ksin)) C n = nb. ddl sur l'élément (NDFN) C ksii = coords. du ieme noeud d'approximation C dans l'espace de référence (de dimension C NDIML) C Pi = ieme polynome d'interpolation sur C l'élément de référence. C Ni = ieme fonction nodale d'interpolation sur C l'élément de référence. C point= point quelconque sur l'élément de référence C (donc en particulier les points de Gauss) C LANGAGE : Esope C AUTEUR : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF) C mél : gounand@semt2.smts.cea.fr C*********************************************************************** C APPELES : VALPOL, NOMINC C APPELE PAR : KFNREF C*********************************************************************** C ENTREES : LRFVOL, MYPG, PNM1 C ENTREES/SORTIES : - C SORTIES : FNPG, DFNPG C CODE RETOUR (IRET) : = 0 si tout s'est bien passé C*********************************************************************** C VERSION : v1, 16/09/99, version initiale C HISTORIQUE : v1, 16/09/99, création C HISTORIQUE : v2, 10/05/00, modif. du segment ELREF 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 PPARAM -INC CCOPTIO -INC TNLIN *-INC SELREF POINTEUR LRFVOL.ELREF *-INC SPOLYNO POINTEUR MYBPOL.POLYNS POINTEUR MYPOLY.POLYNO -INC TMXMAT POINTEUR PNM1.MXMAT -INC SMLENTI INTEGER JG POINTEUR ORDER1.MLENTI -INC SMLREEL POINTEUR VECTPI.MLREEL *-INC SMCHAEL POINTEUR JXCOPG.MCHEVA INTEGER NBLIG,NBCOL,N2LIG,N2COL,NBPOI,NBELM POINTEUR FNPG.MCHEVA POINTEUR DFNPG.MCHEVA * INTEGER IMPR,IRET * * Fonction Blas (produit scalaire) * REAL*8 DDOT EXTERNAL DDOT * INTEGER NBMONO INTEGER NDIMQR, NPGFAC,NBFN,NBELFV INTEGER IDIMQR,JDIMQR,IPGFAC,IBFN,IBELFV * * Executable statements * IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans nif' * * Initialisations * * SEGPRT,JXCOPG * SEGPRT,LRFVOL * SEGPRT,PNM1 SEGACT JXCOPG NDIMQR=JXCOPG.WELCHE(/4) NPGFAC=JXCOPG.WELCHE(/5) NBELFV=JXCOPG.WELCHE(/6) SEGACT LRFVOL MYBPOL=LRFVOL.MBPOLY SEGDES LRFVOL SEGACT MYBPOL SEGACT MYBPOL.LIPOLY(*) NBFN=MYBPOL.LIPOLY(/1) SEGACT PNM1 JG=NDIMQR SEGINI ORDER1 JG=NBFN SEGINI VECTPI * * On calcule les valeurs des fonctions de forme aux points de Gauss * NBLIG=1 NBCOL=NBFN N2LIG=1 N2COL=1 NBPOI=NPGFAC NBELM=NBELFV SEGINI FNPG DO 1 IDIMQR=1,NDIMQR ORDER1.LECT(IDIMQR)=0 1 CONTINUE DO IBELFV=1,NBELFV DO 3 IPGFAC=1,NPGFAC * Calcul de < P (pg) > = < P1(pg) ... Pnbfn(pg) > où pg est le * IPGFACieme point de Gauss DO 32 IBFN=1,NBFN MYPOLY=MYBPOL.LIPOLY(IBFN) NBMONO=MYPOLY.EXPMON(/2) CALL VALPOL(NDIMQR,NBMONO, $ JXCOPG.WELCHE(1,1,1,1,IPGFAC,IBELFV), $ MYPOLY.COEMON,MYPOLY.EXPMON, $ ORDER1.LECT, $ VECTPI.PROG(IBFN), $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 32 CONTINUE * On calcule : < N (pg) > = < P (pg) > [Pn]^{-1} DO 34 IBFN=1,NBFN FNPG.WELCHE(1,IBFN,1,1,IPGFAC,IBELFV)= $ DDOT(NBFN,VECTPI.PROG,1,PNM1.XMAT(1,IBFN),1) 34 CONTINUE 3 CONTINUE IF (IMPR.GT.3) THEN WRITE(IOIMP,*) 'Face n° ',IBELFV WRITE(IOIMP,*) 'Ordre de dérivation / coordonnée de réf. :' WRITE(IOIMP,4003) (ORDER1.LECT(IDIMQR),IDIMQR=1,NDIMQR) DO 5 IPGFAC=1,NPGFAC WRITE(IOIMP,*) 'Noeud de coordonnées :' WRITE(IOIMP,4004) $ (JXCOPG.WELCHE(1,1,1,IDIMQR,IPGFAC,IBELFV),IDIMQR=1 $ ,NDIMQR) WRITE(IOIMP,*) 'FNPG.WELCHE(nb.fns.forme) :' WRITE(IOIMP,4004) $ (FNPG.WELCHE(1,IBFN,1,1,IPGFAC,IBELFV),IBFN=1,NBFN $ ) 5 CONTINUE ENDIF ENDDO SEGDES FNPG * * On calcule les valeurs des dérivées premières des fonctions * de forme aux points de Gauss * NBLIG=1 NBCOL=NBFN N2LIG=1 N2COL=NDIMQR NBPOI=NPGFAC NBELM=NBELFV SEGINI DFNPG DO 7 IDIMQR=1,NDIMQR DO 72 JDIMQR=1,NDIMQR IF (JDIMQR.EQ.IDIMQR) THEN ORDER1.LECT(JDIMQR)=1 ELSE ORDER1.LECT(JDIMQR)=0 ENDIF 72 CONTINUE DO IBELFV=1,NBELFV DO 74 IPGFAC=1,NPGFAC DO 742 IBFN=1,NBFN * Calcul de < dP/dksi_idimqr (pg) > où pg est le * IPGFACieme point de Gauss MYPOLY=MYBPOL.LIPOLY(IBFN) NBMONO=MYPOLY.EXPMON(/2) CALL VALPOL(NDIMQR,NBMONO, $ JXCOPG.WELCHE(1,1,1,1,IPGFAC,IBELFV), $ MYPOLY.COEMON,MYPOLY.EXPMON, $ ORDER1.LECT, $ VECTPI.PROG(IBFN), $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 742 CONTINUE * On calcule : < dN/dksi_idimqr (pg) > = < dP/dksi_idimqr (pg) > [Pn]^{-1} DO 744 IBFN=1,NBFN DFNPG.WELCHE(1,IBFN,1,IDIMQR,IPGFAC,IBELFV)= $ DDOT(NBFN,VECTPI.PROG,1,PNM1.XMAT(1,IBFN),1) 744 CONTINUE 74 CONTINUE IF (IMPR.GT.3) THEN WRITE(IOIMP,*) $ 'Ordre de dérivation / coordonnée de réf. :' WRITE(IOIMP,4003) (ORDER1.LECT(JDIMQR),JDIMQR=1,NDIMQR) DO 76 IPGFAC=1,NPGFAC WRITE(IOIMP,*) 'Face n° ',IBELFV WRITE(IOIMP,*) 'Noeud de coordonnées :' WRITE(IOIMP,4004) (JXCOPG.WELCHE(1,1,1,JDIMQR,IPGFAC $ ,IBELFV),JDIMQR=1,NDIMQR) WRITE(IOIMP,*) 'DFNPG.WELCHE(nb.fns.forme) :' WRITE(IOIMP,4004) $ (DFNPG.WELCHE(1,IBFN,1,IDIMQR,IPGFAC,IBELFV), $ IBFN=1,NBFN) 76 CONTINUE ENDIF ENDDO 7 CONTINUE SEGDES DFNPG SEGSUP VECTPI SEGSUP ORDER1 SEGDES PNM1 SEGDES MYBPOL.LIPOLY(*) SEGDES MYBPOL SEGDES JXCOPG * * Normal termination * IRET=0 RETURN * * Format handling * 4003 FORMAT (2X,6(1X,I3)) 4004 FORMAT (2X,6(1X,1PE13.5)) * * Error handling * 9999 CONTINUE IRET=1 WRITE(IOIMP,*) 'An error was detected in subroutine nif' RETURN * * End of subroutine NIF * END