decoup.f

Go to the documentation of this file.

!                       *****************
                        SUBROUTINE decoup
!                       *****************
!
     &(isurc,x,y,ikle,ncolor,ifabor, nelem2,npoin2,color)
!
!***********************************************************************
! PROGICIEL: STBTEL V5.2        19/04/91  J-C GALLAND  (LNH)
!                               19/02/93  J-M JANIN    (LNH)
!***********************************************************************
!
! FONCTION : DECOUPAGE DES TRIANGLES SURCONTRAINTS :
!            ILS SONT COUPES EN TROIS PAR AJOUT D'UN POINT A
!            LEUR BARYCENTRE
!
!
!-----------------------------------------------------------------------
!                             ARGUMENTS
! .________________.____.______________________________________________.
! |      NOM       |MODE|                   ROLE                       |
! |________________|____|______________________________________________|
! |   ISURC        | -->| NUMERO DE L'ELEMENT SURCONTRAINT A TRAITER
! |   X,Y          |<-->| COORDONNEES DU MAILLAGE .
! |   IKLE         |<-->| LISTE DES POINTS DE CHAQUE ELEMENT
! |   NCOLOR       |<-->| TABLEAU DES COULEURS DES POINTS
! |   IFABOR       |<-->| TABLEAU DES VOISINS DES ELEMENTS
! |   NELEM2       |<-->| NOUVEAU NOMBRE D'ELEMENTS APRES DECOUP
! |   NPOIN2       |<-->| NOUVEAU NOMBRE DE POINTS APRES DECOUP
! |    COLOR       |<-->| STOCKAGE COULEURS DES NOEUDS SUR FICHIER GEO
! |________________|____|______________________________________________|
! MODE : -->(DONNEE NON MODIFIEE), <--(RESULTAT), <-->(DONNEE MODIFIEE)
!-----------------------------------------------------------------------
! APPELE PAR : SURCON
! APPEL DE : -
!***********************************************************************
!
      USE declarations_special
      USE declarations_stbtel, ONLY: nelmax
      IMPLICIT NONE
!
      DOUBLE PRECISION, INTENT(INOUT) :: X(*) , Y(*)
      INTEGER, INTENT(IN) :: ISURC
      INTEGER, INTENT(INOUT) :: NELEM2 , NPOIN2
      INTEGER, INTENT(INOUT) :: IKLE(nelmax,4) , NCOLOR(*)
      INTEGER, INTENT(INOUT) :: IFABOR(nelmax,*)
      LOGICAL, INTENT(INOUT) :: COLOR
!
      INTEGER KELEM
      INTEGER IFAC , ICOLOR , I , I1 , I2 , I3
!
!
!
!=======================================================================
! CALCUL DES COORDONNEES DU NOUVEAU NOEUD 4 (DE NUMERO NPOIN2)
!=======================================================================
!
      npoin2 = npoin2 + 1
      i1 = ikle(isurc,1)
      i2 = ikle(isurc,2)
      i3 = ikle(isurc,3)
!
      x(npoin2) = (x(i1) + x(i2) + x(i3))/3.d0
      y(npoin2) = (y(i1) + y(i2) + y(i3))/3.d0
!
!=======================================================================
! DEFINITION DE LA COULEUR DU NOEUD CREE (C'EST CELLE DU NOEUD NON POINT
! DE BORD DE L'ELEMENT VOISIN)
!=======================================================================
!
      IF (color) THEN
        DO ifac=1,3
          IF(ifabor(isurc,ifac).GT.0) icolor = ifabor(isurc,ifac)
        ENDDO
!
        DO i=1,3
          IF(ikle(icolor,i).NE.i1.AND.ikle(icolor,i).NE.i2.AND.
     &       ikle(icolor,i).NE.i3)
     &       ncolor(npoin2) = ncolor(ikle(icolor,i))
        ENDDO
      ENDIF
!
!=======================================================================
! CALCUL DES NOUVEAUX IKLE : L'ELEMENT (1,2,4) CONSERVE LE NUMERO ISURC
!                            L'ELEMENT (2,3,4) PREND LE NUMERO NELEM2+1
!                            L'ELEMENT (3,1,4) PREND LE NUMERO NELEM2+2
!=======================================================================
!
      ikle(isurc,3) = npoin2
!
      nelem2 = nelem2 + 1
      ikle(nelem2,1) = i2
      ikle(nelem2,2) = i3
      ikle(nelem2,3) = npoin2
!
      kelem = ifabor(isurc,2)
      ifabor(nelem2,1) = kelem
      ifabor(nelem2,2) = nelem2+1
      ifabor(nelem2,3) = isurc
      IF (kelem.GT.0) THEN
        IF (ifabor(kelem,1).EQ.isurc) ifabor(kelem,1) = nelem2
        IF (ifabor(kelem,2).EQ.isurc) ifabor(kelem,2) = nelem2
        IF (ifabor(kelem,3).EQ.isurc) ifabor(kelem,3) = nelem2
      ENDIF
      ifabor(isurc,2) = nelem2
!
      nelem2 = nelem2 + 1
      ikle(nelem2,1) = i3
      ikle(nelem2,2) = i1
      ikle(nelem2,3) = npoin2
!
      kelem = ifabor(isurc,3)
      ifabor(nelem2,1) = ifabor(isurc,3)
      ifabor(nelem2,2) = isurc
      ifabor(nelem2,3) = nelem2-1
      IF (kelem.GT.0) THEN
        IF (ifabor(kelem,1).EQ.isurc) ifabor(kelem,1) = nelem2
        IF (ifabor(kelem,2).EQ.isurc) ifabor(kelem,2) = nelem2
        IF (ifabor(kelem,3).EQ.isurc) ifabor(kelem,3) = nelem2
      ENDIF
      ifabor(isurc,3) = nelem2
!
!=======================================================================
!
      RETURN
      END