C EXTFAC    SOURCE    GOUNAND   06/08/04    21:15:36     5520           
      SUBROUTINE EXTFAC(CGEOM3,CSGEO3,MYQRFS,
     $     CGEOME,FACTIV,
     $     IMPR,IRET)
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
C***********************************************************************
C NOM         : EXTFAC
C DESCRIPTION :  On extrait de CGEOM3 les éléments qui ont au moins une
C                face appartenant à CSGEO3 et un objet MELEME détourné  
C                contenant les faces actives.
C
C
C
C LANGAGE     : ESOPE
C AUTEUR      : Stéphane GOUNAND (CEA/DEN/DM2S/SFME/LTMF)
C               mél : gounand@semt2.smts.cea.fr
C***********************************************************************
C APPELES          : 
C APPELES (E/S)    : 
C APPELES (BLAS)   :
C APPELES (CALCUL) :
C APPELE PAR       :
C***********************************************************************
C SYNTAXE GIBIANE    :
C ENTREES            :
C ENTREES/SORTIES    :
C SORTIES            :
C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
C***********************************************************************
C VERSION    : v1, 17/12/2002, version initiale
C HISTORIQUE : v1, 17/12/2002, 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 SMCOORD
-INC SMELEME
      POINTEUR CGEOM3.MELEME,SCGEO3.MELEME
      POINTEUR CSGEO3.MELEME,SCSGE3.MELEME
      POINTEUR CGEOME.MELEME,SCGEOM.MELEME
      POINTEUR FACVOL.MELEME,SFAVOL.MELEME
      INTEGER NBNN,NBELEM,NBSOUS,NBREF
* Segment à moi
      SEGMENT VOLTIV
      POINTEUR IVOLTI(NBSOUV).SVOLTI
      ENDSEGMENT
      SEGMENT SVOLTI
      LOGICAL LVOLTI(NBELEV)
      ENDSEGMENT
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
      INTEGER NBSOUV,NBSOFV,NBELEV
CBEGININCLUDE SMLLOGI
      SEGMENT MLLOGI
      LOGICAL LOGI(JG)
      ENDSEGMENT
CENDINCLUDE SMLLOGI
      POINTEUR KRSURF.MLLOGI
      INTEGER JG
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 MYQRFS.IQUAFS
      POINTEUR IQUVOL.IQUAF
      POINTEUR IQUFAC.IQUAF
*
      INTEGER IMPR,IRET
*
      INTEGER NBSOUF,NBELEF
      INTEGER IBSOUF,IBELEF,IBSOUV,IBELEV
      INTEGER        NBELFV,NBNNV,NBELVA
      INTEGER IBSOFV,IBELFV,IBNNV,IBELVA
      INTEGER NUCFAC,NGLFAC,NPLFAC,NPCFAC
      INTEGER ITYVOL,ITYFAC
      LOGICAL LFOUND


*     
* Executable statements
*
      IF (IMPR.GT.2) WRITE(IOIMP,*) 'Entrée dans extfac.eso' 
*
* On construit KRSURF : KRSURF(i) = VRAI si i est un numéro global
* du centre d'un élément de CSGEO3 (point face)
*
      JG=XCOOR(/1)/(IDIM+1)
      SEGINI,KRSURF
      SEGACT CSGEO3
      NBSOUF=CSGEO3.LISOUS(/1)
      DO IBSOUF=1,NBSOUF
         SCSGE3=CSGEO3.LISOUS(IBSOUF)
         SEGACT SCSGE3
         ITYFAC=SCSGE3.ITYPEL
         CALL FIQUAF(ITYFAC,MYQRFS,IQUFAC,IMPR,IRET)
         IF (IRET.NE.0) GOTO 9999
         SEGACT IQUFAC
         NUCFAC=IQUFAC.NUCENT
         SEGDES IQUFAC
         NBELEF=SCSGE3.NUM(/2)
         DO IBELEF=1,NBELEF
            NGLFAC=SCSGE3.NUM(NUCFAC,IBELEF)
            KRSURF.LOGI(NGLFAC)=.TRUE.
         ENDDO
         SEGDES SCSGE3
      ENDDO
      SEGDES CSGEO3
*      segprt,krsurf
*
* On parcourt l'objet maillage CGEOM3 en notant les éléments ayant
* au moins une face active LVOLTI(IBELEV)=.TRUE.
*
      SEGACT CGEOM3
      NBSOUV=CGEOM3.LISOUS(/1)
      SEGINI,VOLTIV
      DO IBSOUV=1,NBSOUV
         SCGEO3=CGEOM3.LISOUS(IBSOUV)
         SEGACT SCGEO3
         NBELEV=SCGEO3.NUM(/2)
         SEGINI,SVOLTI
         ITYVOL=SCGEO3.ITYPEL
         CALL FIQUAF(ITYVOL,MYQRFS,IQUVOL,IMPR,IRET)
         IF (IRET.NE.0) GOTO 9999
         SEGACT IQUVOL
         FACVOL=IQUVOL.LFACE
         SEGDES IQUVOL
         SEGACT FACVOL
         NBSOFV=FACVOL.LISOUS(/1)
         DO IBSOFV=1,NBSOFV
            SFAVOL=FACVOL.LISOUS(IBSOFV)
*            segprt,sfavol
            SEGACT SFAVOL
            ITYFAC=SFAVOL.ITYPEL
            CALL FIQUAF(ITYFAC,MYQRFS,IQUFAC,IMPR,IRET)
            IF (IRET.NE.0) GOTO 9999
            SEGACT IQUFAC
            NUCFAC=IQUFAC.NUCENT
            SEGDES IQUFAC
            NBELFV=SFAVOL.NUM(/2)
            DO IBELEV=1,NBELEV
               LFOUND=.FALSE.
               DO IBELFV=1,NBELFV
                  NPLFAC=SFAVOL.NUM(NUCFAC,IBELFV)
                  NPCFAC=SCGEO3.NUM(NPLFAC,IBELEV)
*                  Write(ioimp,*) 'nplfac=',nplfac,' npcfac=',npcfac
                  LFOUND=LFOUND.OR.KRSURF.LOGI(NPCFAC)
               ENDDO
               SVOLTI.LVOLTI(IBELEV)=LFOUND.OR.SVOLTI.LVOLTI(IBELEV)
            ENDDO
            SEGDES,SFAVOL
         ENDDO
         SEGDES,SVOLTI
*         SEGPRT,SVOLTI
         VOLTIV.IVOLTI(IBSOUV)=SVOLTI
         SEGDES FACVOL
         SEGDES SCGEO3
      ENDDO
      SEGDES VOLTIV
      SEGDES CGEOM3
*
* On construit l'objet maillage CGEOME contenant uniquement 
* les éléments ayant au moins une face active
*
      SEGACT CGEOM3
      NBSOUV=CGEOM3.LISOUS(/1)
      NBNN=0
      NBELEM=0
      NBSOUS=NBSOUV
      NBREF=0
      SEGINI CGEOME
      SEGACT VOLTIV
      IBSOV2=0
      DO IBSOUV=1,NBSOUV
         SCGEO3=CGEOM3.LISOUS(IBSOUV)
         SEGACT SCGEO3
         NBNNV=SCGEO3.NUM(/1)
         NBELEV=SCGEO3.NUM(/2)
         SVOLTI=VOLTIV.IVOLTI(IBSOUV)
         SEGACT SVOLTI
*   Trouver le nombre d'éléments actifs dans ce maillage élémentaire
         NBELVA=0
         DO IBELEV=1,NBELEV
            IF (SVOLTI.LVOLTI(IBELEV)) THEN
               NBELVA=NBELVA+1
            ENDIF
         ENDDO
         IF (NBELVA.GT.0) THEN
            NBNN=NBNNV
            NBELEM=NBELVA
            NBSOUS=0
            NBREF=0
            SEGINI,SCGEOM
            SCGEOM.ITYPEL=SCGEO3.ITYPEL
            IBELVA=0
            DO IBELEV=1,NBELEV
               IF (SVOLTI.LVOLTI(IBELEV)) THEN
                  IBELVA=IBELVA+1
                  DO IBNNV=1,NBNNV
                     SCGEOM.NUM(IBNNV,IBELVA)=SCGEO3.NUM(IBNNV,IBELEV)
                  ENDDO
               ENDIF
            ENDDO
            SEGDES,SCGEOM
            IBSOV2=IBSOV2+1
            CGEOME.LISOUS(IBSOV2)=SCGEOM
         ENDIF
*DEBUG         SEGPRT,SVOLTI
         SEGSUP SVOLTI
         SEGDES SCGEO3
      ENDDO
*DEBUG      SEGPRT,VOLTIV
      SEGSUP VOLTIV
      NBNN=0
      NBELEM=0
      NBSOUS=IBSOV2
      NBREF=0
      SEGADJ,CGEOME
      SEGDES CGEOME
      SEGDES CGEOM3
*DEBUG      CALL ECROBJ('MAILLAGE',CGEOME)
*DEBUG      CALL PRLIST
*DEBUG      CALL ECROBJ('MAILLAGE',CGEOM3)
*DEBUG      CALL PRLIST
*
* On parcourt l'objet maillage CGEOME en notant les faces actives des
* éléments LFACTI(IBFAVO,IBELEV)=.TRUE.
*
      SEGACT CGEOME
      NBSOUV=CGEOME.LISOUS(/1)
      SEGINI,FACTIV
      DO IBSOUV=1,NBSOUV
         SCGEOM=CGEOME.LISOUS(IBSOUV)
         SEGACT SCGEOM
         ITYVOL=SCGEOM.ITYPEL
         CALL FIQUAF(ITYVOL,MYQRFS,IQUVOL,IMPR,IRET)
         IF (IRET.NE.0) GOTO 9999
         SEGACT IQUVOL
         FACVOL=IQUVOL.LFACE
         SEGDES IQUVOL
         SEGACT FACVOL
         NBSOFV=FACVOL.LISOUS(/1)
         SEGINI,SFACTI
         DO IBSOFV=1,NBSOFV
            SFAVOL=FACVOL.LISOUS(IBSOFV)
            SEGACT SFAVOL
            ITYFAC=SFAVOL.ITYPEL
            CALL FIQUAF(ITYFAC,MYQRFS,IQUFAC,IMPR,IRET)
            IF (IRET.NE.0) GOTO 9999
            SEGACT IQUFAC
            NUCFAC=IQUFAC.NUCENT
            SEGDES IQUFAC
            NBELFV=SFAVOL.NUM(/2)
            NBELEV=SCGEOM.NUM(/2)
            SEGINI SSFACT
            DO IBELEV=1,NBELEV
               DO IBELFV=1,NBELFV
                  NPLFAC=SFAVOL.NUM(NUCFAC,IBELFV)
                  NPCFAC=SCGEOM.NUM(NPLFAC,IBELEV)
                  SSFACT.LFACTI(IBELFV,IBELEV)=KRSURF.LOGI(NPCFAC)
               ENDDO
            ENDDO
            SEGDES SSFACT
*            SEGPRT,SSFACT
            SFACTI.ISFACT(IBSOFV)=SSFACT
            SEGDES SFAVOL
         ENDDO
         SEGDES SFACTI
*         SEGPRT,SFACTI
         FACTIV.IFACTI(IBSOUV)=SFACTI
         SEGDES FACVOL
         SEGDES SCGEOM
      ENDDO
      SEGDES FACTIV
*      SEGPRT,FACTIV
      SEGDES CGEOME
      SEGSUP,KRSURF
*
* Normal termination
*
      IRET=0
      RETURN
*
* Format handling
*
*
* Error handling
*
 9999 CONTINUE
      IRET=1
      WRITE(IOIMP,*) 'An error was detected in subroutine extfac'
      RETURN
*
* End of subroutine EXTFAC
*
      END