Sources Esope | Cast3M

geolf2
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