C GEOLF2 SOURCE GOUNAND 06/08/04 21:15:55 5520 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 CCOPTIO -INC SMELEME POINTEUR SFAVOL.MELEME -INC SMLENTI POINTEUR KPQVOL.MLENTI * CBEGININCLUDE SFACTIV SEGMENT FACTIV POINTEUR IFACTI(NBSOUV).SFACTI ENDSEGMENT SEGMENT SFACTI POINTEUR ISFACT(NBSOFV).SSFACT ENDSEGMENT SEGMENT SSFACT LOGICAL LFACTI(NBELFV,NBELEV) ENDSEGMENT CENDINCLUDE SFACTIV 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 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 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 LRFVOL.ELREF POINTEUR LRFFAC.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 PGFAC.POGAU 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 CBEGININCLUDE SIQUAF SEGMENT IQUAF INTEGER NUMQUF REAL*8 XCONQR(NDIMQR,NBNOQR) INTEGER NUCENT POINTEUR LFACE.MELEME ENDSEGMENT SEGMENT IQUAFS POINTEUR LISQRF(NBQRF).IQUAF ENDSEGMENT CENDINCLUDE 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.VELCHE(1,IDDLFA,1,IDIMQR,1,IBELEF)= $ JCOOR.VELCHE(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