decoup.f

Go to the documentation of this file.
00001 C:\opentelemac\v7p0\sources\stbtel\decoup.f
00002 !
00024                         SUBROUTINE DECOUP
00025 !                       *****************
00026 !
00027      &(ISURC,X,Y,IKLE,NCOLOR,IFABOR, NELEM2,NPOIN2,COLOR)
00028 !
00029 !***********************************************************************
00030 ! PROGICIEL: STBTEL V5.2        19/04/91  J-C GALLAND  (LNH)
00031 !                               19/02/93  J-M JANIN    (LNH)
00032 !***********************************************************************
00033 !
00034 ! FONCTION : DECOUPAGE DES TRIANGLES SURCONTRAINTS :
00035 !            ILS SONT COUPES EN TROIS PAR AJOUT D'UN POINT A
00036 !            LEUR BARYCENTRE
00037 !
00038 !
00039 !-----------------------------------------------------------------------
00040 !                             ARGUMENTS
00041 ! .________________.____.______________________________________________.
00042 ! |      NOM       |MODE|                   ROLE                       |
00043 ! |________________|____|______________________________________________|
00044 ! |   ISURC        | -->| NUMERO DE L'ELEMENT SURCONTRAINT A TRAITER
00045 ! |   X,Y          |<-->| COORDONNEES DU MAILLAGE .
00046 ! |   IKLE         |<-->| LISTE DES POINTS DE CHAQUE ELEMENT
00047 ! |   NCOLOR       |<-->| TABLEAU DES COULEURS DES POINTS
00048 ! |   IFABOR       | -->| TABLEAU DES VOISINS DES ELEMENTS
00049 ! |   NELEM2       |<-->| NOUVEAU NOMBRE D'ELEMENTS APRES DECOUP
00050 ! |   NPOIN2       |<-->| NOUVEAU NOMBRE DE POINTS APRES DECOUP
00051 ! |    COLOR       |<-->| STOCKAGE COULEURS DES NOEUDS SUR FICHIER GEO
00052 ! |________________|____|______________________________________________
00053 ! | COMMON:        |    |
00054 ! |  GEO:          |    |
00055 ! |    MESH        | -->| TYPE DES ELEMENTS DU MAILLAGE
00056 ! |    NDP         | -->| NOMBRE DE NOEUDS PAR ELEMENTS
00057 ! |    NPOIN       | -->| NOMBRE TOTAL DE NOEUDS DU MAILLAGE
00058 ! |    NELEM       | -->| NOMBRE TOTAL D'ELEMENTS DU MAILLAGE
00059 ! |    NPMAX       | -->| DIMENSION EFFECTIVE DES TABLEAUX X ET Y
00060 ! |                |    | (NPMAX = NPOIN + 0.1*NELEM)
00061 ! |    NELMAX      | -->| DIMENSION EFFECTIVE DES TABLEAUX CONCERNANT
00062 ! |                |    | LES ELEMENTS (NELMAX = NELEM + 0.2*NELEM)
00063 ! |                |    |
00064 ! |________________|____|______________________________________________|
00065 ! MODE : -->(DONNEE NON MODIFIEE), <--(RESULTAT), <-->(DONNEE MODIFIEE)
00066 !-----------------------------------------------------------------------
00067 ! APPELE PAR : SURCON
00068 ! APPEL DE : -
00069 !***********************************************************************
00070 !
00071       IMPLICIT NONE
00072       INTEGER LNG,LU
00073       COMMON/INFO/LNG,LU
00074 !
00075       DOUBLE PRECISION X(*) , Y(*)
00076 !
00077       INTEGER NELEM , NELEM2 , MESH , NDP , NPOIN , NPOIN2 , NPMAX
00078       INTEGER NELMAX , KELEM
00079       INTEGER ISURC , IFAC , ICOLOR , I , I1 , I2 , I3
00080       INTEGER IKLE(NELMAX,4) , NCOLOR(*)
00081       INTEGER IFABOR(NELMAX,*)
00082 !
00083       LOGICAL COLOR
00084 !
00085       COMMON/GEO/ MESH , NDP , NPOIN , NELEM , NPMAX , NELMAX
00086 !
00087 !=======================================================================
00088 ! CALCUL DES COORDONNEES DU NOUVEAU NOEUD 4 (DE NUMERO NPOIN2)
00089 !=======================================================================
00090 !
00091       NPOIN2 = NPOIN2 + 1
00092       I1 = IKLE(ISURC,1)
00093       I2 = IKLE(ISURC,2)
00094       I3 = IKLE(ISURC,3)
00095 !
00096       X(NPOIN2) = (X(I1) + X(I2) + X(I3))/3.D0
00097       Y(NPOIN2) = (Y(I1) + Y(I2) + Y(I3))/3.D0
00098 !
00099 !=======================================================================
00100 ! DEFINITION DE LA COULEUR DU NOEUD CREE (C'EST CELLE DU NOEUD NON POINT
00101 ! DE BORD DE L'ELEMENT VOISIN)
00102 !=======================================================================
00103 !
00104       IF (COLOR) THEN
00105         DO IFAC=1,3
00106           IF(IFABOR(ISURC,IFAC).GT.0) ICOLOR = IFABOR(ISURC,IFAC)
00107         ENDDO
00108 !
00109         DO I=1,3
00110           IF(IKLE(ICOLOR,I).NE.I1.AND.IKLE(ICOLOR,I).NE.I2.AND.
00111      &       IKLE(ICOLOR,I).NE.I3)
00112      &       NCOLOR(NPOIN2) = NCOLOR(IKLE(ICOLOR,I))
00113         ENDDO
00114       ENDIF
00115 !
00116 !=======================================================================
00117 ! CALCUL DES NOUVEAUX IKLE : L'ELEMENT (1,2,4) CONSERVE LE NUMERO ISURC
00118 !                            L'ELEMENT (2,3,4) PREND LE NUMERO NELEM2+1
00119 !                            L'ELEMENT (3,1,4) PREND LE NUMERO NELEM2+2
00120 !=======================================================================
00121 !
00122       IKLE(ISURC,3) = NPOIN2
00123 !
00124       NELEM2 = NELEM2 + 1
00125       IKLE(NELEM2,1) = I2
00126       IKLE(NELEM2,2) = I3
00127       IKLE(NELEM2,3) = NPOIN2
00128 !
00129       KELEM = IFABOR(ISURC,2)
00130       IFABOR(NELEM2,1) = KELEM
00131       IFABOR(NELEM2,2) = NELEM2+1
00132       IFABOR(NELEM2,3) = ISURC
00133       IF (KELEM.GT.0) THEN
00134         IF (IFABOR(KELEM,1).EQ.ISURC) IFABOR(KELEM,1) = NELEM2
00135         IF (IFABOR(KELEM,2).EQ.ISURC) IFABOR(KELEM,2) = NELEM2
00136         IF (IFABOR(KELEM,3).EQ.ISURC) IFABOR(KELEM,3) = NELEM2
00137       ENDIF
00138       IFABOR(ISURC,2) = NELEM2
00139 !
00140       NELEM2 = NELEM2 + 1
00141       IKLE(NELEM2,1) = I3
00142       IKLE(NELEM2,2) = I1
00143       IKLE(NELEM2,3) = NPOIN2
00144 !
00145       KELEM = IFABOR(ISURC,3)
00146       IFABOR(NELEM2,1) = IFABOR(ISURC,3)
00147       IFABOR(NELEM2,2) = ISURC
00148       IFABOR(NELEM2,3) = NELEM2-1
00149       IF (KELEM.GT.0) THEN
00150         IF (IFABOR(KELEM,1).EQ.ISURC) IFABOR(KELEM,1) = NELEM2
00151         IF (IFABOR(KELEM,2).EQ.ISURC) IFABOR(KELEM,2) = NELEM2
00152         IF (IFABOR(KELEM,3).EQ.ISURC) IFABOR(KELEM,3) = NELEM2
00153       ENDIF
00154       IFABOR(ISURC,3) = NELEM2
00155 !
00156 !=======================================================================
00157 !
00158       RETURN
00159       END

Generated on Fri Aug 31 2013 18:12:58 by S.E.Bourban (HRW) using doxygen 1.7.0