C GEOLF2 SOURCE GOUNAND 21/06/02 21:16:07 11022 SUBROUTINE GEOLF2(LRFVOL,IQUVOL,SFAVOL, $ MYDISC,METING,MYFALS,MYFPGS, $ JCOOR,SSFACT,NBELEF, $ JMAJA2,JMIJA2,JDTJA2,LERJ2, $ IMPR,IRET) IMPLICIT REAL*8 (A-H,O-Z) IMPLICIT INTEGER (I-N) C*********************************************************************** C NOM : GEOLF2 C PROJET : Noyau linéaire NLIN C DESCRIPTION : 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 : C APPELE PAR : C*********************************************************************** C ENTREES : C ENTREES/SORTIES : - C SORTIES : C CODE RETOUR (IRET) : = 0 si tout s'est bien passé C*********************************************************************** C VERSION : v1, 30/07/03, version initiale C HISTORIQUE : v1, 30/07/03, 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 PPARAM -INC CCOPTIO -INC SMELEME POINTEUR SFAVOL.MELEME -INC SMLENTI POINTEUR KPQVOL.MLENTI * -INC TNLIN *-INC SFACTIV *-INC SMCHAEL INTEGER NBLIG,NBCOL,N2LIG,N2COL,NBPOI,NBELM POINTEUR JCOOR.MCHEVA POINTEUR KCOOR.MCHEVA POINTEUR FFFAC.MCHEVA POINTEUR DFFFAC.MCHEVA POINTEUR JMAJA2.MCHEVA POINTEUR JMIJA2.MCHEVA POINTEUR JDTJA2.MCHEVA *-INC SELREF POINTEUR LRFVOL.ELREF POINTEUR LRFFAC.ELREF *-INC SFALRF POINTEUR MYFALS.FALRFS *-INC SPOGAU POINTEUR PGFAC.POGAU *-INC SFAPG POINTEUR MYFPGS.FAPGS *-INC SIQUAF POINTEUR IQUVOL.IQUAF * LOGICAL LERJ2 CHARACTER*4 MYDISC,METING INTEGER NBELEV,NBELEF,NBELFV INTEGER IMPR,IRET * * Executable statements * IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans geolf2' * * 1ere etape : on crée les ddl de la transfo geometrique * SEGACT IQUVOL NDIMQR=IQUVOL.XCONQR(/1) NBNOQR=IQUVOL.XCONQR(/2) SEGDES IQUVOL SEGACT LRFVOL NDDLVO=LRFVOL.NPQUAF(/1) JG=NBNOQR SEGINI KPQVOL DO IDDLVO=1,NDDLVO KPQVOL.LECT(LRFVOL.NPQUAF(IDDLVO))=IDDLVO ENDDO SEGDES LRFVOL SEGACT SFAVOL ITYFAC=SFAVOL.ITYPEL CALL KEEF(ITYFAC,MYDISC, $ MYFALS, $ LRFFAC, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 SEGACT LRFFAC NDDLFA=LRFFAC.NPQUAF(/1) SEGACT SSFACT NBELFV=SSFACT.LFACTI(/1) NBELEV=SSFACT.LFACTI(/2) NBLIG=1 NBCOL=NDDLFA N2LIG=1 N2COL=NDIMQR NBPOI=1 NBELM=NBELEF SEGINI KCOOR SEGACT JCOOR IBELEF=0 DO IBELEV=1,NBELEV DO IBELFV=1,NBELFV IF (SSFACT.LFACTI(IBELFV,IBELEV)) THEN IBELEF=IBELEF+1 DO IDDLFA=1,NDDLFA IBNOQR=SFAVOL.NUM(LRFFAC.NPQUAF(IDDLFA),IBELFV) IBNOVO=KPQVOL.LECT(IBNOQR) DO IDIMQR=1,NDIMQR KCOOR.WELCHE(1,IDDLFA,1,IDIMQR,1,IBELEF)= $ JCOOR.WELCHE(1,IBNOVO,1,IDIMQR,1,IBELEV) ENDDO ENDDO ENDIF ENDDO ENDDO SEGDES JCOOR SEGDES SSFACT SEGDES LRFFAC SEGDES SFAVOL SEGSUP KPQVOL * * 2ème étape : - on crée les fonctions de forme et leurs dérivées * pour la transformation géométrie face -> volume * - on récupère coordonnées et poids des points de * Gauss pour la méthode METING sur la face de * référence * - pour chaque face de l'élément de référence volumique * on construit les coordonnées des points de Gauss * attenant à l'aide de la transformation géométrique * CALL KEPG(ITYFAC,METING, $ MYFPGS, $ PGFAC, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 * * In KFNREF : SEGINI FFFAC * In KFNREF : SEGINI DFFFAC * CALL KFNREF(LRFFAC,PGFAC, $ FFFAC,DFFFAC, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 SEGSUP FFFAC * * 3ème étape : On crée le déterminant de la matrice jacobienne * aux points de Gauss et on multiplie * les poids des points de Gauss par ce déterminant * * In GEOLIN : SEGINI JMAJA2 * In GEOLIN : SEGINI JMIJA2 * In GEOLIN : SEGINI JDTJA2 * SEGPRT,DFFFAC * SEGPRT,KCOOR CALL GEOLIN(DFFFAC,KCOOR,NBELEF, $ JMAJA2,JMIJA2,JDTJA2,LERJ2, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 * SEGPRT,JDTJA2 * In GEOLIN : SEGDES JMAJA2 * In GEOLIN : SEGDES JMIJA2 * In GEOLIN : SEGDES JDTJA2 SEGSUP DFFFAC SEGSUP KCOOR * SEGPRT,IQUVOL * SEGPRT,SFAVOL * SEGPRT,LRFVOL * SEGPRT,LRFFAC * SEGPRT,SSFACT * SEGPRT, JCOOR * SEGPRT, KCOOR * SEGPRT,PGFAC * SEGPRT,DFFFAC * SEGPRT,JMAJA2 * SEGPRT,JDTJA2 * STOP 16 * * Normal termination * IRET=0 RETURN * * Format handling * * * Error handling * 9999 CONTINUE IRET=1 WRITE(IOIMP,*) 'An error was detected in subroutine geolf2' RETURN * * End of subroutine GEOLF2 * END