Sources Esope | Cast3M

isova1
C ISOVA1    SOURCE    CB215821  21/06/10    21:15:30     11029          
      SUBROUTINE ISOVA1(MCHELM,XISO,XTOL,IOPT,MELEME)
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
C***********************************************************************
C NOM         : ISOVA1
C DESCRIPTION : Construit le maillage d'une isovaleur d'un champ par
C               éléments
C
* IOPT=-1 EGIN
* IOPT=0  EGAL (par défaut)
* IOPT=1  EGSU
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 VERSION    : v1, 17/12/2008, version initiale
C HISTORIQUE : v1, 17/12/2008, création
C HISTORIQUE : 30/07/2014, sg: ajout des options EGIN EGSU
C               ne pas créer de noeuds et d'éléments en multiples
C               exemplaires.
C
C
C HISTORIQUE :
C***********************************************************************
 
-INC PPARAM
-INC CCOPTIO
-INC CCGEOME
-INC CCREEL
-INC SMCOORD
-INC SMELEME
-INC SMCHAML
-INC SMLENTI
*
* Segments ajustables 1D contenant les noeuds des éléments créés ainsi
* que leur couleur
* ELEM(1) contient des POI1
* ELEM(2) contient des SEG2
* ELEM(3) contient des TRI3
* ELEM(4) contient des TET4
* ELEM(5) contient des PYR5
* ELEM(6) contient des PRI6
* ELEM(7) contient des QUA4
*
      PARAMETER (NTYEL=7)
      SEGMENT ELEMS
      POINTEUR ELEM(NTYEL).MLENTI
      ENDSEGMENT
      SEGMENT MELEMS
      POINTEUR IPT(NTYEL).MELEME
      ENDSEGMENT
*
* Pile des nouveaux noeuds
      SEGMENT NEWNOD
      INTEGER NNOD
      INTEGER NOEINF(MAXNOD)
      INTEGER NOESUP(MAXNOD)
      REAL*8  COEINF(MAXNOD)
      ENDSEGMENT
*
      segment newnum(nnod)
*
      SEGMENT ICPR(nbpts)
      segment inode(ino)
      segment jelnum(imaxel,ino)
      segment kelnum(imaxel,ino)
      segment xelnum(imaxel,ino)
*
      CHARACTER*8 MCHA
      INTEGER IMPR,IRET
      LOGICAL LFOUND
*
      INTEGER ITYPL(NTYEL)
      DATA ITYPL/1,2,4,23,25,16,8/
*
* Executable statements
*
      IMPR=0
      IF (IMPR.GT.2) WRITE(IOIMP,*) 'Entrée dans isova1.eso'
*
* Initialisation des objets possiblement créés et de la pile
* des nouveaux noeuds
*
      SEGINI ELEMS
      DO ITYEL=1,NTYEL
         JG=0
         SEGINI MLENTI
         ELEM(ITYEL)=MLENTI
      ENDDO
      MAXNOD=0
      SEGINI NEWNOD
*
* Parcours du CHAMELEM
*
      SEGACT MCHELM
      N1=IMACHE(/1)
      DO I1=1,N1
         ITYCHA=INFCHE(I1,6)
         IF (ITYCHA.NE.1) THEN
            MOTERR(1:16)='NOEUDS         '
* 291 2
*Pas de MCHAML de type %m1:16 trouvé
            CALL ERREUR(291)
            RETURN
         ENDIF
         MELEME=IMACHE(I1)
         SEGACT MELEME
         MCHAML=ICHAML(I1)
         SEGACT MCHAML
         CALL ISOVA2(MELEME,MCHAML,XISO,XTOL,IOPT,NEWNOD,ELEMS,ITYPL)
         IF (IERR.NE.0) RETURN
      ENDDO
*
* La pile NEWNOD contient généralement des noeuds géométriquement
* confondus : on les élimine. Puis, on incrémente le segment MCOORD
* avec le nouveaux noeuds non géométriquement confondus
* et on met à jour les piles d'éléments.
*
      CALL ISOVA5(NEWNOD,ELEMS,ITYPL)
      IF (IERR.NE.0) RETURN
*
* Les piles d'éléments peuvent contenir des informations redondantes :
* - dans une pile d'éléments, plusieurs fois le même
* - dans la pile des POI1, des noeuds déjà présents dans les piles
*   de SEG2, TRI3, TET4, PYR5, PRI6, QUA4
* - dans la pile des SEG2, des segments déjà présents dans les piles
*   de TRI3, TET4, PYR5, PRI6, QUA4
* - dans la pile des TRI3, des faces dèjà présentes dans la pile des
*   TET4
* On réduit les piles de manière adéquate.
*
      CALL ISOVA6(ELEMS,ITYPL)
      IF (IERR.NE.0) RETURN
*
* Transformation des segments ajustables en MELEME
*
      SEGINI MELEMS
      NSOUT=0
      NBSOUS=0
      NBREF=0
      DO ITYEL=1,NTYEL
         MLENTI=ELEM(ITYEL)
         JG=LECT(/1)
         IF (JG.GT.0) THEN
            NSOUT=NSOUT+1
            ITYP=ITYPL(ITYEL)
            NBNN=NBNNE(ITYP)
            NBNN1=NBNN+1
            NBELEM=JG/NBNN1
            SEGINI MELEME
            ITYPEL=ITYP
            DO IELEM=1,NBELEM
               DO INN=1,NBNN
                  NUM(INN,IELEM)=LECT((IELEM-1)*NBNN1+INN)
               ENDDO
               ICOLOR(IELEM)=LECT(IELEM*NBNN1)
            ENDDO
            MELEMS.IPT(ITYEL)=MELEME
         ENDIF
         SEGSUP MLENTI
      ENDDO
      SEGSUP ELEMS
*
      IF (NSOUT.EQ.1) THEN
         DO ITYEL=1,NTYEL
            IPT1=IPT(ITYEL)
            IF (IPT1.NE.0) THEN
               MELEME=IPT1
            ENDIF
         ENDDO
      ELSE
* Traite aussi le cas maillage vide (NSOUT=0)
         NBNN=0
         NBELEM=0
         NBREF=0
         NBSOUS=NSOUT
         NBREF=0
         SEGINI MELEME
         ISOUS=0
         DO ITYEL=1,NTYEL
            IPT1=IPT(ITYEL)
            IF (IPT1.NE.0) THEN
               ISOUS=ISOUS+1
               LISOUS(ISOUS)=IPT1
            ENDIF
         ENDDO
      ENDIF
      SEGSUP MELEMS
      RETURN
*
* End of subroutine ISOVA1
*
      END