Télécharger rlenso.eso

Retour à la liste

rlenso
C RLENSO    SOURCE    OF166741  24/12/13    21:17:25     12097          
      SUBROUTINE RLENSO(MELFL,MELFP,MELSOM,MLEPOI)
C************************************************************************
C
C PROJET            :  CASTEM 2000
C
C NOM               :  RLENSO
C
C DESCRIPTION       :  Appelle par GRADI2
C
C LANGAGE           :  FORTRAN 77 + ESOPE 2000 (avec extensions CISI)
C
C AUTEUR            :  A. BECCANTINI
C
C************************************************************************
C
C
C     Inputs:
C     MELFL  : facel of domaine table
C     MELFP  : facep of domaine table
C     MELSOM : sommet of the domaine table
C
C     Outputs:
C     MLEPOI : list of integers.
C     MLEPOI.LECT(I) is the pointer of the list of integers
C     MLENTI which contains the neighbors of the i-th sommet
C     point.
C
      IMPLICIT INTEGER(I-N)
      INTEGER  NSOMM, NBSOUS, NBELEM, NBNO
     &       , IELEM, NGF, NGF1, INOEU, NGS1, NLS1, ISOUS
     &       , IELEMF, NGC1, NGC2, NELT, NELTT, I1
C
-INC SMELEME
      INTEGER JG
-INC SMLENTI
 
-INC PPARAM
-INC CCOPTIO
C
      POINTEUR MELSOM.MELEME, MELFL.MELEME, MELFP.MELEME, MELFP1.MELEME
     &        ,MLESOM.MLENTI, MLEFP.MLENTI, MTOUC.MLENTI, MTOUC2.MLENTI
     &        ,MLEPOI.MLENTI
C
C**** Le MELEME SOMMET
C
      CALL KRIPAD(MELSOM,MLESOM)
C
C     MLESOM: numerotation globale -> locale
C
C**** En KRIPAD
C     SEGACT MELSOM
C     SEGINI MLESOM
C
      NSOMM = MELSOM.NUM(/2)
      JG=NSOMM
      SEGINI MTOUC
      SEGINI MTOUC2
C     MTOUC.LECT(NLS1)  = estimation of the number of neighbors for NLS1
C     MTOUC2.LECT(NLS1) = how many times NLS1 is touched
C
      SEGACT MELFP
C
C**** En 2D MELFP est un maillage elementaire
C     En 3D pas à priori
C     -> MLEFP contains the list of LISOUS
C
      NBSOUS=MELFP.LISOUS(/1)
C     NBSOUS=0 fais un peux chier!
      JG=MAX(NBSOUS,1)
      SEGINI MLEFP
      IF(NBSOUS .EQ. 0)THEN
         MLEFP.LECT(1)=MELFP
      ELSE
         DO ISOUS=1,NBSOUS,1
            MLEFP.LECT(ISOUS)=MELFP.LISOUS(ISOUS)
         ENDDO
      ENDIF
      SEGDES MELFP
C
      SEGACT MELFL
      NBSOUS=MELFL.LISOUS(/1)
      IF(NBSOUS .NE. 0)THEN
         WRITE(IOIMP,*) 'FACEL = ???'
         WRITE(IOIMP,*) 'Subroutine rlenso.eso'
         CALL ERREUR(5)
         GOTO 9999
      ENDIF
C
      IELEMF=0
      NBSOUS=MLEFP.LECT(/1)
      DO ISOUS = 1, NBSOUS, 1
         MELFP1=MLEFP.LECT(ISOUS)
         SEGACT MELFP1
         NBELEM=MELFP1.NUM(/2)
         NBNO=MELFP1.NUM(/1) - 1
C
C        The first ISOUS of 'FACEP' has NBELEM elements which contain
C        NBNO sommets and one point face. Each time a 'sommet' point is
C        touched, there are at most two neighbors of him.
C
         DO IELEM = 1, NBELEM,1
            IELEMF=IELEMF+1
            NGF=MELFP1.NUM(NBNO+1,IELEM)
            NGF1=MELFL.NUM(2,IELEMF)
            IF(NGF .NE. NGF1)THEN
               WRITE(IOIMP,*) 'FACEL = ???'
               WRITE(IOIMP,*) 'Subroutine rlenso.eso'
               CALL ERREUR(5)
               GOTO 9999
            ENDIF
C
C           Loop involving the sommet noeuds of the element of
C           FACEP
C
            DO INOEU = 1, NBNO, 1
               NGS1 = MELFP1.NUM(INOEU,IELEM)
               NLS1 = MLESOM.LECT(NGS1)
               MTOUC2.LECT(NLS1)=MTOUC2.LECT(NLS1)+1
            ENDDO
         ENDDO
      ENDDO
C
C**** MTOUC2.LECT(NLS1) says us how many times NLS1 is touched
C     Apart from the first interface, normally each
C     interface adds just one new neighbor and not two.
C     I create NSOMM MLENTI which contain the list of neighbors.
C     MLEPOI contains the number of their pointers
C
      JG=NSOMM
      SEGINI MLEPOI
      DO INOEU=1,NSOMM,1
         JG=MTOUC2.LECT(INOEU)+1
         SEGINI MLENTI
C        MTOUC.LECT(INOEU) says how many places are in each MLENTI
         MTOUC.LECT(INOEU)=JG
         MLEPOI.LECT(INOEU)=MLENTI
         MTOUC2.LECT(INOEU)=0
      ENDDO
C
      IELEMF=0
      NBSOUS=MLEFP.LECT(/1)
      DO ISOUS = 1, NBSOUS, 1
         MELFP1=MLEFP.LECT(ISOUS)
         NBELEM=MELFP1.NUM(/2)
         NBNO=MELFP1.NUM(/1) - 1
C
C        The first ISOUS of 'FACEP' has NBELEM elements which contain
C        NBNO sommets and one point face. Each time a 'sommet' point is
C        touched, there are at most two neighbors of him. As already
C        mentioned, normally each interface adds just one new neighbor
C        and not two.
C
         DO IELEM = 1, NBELEM,1
            IELEMF=IELEMF+1
            NGF=MELFP1.NUM(NBNO+1,IELEM)
            NGF1=MELFL.NUM(2,IELEMF)
            NGC1=MELFL.NUM(1,IELEMF)
            NGC2=MELFL.NUM(3,IELEMF)
            IF(NGC1 .NE. NGC2)THEN
C
C************* Internal face
C
C             Loop involving the sommet noeuds of the element of
C             FACEP
C
               DO INOEU = 1, NBNO, 1
                  NGS1 = MELFP1.NUM(INOEU,IELEM)
                  NLS1 = MLESOM.LECT(NGS1)
C
C**************** POINT NGC1: does it already belong to the list?
C
C                 NELT says how many neighbors are already in
C                 MLEPOI.LECT(NLS1)
C                 NELTT is the dimension of MLEPOI.LECT(NLS1)
C
                  NELT=MTOUC2.LECT(NLS1)
                  NELTT=MTOUC.LECT(NLS1)
                  MLENTI = MLEPOI.LECT(NLS1)
                  DO I1 = 1, NELT, 1
                     IF(MLENTI.LECT(I1).EQ.NGC1) GOTO 1
                  ENDDO
C
C**************** It does not
C
                  IF(NELT .LT. NELTT)THEN
                     MTOUC2.LECT(NLS1)=NELT+1
                     MLENTI.LECT(NELT+1)=NGC1
                     NELT=NELT+1
                  ELSE
C******************* Dimension of MLENTI too little
                     NELT=NELT+1
                     NELTT= NELTT+1
                     JG=NELTT
                     SEGADJ MLENTI
                     MTOUC2.LECT(NLS1)=JG
                     MTOUC.LECT(NLS1)=JG
                     MLENTI.LECT(JG)=NGC1
                  ENDIF
C
C**************** It does not
C
 1                CONTINUE
C
C**************** The same for NGC2
C
                  DO I1 = 1, NELT, 1
                     IF(MLENTI.LECT(I1).EQ.NGC2) GOTO 2
                  ENDDO
C
C**************** The point does not already belong to this element
C
                  IF(NELT .LT. NELTT)THEN
                     MTOUC2.LECT(NLS1)=NELT+1
                     MLENTI.LECT(NELT+1)=NGC2
                  ELSE
C
C******************* Dimension of MLENTI too little
C
                     JG=NELTT+1
                     SEGADJ MLENTI
                     MTOUC2.LECT(NLS1)=JG
                     MTOUC.LECT(NLS1)=JG
                     MLENTI.LECT(JG)=NGC2
                  ENDIF
C
C**************** The point already belongs to this element
C                 Nothing to do
C
 2                CONTINUE
               ENDDO
            ELSE
C
C************* Boundary face
C
C             Loop involving the sommet noeuds of the element of
C             FACEP
C
               DO INOEU = 1, NBNO, 1
                  NGS1 = MELFP1.NUM(INOEU,IELEM)
                  NLS1 = MLESOM.LECT(NGS1)
                  NELT=MTOUC2.LECT(NLS1)
                  NELTT=MTOUC.LECT(NLS1)
                  MLENTI = MLEPOI.LECT(NLS1)
C
C**************** POINT NGF cannot belongs to the list
C
                  IF(NELT .LT. NELTT)THEN
                     MTOUC2.LECT(NLS1)=NELT+1
                     MLENTI.LECT(NELT+1)=NGF
                     NELT=NELT+1
                  ELSE
C******************* Dimension of MLENTI too little
                     NELT=NELT+1
                     NELTT= NELTT+1
                     JG=NELTT
                     SEGADJ MLENTI
                     MTOUC2.LECT(NLS1)=JG
                     MTOUC.LECT(NLS1)=JG
                     MLENTI.LECT(JG)=NGF
                  ENDIF
C
C**************** What about NGC1?
C
                  DO I1 = 1, NELT, 1
                     IF(MLENTI.LECT(I1).EQ.NGC1) GOTO 3
                  ENDDO
C
C**************** The point does not already belong to this element
C
                  IF(NELT .LT. NELTT)THEN
                     MTOUC2.LECT(NLS1)=NELT+1
                     MLENTI.LECT(NELT+1)=NGC1
                  ELSE
C
C******************* Dimension of MLENTI too little
C
                     JG=NELTT+1
                     SEGADJ MLENTI
                     MTOUC2.LECT(NLS1)=JG
                     MTOUC.LECT(NLS1)=JG
                     MLENTI.LECT(JG)=NGC1
                  ENDIF
C
C**************** The point already belongs to this element
C                 Nothing to do
C
 3                CONTINUE
               ENDDO
            ENDIF
         ENDDO
         SEGDES MELFP1
      ENDDO
C
C**** We eliminate the 0 into the MLENTI of
C     MLEPOI.LECT(NL sommet)
C
      DO INOEU=1,NSOMM,1
         MLENTI=MLEPOI.LECT(INOEU)
         NELT=MTOUC2.LECT(INOEU)
         NELTT=MTOUC.LECT(INOEU)
         DO I1=(NELT+1),NELTT,1
            IF(MLENTI.LECT(I1) .NE. 0)THEN
C
C************* There is an error somewhere
C
               WRITE(IOIMP,*) 'Subroutine rlenso.eso'
               CALL ERREUR(5)
               GOTO 9999
            ENDIF
         ENDDO
         JG=NELT
         SEGADJ MLENTI
         SEGDES MLENTI
      ENDDO
C
C**** Test
C
C      DO INOEU=1,NSOMM,1
C         MLENTI=MLEPOI.LECT(INOEU)
C         NELT=MLENTI.LECT(/1)
C         write (*,*) 'ngs =', MELSOM.NUM(1,INOEU)
C         write (*,*) (mlenti.lect(i2),i2=1,nelt)
C      ENDDO
C
      SEGSUP MTOUC
      SEGSUP MTOUC2
C
      SEGSUP MLESOM
      SEGDES MELSOM
C
      SEGSUP MLEFP
C
      SEGDES MELFL
      SEGDES MLEPOI
C
 9999 RETURN
      END
 
 
 
 
 
 

© Cast3M 2003 - Tous droits réservés.
Mentions légales