Sources Esope | Cast3M

rlexc1
C RLEXC1    SOURCE    OF166741  24/10/03    21:15:39     12022          
      SUBROUTINE RLEXC1(MLEPOI,MLECOE,MCHELM)
C************************************************************************
C
C PROJET            :  CASTEM 2000
C
C NOM               :  RLEXC1
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 Inputs:
C
C MLEPOI : pointers of list of points (FACE + neighbors)
C
C MLECOE : pointers of the list of coeff
C
C Output
C
C MCHELM : MCHAML which contains the coeff. to compute gradients
C
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
 
-INC PPARAM
-INC CCOPTIO
 
-INC SMCHAML
-INC SMLREEL
-INC SMLENTI
-INC SMELEME
      POINTEUR MLELAS.MLENTI, MLECON.MLENTI, MLEELT.MLENTI
     &     ,MLEPOI.MLENTI,MLECOE.MLENTI
 
      SEGMENT MATRIX
        REAL*8 MAT(N1,N2)
      ENDSEGMENT
 
      INTEGER N1,N2
      INTEGER N3,L1,N1PTEL,N1EL,N2PTEL,N2EL
      INTEGER NBNN,NBELEM,NBSOUS,NBREF
      INTEGER JG
C
      INTEGER NFAC,NMAX,IFAC, NTSOUS, I1, NBNN0, I3, I2, NG, ISOUS
C
      SEGACT MLEPOI
      SEGACT MLECOE
      NFAC=MLEPOI.LECT(/1)
C
C**** NMAX = maximum number of points in the element
C            'FACE'-neighbors
      NMAX=0
      DO IFAC = 1, NFAC, 1
         MLENTI=MLEPOI.LECT(IFAC)
         SEGACT MLENTI
         NBNN=MLENTI.LECT(/1)
         NMAX=MAX(NMAX,NBNN)
      ENDDO
C
C**** We create the following MLENTI
C
C     MLECON : dimension = NMAX
C              MLECON.LECT(I) = number of elements with I points
C
C     MLELAS : dimension = NMAX
 
C             MLELAS.LECT(I) = 0 -> there are no elements with I
C                                    points
C
C                               J -> the J-th element has I points
C
C
C     The other elements with I points are into the chaining list
C     MLEELT.
C
C     MLEELT : dimension = NFAC
C              MLEELT+MLELAS allows to rapidly recover the elements
C              with the same number of points
C              For example, the elements with I points are:
C              IELEM = MLELAS.LECT(I)
C              IELEM2 = MLEELT.LECT(IELEM)
C              ...
C              IELEM_K+1 = MLEELT.LECT(IELEM_K)
C              ...
C              until IELEM_K+1 = 0
C
      JG=NMAX
      SEGINI MLELAS
      SEGINI MLECON
      JG=NFAC
      SEGINI MLEELT
      DO IFAC = 1, NFAC, 1
         MLENTI=MLEPOI.LECT(IFAC)
         NBNN=MLENTI.LECT(/1)
         MLECON.LECT(NBNN)=MLECON.LECT(NBNN)+1
         MLEELT.LECT(IFAC)= MLELAS.LECT(NBNN)
         MLELAS.LECT(NBNN)=IFAC
      ENDDO
C
C**** Les supports
C
      NTSOUS=0
      DO ISOUS=1,NMAX,1
         IF(MLECON.LECT(ISOUS).NE.0) NTSOUS=NTSOUS+1
      ENDDO
C
C**** Initialisation du MCHELM
C
      N1=NTSOUS
      N2=IDIM
      N3=6
      L1=8
      SEGINI MCHELM
      MCHELM.TITCHE='Gradient'
      MCHELM.IFOCHE=IFOUR
C
      ISOUS=0
      NBSOUS=0
      NBREF=0
      DO I1 = 1, NMAX, 1
         NBELEM=MLECON.LECT(I1)
         IF(NBELEM .GT. 0)THEN
            ISOUS=ISOUS+1
            NBNN=I1
            SEGINI MELEME
C           ITYPEL=32 -> 'POLY'
            ITYPEL=32
            MCHELM.IMACHE(ISOUS)=MELEME
            MCHELM.CONCHE(ISOUS)='        '
            MCHELM.INFCHE(ISOUS,6)=1
            SEGINI MCHAML
            MCHELM.ICHAML(ISOUS)=MCHAML
            MCHAML.NOMCHE(1)='alphax'
            MCHAML.NOMCHE(2)='alphay'
            MCHAML.TYPCHE(1)='REAL*8          '
            MCHAML.TYPCHE(2)='REAL*8          '
            N1PTEL=NBNN
            N1EL=NBELEM
            N2PTEL=0
            N2EL=0
            SEGINI MELVA1
            SEGINI MELVA2
            MCHAML.IELVAL(1)=MELVA1
            MCHAML.IELVAL(2)=MELVA2
            IF(IDIM.EQ.3)THEN
               MCHAML.NOMCHE(3)='alphaz'
               MCHAML.TYPCHE(3)='REAL*8          '
               SEGINI MELVA3
               MCHAML.IELVAL(3)=MELVA3
            ENDIF
            IFAC=MLELAS.LECT(I1)
            MLENTI=MLEPOI.LECT(IFAC)
            MATRIX=MLECOE.LECT(IFAC)
            SEGACT MATRIX
            NBNN0=MLENTI.LECT(/1)
            IF(NBNN0.NE.NBNN)THEN
               WRITE(IOIMP,*) 'subroutine rlexc1.eso'
               CALL ERREUR(5)
               GOTO 9999
            ENDIF
C
C********** The first point of MLENTI is a FACE point
C           In the same way, MELEME.NUM(1,*) is the FACE point
C
C           N.B. the first element is stored into MLELAS
C                the others are stored into MLEELT
C
            DO I3=1,NBNN,1
               NG=MLENTI.LECT(I3)
               MELEME.NUM(I3,1)=NG
               MELVA1.VELCHE(I3,1)=MATRIX.MAT(2,I3)
               MELVA2.VELCHE(I3,1)=MATRIX.MAT(3,I3)
               IF(IDIM.EQ.3)  MELVA3.VELCHE(I3,1)=MATRIX.MAT(4,I3)
            ENDDO
            SEGSUP MLENTI
            SEGSUP MATRIX
C
            DO I2=2,NBELEM,1
               IFAC=MLEELT.LECT(IFAC)
               MLENTI=MLEPOI.LECT(IFAC)
               MATRIX=MLECOE.LECT(IFAC)
               SEGACT MATRIX
               NBNN0=MLENTI.LECT(/1)
               IF(NBNN0.NE.NBNN)THEN
                  WRITE(IOIMP,*) 'subroutine rlexc1.eso'
                  CALL ERREUR(5)
                  GOTO 9999
               ENDIF
C
               DO I3=1,NBNN,1
                  NG=MLENTI.LECT(I3)
                  MELEME.NUM(I3,I2)=NG
                  MELVA1.VELCHE(I3,I2)=MATRIX.MAT(2,I3)
                  MELVA2.VELCHE(I3,I2)=MATRIX.MAT(3,I3)
                  IF(IDIM.EQ.3) MELVA3.VELCHE(I3,I2)=MATRIX.MAT(4,I3)
               ENDDO
               SEGSUP MLENTI
               SEGSUP MATRIX
            ENDDO
C
            IFAC=MLEELT.LECT(IFAC)
            IF(IFAC.NE.0)THEN
               WRITE(IOIMP,*) 'subroutine rlexc1.eso'
               CALL ERREUR(5)
               GOTO 9999
            ENDIF
            SEGDES MCHAML
            SEGDES MELEME
            SEGDES MELVA1
            SEGDES MELVA2
            IF(IDIM.EQ.3) SEGDES MELVA3
         ENDIF
      ENDDO
C
      SEGDES MCHELM
C
      SEGSUP MLEPOI
      SEGSUP MLECOE
      SEGSUP MLEELT
      SEGSUP MLECON
      SEGSUP MLELAS
C
 9999 RETURN
      END
 
 
 
 
C