Sources Esope | Cast3M

rlexfi
C RLEXFI    SOURCE    PV        20/03/30    21:24:19     10567          
      SUBROUTINE RLEXFI(MLESCF,MATCOE,MLEFSC,MACOE1,MLEFC,MACOE2)
C************************************************************************
C
C PROJET            :  CASTEM 2000
C
C NOM               :  RLEXFI
C
C DESCRIPTION       :  Appelle par GRADIA
C
C LANGAGE           :  FORTRAN 77 + ESOPE 2000 (avec extensions CISI)
C
C AUTEUR            :  A. BECCANTINI
C
C************************************************************************
C
C Inputs:
C
C MLESCF : list of SOMMET points and their CENTRE neighbors
C
C MATCOE : coeff. for linear exact reconstruction of MLESCF
C
C MLEFSC : list of FACES points and their neighbors (CENTRE and SOMMET
C      points)
C
C MACOE1 : coeff. for linear exact reconstruction of MLEFSC
C
C Output
C
C MLEFC  :  list of FACES points and their neighbors (CENTRE points only)
C
C MACOE2 : coeff. for linear exact reconstruction of MLEFC
C
C
C**** Variables de COOPTIO
C
C      INTEGER IPLLB, IERPER, IERMAX, IERR, INTERR
C     &        ,IOTER,   IOLEC,  IOIMP,     IOCAR,  IOACQ
C     &        ,IOPER,   IOSGB,  IOGRA,     IOSAU,  IORES
C     &        ,IECHO,   IIMPI,  IOSPI
C     &        ,IDIM
CC     &        ,MCOORD
C     &        ,IFOMOD, NIFOUR, IFOUR, NSDPGE, IONIVE
C     &        ,NGMAXY, IZROSF, ISOTYP, IOSCR,LTEXLU
C     &        ,NORINC,NORVAL,NORIND,NORVAD
C     &        ,NUCROU, IPSAUV, IFICLE, IPREFI
C
      IMPLICIT INTEGER(I-N)
 
-INC PPARAM
-INC CCOPTIO
-INC SMCOORD
      INTEGER JG
-INC SMLENTI
      POINTEUR MLECEN.MLENTI, MLESOM.MLENTI, MCLEAR.MLENTI
-INC SMLREEL
      POINTEUR MLRCOE.MLREEL
C
      INTEGER NBL, NBTPOI
      SEGMENT MLELEM
      INTEGER INDEX(NBL+1)
      INTEGER LESPOI(NBTPOI)
      ENDSEGMENT
      POINTEUR MLESCF.MLELEM,MLEFSC.MLELEM, MLEFC.MLELEM
C
      INTEGER N1,N2
      SEGMENT MATRIX
      REAL*8 MAT(N1,N2)
      ENDSEGMENT
      POINTEUR MATCOE.MATRIX, MACOE1.MATRIX, MACOE2.MATRIX
C
      INTEGER NSOM, IPOS, IPOS1, NMAXVS, IELEM, NFAC, NGS, NMAXVF, I1
     &     , NGF, IPOSF, NVOIF, NCEN, NGP, NLS, IPOSP, IPOSP1
     &     , NVOI, I2 , IPOSV, NGC, NLC
      REAL*8 ERRO, VAL
C
C**** MLESCF = MLELEM sommet-centres voisins
C     NMAXVS = nombre max de voisins aux sommets
C
      SEGACT MLESCF
      NSOM=MLESCF.INDEX(/1)-1
      IPOS1=MLESCF.INDEX(1)
C
C**** N.B. Le sommet n'a pas  de voisins si il
C          appartient aux CL
C
      NMAXVS=1
      DO IELEM = 1, NSOM, 1
         IPOS=IPOS1
         IPOS1=MLESCF.INDEX(1+IELEM)
         NMAXVS=MAX(NMAXVS,(IPOS1-IPOS-1))
      ENDDO
C
C**** MLEFSC = MLELEM face (sommets-centres) voisins
C     NMAXVF = nombre max de voisins sommets aux faces
C              (N.B: dedans MLEFSC, un/deux points sont des points centres)
C
      SEGACT MLEFSC
      NFAC=MLEFSC.INDEX(/1)-1
      IPOS1=MLEFSC.INDEX(1)
      NMAXVF=0
      DO IELEM = 1, NSOM, 1
         IPOS=IPOS1
         IPOS1=MLEFSC.INDEX(1+IELEM)
         NMAXVF=MAX(NMAXVF,(IPOS1-IPOS-1))
      ENDDO
C
      NBL=NFAC
      NBTPOI=NFAC*(NMAXVS*NMAXVF)+NFAC
C
C**** NBTPOI iper sur-dimensionné
C
      SEGINI MLEFC
      N1=IDIM
      N2=NBTPOI
      SEGINI MACOE2
C
C
C**** MLECEN.MLENTI = position du centre NGC dedans un elt
C                     face -centres
C
C     MCLEAR = liste des points centres (pour nettoyer MLECEN)
C
C
C     MLESOM = position du sommet dedans MLESCF
C
      JG=nbpts
      SEGINI MLECEN
      SEGINI MLESOM
C
      DO IELEM=1,NSOM,1
         IPOS=MLESCF.INDEX(IELEM)
         NGS=MLESCF.LESPOI(IPOS)
         MLESOM.LECT(NGS)=IELEM
      ENDDO
C
      JG=NMAXVS*NMAXVF
      SEGINI MCLEAR
C
C**** On crée MLRCOE:
C
C     IPOS = MLESCF.INDEX(NLS)
C     IPOS1 = MLESCF.INDEX(NLS+1)
C     NGS =   MLESCF.LESPOI(IPOS)
C
C
C**** N.B. If MATCOE is expressed in the absolute frame
C
C     VAL_NGS = \sum_{J=IPOS+1,IPOS1-1) (MATCOE.MAT(1,J)  +
C               MATCOE.MAT(2,J) * X_NGS + MATCOE.MAT(3,J) * YNGS)
C               * VAL_J
C
C     MLRCOE.PROG(J) = (MATCOE.MAT(1,J)  +
C               MATCOE.MAT(2,J) * X_NGS + MATCOE.MAT(3,J) * YNGS)
C
C     If MATCOE is expressed in the relative frame
C
C     MLRCOE.PROG(J) = MATCOE.MAT(1,J)
C
      SEGACT MATCOE
      N2=MATCOE.MAT(/2)
      NBTPOI=MLESCF.LESPOI(/1)
      IF(N2 .NE. NBTPOI)THEN
         WRITE(IOIMP,*) 'Subroutine rlexfi.eso'
         CALL ERREUR(5)
         GOTO 9999
      ENDIF
C
      JG=N2
      SEGINI MLRCOE
      IPOS1=MLESCF.INDEX(1)
      DO IELEM=1,NSOM,1
         IPOS=IPOS1
         IPOS1=MLESCF.INDEX(1+IELEM)
         NGS=MLESCF.LESPOI(IPOS)
         MLRCOE.PROG(IPOS)=MATCOE.MAT(1,IPOS)
C
C******* N.B. IPOS+1 peut etre plus grand que IPOS1-1
C             En ce cas, pas de boucle
C
         DO I1 = (IPOS+1),(IPOS1-1),1
            MLRCOE.PROG(I1)=MATCOE.MAT(1,I1)
         ENDDO
      ENDDO
C
C**** On detrui MATCOE
C     On rempli MACOE2.MAT
C               MLEFC.MELEME : face - (voisins de type centre
C                                        + sommets appartenant
C                                          aux c.l.)
C
      SEGSUP MATCOE
      SEGACT MACOE1
C
      IPOS1=MLEFSC.INDEX(1)
      IPOSF=1
      MLEFC.INDEX(1)=IPOSF
      DO IELEM=1,NFAC,1
         IPOS=IPOS1
         IPOS1=MLEFSC.INDEX(1+IELEM)
         NGF=MLEFSC.LESPOI(IPOS)
         IPOSF=MLEFC.INDEX(IELEM)
         MLEFC.LESPOI(IPOSF)=NGF
C
C******* NGF a de voisins en MLEFSC.MLELEM:
C        a) de type centre (un ou deux)
C        b) de type sommet
C
         NVOIF=0
         NCEN=0
C
C******* NVOIF = nombre de voisins de NGF dedans
C                MLEFC.MLELEM
C        NCEN  = nombre de voisins de type CENTRE de NGF dedans
C                MLEFC.MLELEM
C
C
C******* Boucle sur le voisins de NGF en MLEFSC.MLELEM
C
         DO I1=(IPOS+1),(IPOS1-1),1
            NGP=MLEFSC.LESPOI(I1)
            NLS=MLESOM.LECT(NGP)
C
C********** Deux possibilité:
C           NLS > 0  -> NGP est un point sommet
C                       Dans ce cas NLS=position de NGP
C                       dedans MLESCF.MLELEM
C           NLS = 0  -> NGP est un point centre
C
            IF(NLS.GT.0)THEN
               IPOSP=MLESCF.INDEX(NLS)
               IPOSP1=MLESCF.INDEX(NLS+1)
               NVOI=IPOSP1-IPOSP-1
               IF(NVOI.EQ.0)THEN
C
C**************** Le point sommet NGP n'a pas de voisins
C                 Donc il appartient aux c.l.
C
C                 Sa position dedans MLEFSC est I1
C                 Sa position dedans MLESCF est IPOSP
C
                  ERRO=ABS(MLRCOE.PROG(IPOSP) - 1.0D0)
                  IF(ERRO .GT. 1.0D-6)THEN
                     WRITE(IOIMP,*) 'Subroutine rlexfi.eso'
                     CALL ERREUR(5)
                     GOTO 9999
                  ENDIF
                  NVOIF=NVOIF+1
                  IPOSV=IPOSF+NVOIF
                  MLEFC.LESPOI(IPOSV)=NGP
                  MACOE2.MAT(1,IPOSV)=MACOE1.MAT(2,I1)
                  MACOE2.MAT(2,IPOSV)=MACOE1.MAT(3,I1)
                  IF(IDIM.EQ.3)  MACOE2.MAT(3,IPOSV)=
     &                 MACOE1.MAT(4,I1)
               ELSEIF(NVOI.GT.0)THEN
C
C**************** Boucle sur les voisins du point sommet NGP
C                 dedans MLESCF.MLELEM
C
                  DO I2 = (IPOSP+1),(IPOSP1-1),1
                     VAL=MLRCOE.PROG(I2)
                     NGC=MLESCF.LESPOI(I2)
                     NLC=MLECEN.LECT(NGC)
C
C******************* NLC = position de NGC dans la structure
C                          NGF - se voisins en MLEFC.MLELEM
C
                     IF(NLC .EQ. 0)THEN
C
C********************** Nouveau voisin centre
C
                        NVOIF=NVOIF+1
                        NCEN=NCEN+1
                        MCLEAR.LECT(NCEN)=NGC
                        MLECEN.LECT(NGC)=NVOIF
                        IPOSV=IPOSF+NVOIF
                        MLEFC.LESPOI(IPOSV)=NGC
                     ELSE
                        IPOSV=IPOSF+NLC
                     ENDIF
C
C******************* I1 est la position du point sommet NGP dedans
C                    MLEFSC.MLELEM, i.e.
C                    MLEFSC.LESPOI(I1)=NGP
C
                     MACOE2.MAT(1,IPOSV)=MACOE2.MAT(1,IPOSV)+
     &                    (MACOE1.MAT(2,I1)*VAL)
                     MACOE2.MAT(2,IPOSV)=MACOE2.MAT(2,IPOSV)+
     &                    (MACOE1.MAT(3,I1)*VAL)
                     IF(IDIM.EQ.3)  MACOE2.MAT(3,IPOSV)=
     &                    MACOE2.MAT(3,IPOSV)+
     &                    (MACOE1.MAT(4,I1)*VAL)
                  ENDDO
               ELSEIF(NVOI.LT.0)THEN
                  WRITE(IOIMP,*) 'Subroutine rlexfi.eso'
                  CALL ERREUR(5)
                  GOTO 9999
               ENDIF
C
            ELSEIF(NLS.EQ.0)THEN
C
C************* NGP est un point centre
C              I1 = position de NGP dedans MLEFSC
C              i.e. MLEFSC.LESPOI(I1)=NGP
C
               NLC=MLECEN.LECT(NGP)
               IF(NLC .EQ. 0)THEN
C
C******************* Nouveau point centre
C
                  NVOIF=NVOIF+1
                  NCEN=NCEN+1
                  MCLEAR.LECT(NCEN)=NGP
                  MLECEN.LECT(NGP)=NVOIF
                  IPOSV=IPOSF+NVOIF
                  MLEFC.LESPOI(IPOSV)=NGP
               ELSE
                  IPOSV=IPOSF+NLC
               ENDIF
               MACOE2.MAT(1,IPOSV)=MACOE2.MAT(1,IPOSV)+
     &              MACOE1.MAT(2,I1)
               MACOE2.MAT(2,IPOSV)=MACOE2.MAT(2,IPOSV)+
     &              MACOE1.MAT(3,I1)
               IF(IDIM.EQ.3)  MACOE2.MAT(3,IPOSV)=
     &              MACOE2.MAT(3,IPOSV)+
     &              MACOE1.MAT(4,I1)
            ELSEIF(NLS.LT.0)THEN
               WRITE(IOIMP,*) 'Subroutine rlexfi.eso'
               CALL ERREUR(5)
               GOTO 9999
            ENDIF
C
C******* Fin boucle sur le voisins de NGF en MLEFSC.MLELEM
C
         ENDDO
C
         MLEFC.INDEX(IELEM+1)=IPOSF+NVOIF+1
C
C******* Nettoyage de MCLEAR et MLECEN
C
         DO I1 = 1, NCEN , 1
            NGC=MCLEAR.LECT(I1)
            MLECEN.LECT(NGC)=0
            MCLEAR.LECT(I1)=0
         ENDDO
C
      ENDDO
      NBTPOI=MLEFC.INDEX(NFAC+1)-1
      N2 = NBTPOI
C
      SEGADJ MLEFC
      SEGADJ MACOE2
      SEGDES MLEFC
      SEGDES MACOE2
C
C**** On detrui tous les objet qui ne servent plus
C
      SEGSUP MLEFSC
      SEGSUP MLESCF
      SEGSUP MATCOE
      SEGSUP MLRCOE
      SEGSUP MLESOM
      SEGSUP MLECEN
      SEGSUP MCLEAR
C
 9999 RETURN
      END