Sources Esope | Cast3M

rlenct
C RLENCT    SOURCE    OF166741  24/12/13    21:17:24     12097          
      SUBROUTINE RLENCT(MELFL,MELSOM,MLEPOI,MLECOE,MLEPOF,MLECOF)
C************************************************************************
C
C PROJET            :  CASTEM 2000
C
C NOM               :  RLENCT
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     This subroutine computes the coefficients to compute the gradient
C     at intefaces with respect to the values on its neighbors.
C     The neighbors are 'CENTRE' points or 'boundary condition' points.
C
C**** Inputs:
C
C     MELFL  = 'FACEL' meleme
C
C     MELSOM = 'SOMMET' meleme
C
C     MLEPOI = list of integers.
C              MLEPOI.LECT(i) points to the list neighbors of
C              MELSOM.NUM(1,I). Neighbors are 'CENTRE' points or
C              'boundary condition' points
C     MLECOE =  list of integers.
C               MLECOE.LECT(i) points to the list of real of coeffients
C               to compute the vertex values
C
C     MLEPOF = list of integers.
C              MLEPOI.LECT(i) points to the list neighbors of
C              MELFL.NUM(2,i). Neighbors are 'CENTRE' points or
C              'SOMMET' points.
C     MLECOF =  list of integers.
C               MLECOE.LECT(i) points to the matrix of coeffients to
C               compute the gradient with respect the neighbors value
C
C**** Output:
C
C     MLEPOF = list of integers.
C              MLEPOI.LECT(i) points to the list neighbors of
C              MELFL.NUM(2,i). Neighbors are 'CENTRE' points or
C              'boundary condition' points. The first one is the
C              'FACE' point itself.
C     MLECOE =  list of integers.
C               MLECOE.LECT(i) points to the matrix of coeffients to
C               compute the gradient
C
      IMPLICIT INTEGER(I-N)
 
-INC PPARAM
-INC CCOPTIO
-INC SMCOORD
-INC SMLENTI
-INC SMLREEL
-INC SMELEME
C
      INTEGER NTP, NFAC, IFAC, NVOIF, IVOIF, NGV, NLS, NLV
     &     ,NVOIS,IVOIS,NGVS, LAST, LAST0, NSOMM, IPOS
     &     ,I1,ICELL,NGF
      REAL*8 CELL
      INTEGER JG
      INTEGER N1,N2
      SEGMENT MATRIX
      REAL*8 MAT(N1,N2)
      ENDSEGMENT
      POINTEUR MELSOM.MELEME, MLEPOI.MLENTI,MLECOE.MLENTI, MELFL.MELEME
     &     ,MLEPOF.MLENTI,MLECOF.MLENTI
     &     ,MATCOE.MATRIX,MATCO1.MATRIX,MLRCOE.MLREEL,MLREST.MLENTI
     &     ,MLESOM.MLENTI,MLPOSI.MLENTI
C
C
      SEGACT MELFL
C
      NTP=nbpts
C
C**** Chaining list
C     LAST
C     MLREST(NTP)
C
      JG=NTP
      SEGINI MLREST
      LAST=-1
C
C**** Position of a point in the list of neighbors
C     MLREST is used to clean it at the end
C
      JG=NTP
      SEGINI MLPOSI
C
C**** We create the MLENTI for the sommets
C
      CALL KRIPAD(MELSOM,MLESOM)
      IF(IERR .NE. 0)GOTO 9999
C     En KRIPAD
C     SEGACT MELSOM
C     SEGINI MLESOM
C
      SEGACT MLEPOF*MOD
      NFAC=MLEPOF.LECT(/1)
      SEGACT MLECOF*MOD
C
      SEGACT MLEPOI
      SEGACT MLECOE
C
      NSOMM=MLEPOI.LECT(/1)
      DO I1=1,NSOMM,1
         MLENTI=MLEPOI.LECT(I1)
         SEGACT MLENTI
         MLREEL=MLECOE.LECT(I1)
         SEGACT MLREEL
      ENDDO
C
      DO IFAC=1,NFAC,1
         NGF=MELFL.NUM(2,IFAC)
         MLENT1=MLEPOF.LECT(IFAC)
         SEGACT MLENT1
         NVOIF=MLENT1.LECT(/1)
C
C******* We fill MLREST, MLPOSI
C
         LAST=-1
         IPOS=1
         MLREST.LECT(NGF)=LAST
         LAST=NGF
         DO IVOIF=1,NVOIF,1
            NGV=MLENT1.LECT(IVOIF)
C
C********** First of all, we have to check if this is a
C           'SOMMET' point. In that case we have to replace
C           it by its neighbors.
C
            NLS=MLESOM.LECT(NGV)
C
            IF(NLS .GT. 0)THEN
C             'SOMMET'
               MLENT2=MLEPOI.LECT(NLS)
               NVOIS=MLENT2.LECT(/1)
               DO IVOIS=1,NVOIS,1
                  NGVS=MLENT2.LECT(IVOIS)
                  NLV=MLREST.LECT(NGVS)
                  IF(NLV .EQ. 0)THEN
C
C**************** New point
C
                     IPOS=IPOS+1
                     MLREST.LECT(NGVS)=LAST
                     LAST=NGVS
                  ENDIF
               ENDDO
            ELSE
C             'CENTRE'
               NLV=MLREST.LECT(NGV)
               IF(NLV .EQ. 0)THEN
C
C************* New point
C
                  IPOS=IPOS+1
                  MLREST.LECT(NGV)=LAST
                  LAST=NGV
               ENDIF
            ENDIF
         ENDDO
C
C********** We create the new list of neighbors
C
         JG=IPOS
         SEGINI MLENTI
         MLEPOF.LECT(IFAC)=MLENTI
         LAST0=LAST
         DO IVOIF=1,IPOS,1
            I1=(IPOS-IVOIF)+1
            MLENTI.LECT(I1)=LAST
            MLPOSI.LECT(LAST)=I1
            LAST=MLREST.LECT(LAST)
         ENDDO
         IF(LAST .NE. -1)THEN
            WRITE(IOIMP,*) 'subroutine rlenct.eso'
            CALL ERREUR(5)
         ENDIF
         LAST=LAST0
C
C******* Summarizing
C
C        MLENTI: list of the new 'FACE' neighbors
C        MLENT1: list of the old 'FACE' neighbors
C        MLENT2: is free. It has been used and it will be used
C                for the 'SOMMET' neighbors.
C        MLPOSI: position of the new neighbors into MLENTI
C        MLREST + LAST : chaining list, used to clean MLPOSI
C
C******* Let us call
C        MATCOE: matrix of the 'FACE' coeff (IDIM+1,*)
C        MATCO1: matrix of the old 'FACE' coeff. (IDIM+1,*)
C        MLRCOE: list of the 'SOMMET coeff
C
C
         MATCO1=MLECOF.LECT(IFAC)
         SEGACT MATCO1
         N1=IDIM+1
         N2=MLENTI.LECT(/1)
         SEGINI MATCOE
         MLECOF.LECT(IFAC)=MATCOE
C
C******* Loop on the old 'FACE' neighbors
C
         NVOIF=MLENT1.LECT(/1)
         DO IVOIF=1,NVOIF,1
            NGV=MLENT1.LECT(IVOIF)
            NLS=MLESOM.LECT(NGV)
C
            IF(NLS .GT. 0)THEN
C             'SOMMET'
               MLENT2=MLEPOI.LECT(NLS)
               MLRCOE=MLECOE.LECT(NLS)
               NVOIS=MLENT2.LECT(/1)
               DO IVOIS=1,NVOIS,1
                  NGVS=MLENT2.LECT(IVOIS)
                  IPOS=MLPOSI.LECT(NGVS)
                  IF(IPOS .EQ. 0)THEN
                     WRITE(IOIMP,*) 'subroutine rlenct.eso'
                     CALL ERREUR(5)
                  ENDIF
                  DO I1=1,IDIM+1,1
                     MATCOE.MAT(I1,IPOS)=MATCOE.MAT(I1,IPOS)+
     &                    (MATCO1.MAT(I1,IVOIF)*MLRCOE.PROG(IVOIS))
                  ENDDO
               ENDDO
            ELSE
C             'CENTRE'
               IPOS=MLPOSI.LECT(NGV)
               DO I1=1,IDIM+1,1
                  MATCOE.MAT(I1,IPOS)=MATCOE.MAT(I1,IPOS)+
     &                 MATCO1.MAT(I1,IVOIF)
               ENDDO
            ENDIF
         ENDDO
C
CC
CC******* Test
CC
C         ipos=mlenti.lect(/1)
C         write(*,*) 'ngf=',melfl.num(2,ifac)
C         write(*,*) 'ntvois=',ipos
C         write(*,*) 'nvois=',(mlenti.lect(ivoif),ivoif=1,ipos,1)
C         write(*,*) 'Position=',
C     &        (mlposi.lect(mlenti.lect(ivoif)),ivoif=1,ipos,1)
C         write(*,*) 'coeff(1) =',(matcoe.mat(1,ivoif),ivoif=1,ipos,1)
C         write(*,*) 'coeff(2) =',(matcoe.mat(2,ivoif),ivoif=1,ipos,1)
C         write(*,*) 'coeff(3) =',(matcoe.mat(3,ivoif),ivoif=1,ipos,1)
C         if(idim.eq.3) write(*,*) 'coeff(4)=',
C     &        (matcoe.mat(4,ivoif),ivoif=1,ipos,1)
C         cell=0.0D0
C         do ivoif=1,ipos,1
C            cell=cell+matcoe.mat(1,ivoif)
C         enddo
C         write(*,*) 'sum=',cell
C         if(abs(cell-1.0d0) .gt. 1.0d-10)then
CC           It must be true if I just consider Dirichlet B.C.
C            call erreur(5)
C            goto 9999
C         endif
C
C******* We clean MLPOSI and MLREST
C
         NVOIS=MLENTI.LECT(/1)
         DO IVOIF=1,NVOIS,1
            MLPOSI.LECT(LAST)=0
            ICELL=LAST
            LAST=MLREST.LECT(ICELL)
            MLREST.LECT(ICELL)=0
         ENDDO
         IF(LAST .NE. -1)THEN
            WRITE(IOIMP,*) 'subroutine rlenct.eso'
            CALL ERREUR(5)
         ENDIF
C
         SEGSUP MATCO1
         SEGSUP MLENT1
         SEGDES MATCOE
         SEGDES MLENTI
C
      ENDDO
CC
CC******* Test
CC
C      do ifac=1,nfac,1
C         mlenti=mlepof.lect(ifac)
C         matcoe=mlecof.lect(ifac)
C         segact mlenti
C         segact matcoe
C         ipos=mlenti.lect(/1)
C         write(*,*) 'ngf=',melfl.num(2,ifac)
C         write(*,*) 'ntvois=',ipos
C         write(*,*) 'nvois=',(mlenti.lect(ivoif),ivoif=1,ipos,1)
C         write(*,*) 'coeff(1) =',(matcoe.mat(1,ivoif),ivoif=1,ipos,1)
C         write(*,*) 'coeff(2) =',(matcoe.mat(2,ivoif),ivoif=1,ipos,1)
C         write(*,*) 'coeff(3) =',(matcoe.mat(3,ivoif),ivoif=1,ipos,1)
C         if(idim.eq.3) write(*,*) 'coeff(4)=',
C     &        (matcoe.mat(4,ivoif),ivoif=1,ipos,1)
C         cell=0.0D0
C         do ivoif=1,ipos,1
C            cell=cell+matcoe.mat(1,ivoif)
C         enddo
C         write(*,*) 'sum=',cell
C         if(abs(cell-1.0d0) .gt. 1.0d-10)then
CC           It must be true if I just consider Dirichlet B.C.
C            call erreur(5)
C            goto 9999
C         endif
C         segdes mlenti
C         segdes matcoe
C      enddo
C
      SEGDES MELFL
C
      SEGSUP MLREST
      SEGSUP MLPOSI
C
      SEGDES MELSOM
      SEGSUP MLESOM
C
      SEGDES MLEPOF
      SEGDES MLECOF
C
      NSOMM=MLEPOI.LECT(/1)
      DO I1=1,NSOMM,1
         MLENTI=MLEPOI.LECT(I1)
         SEGSUP MLENTI
         MLREEL=MLECOE.LECT(I1)
         SEGSUP MLREEL
      ENDDO
      SEGSUP MLEPOI
      SEGSUP MLECOE
C
 9999 CONTINUE
      RETURN
      END