elmpb.f

Go to the documentation of this file.
00001 C:\opentelemac\v7p0\sources\stbtel\elmpb.f
00002 !
00024                         SUBROUTINE ELMPB
00025 !                       ****************
00026 !
00027      &(NBPB,NUMPB,X,Y,IKLE,NCOLOR,ISDRY,NEW)
00028 !
00029 !***********************************************************************
00030 ! PROGICIEL : STBTEL  V5.2                    A. CABAL / P. LANG SOGREAH
00031 !***********************************************************************
00032 !
00033 !     FONCTION  :  ELIMINATION DES ELEMENTS APPARTENANT A PLUSIEURS
00034 !                  SEGMENTS FRONTIERES
00035 !
00036 !-----------------------------------------------------------------------
00037 !                             ARGUMENTS
00038 ! .________________.____.______________________________________________
00039 ! |      NOM       |MODE|                   ROLE
00040 ! |________________|____|______________________________________________
00041 ! |   NBPB         |--> | NB DE POINTS A SUPPRIMER
00042 ! |   NUMPB        |--> | NUMERO DES POINTS A SUPPRIMER
00043 ! |   X,Y          |<-->| COORDONNEES DU MAILLAGE .
00044 ! |   IKLE         |<-->| NUMEROS GLOBAUX DES NOEUDS DE CHAQUE ELEMENT
00045 ! |   NCOLOR       |<-->| TABLEAU DES COULEURS DES POINTS DU MAILLAGE
00046 ! | ELPSEC         | -->| INDICATEUR ELIMIN. DES ELEMENTS PARTIELLEMENT SECS
00047 ! | ISDRY(NELMAX)  |<-- | TAB INDICATEUR ELEMENTS SECS
00048 ! |                |    | = 1 POINT TOUJOURS SEC,
00049 ! |                |    | = 0 SOUS SEUSEC M D'EAU AU MOINS POUR 1 PAS DE TEMPS
00050 ! | IHAUT          | -->| NUM D'ORDRE DE LA VARIABLE HAUT D'EAU DANS FICH TEL2D
00051 ! | NVAR           | -->| NB DE VAR STOCKEES DANS LE FICHIER TEL2D
00052 ! | H              | -->| TABLEAU DES HAUTEURS D'EAU
00053 ! |________________|____|______________________________________________
00054 ! | COMMON:        |    |
00055 ! |  GEO:          |
00056 ! |    MESH        | -->| TYPE DES ELEMENTS DU MAILLAGE
00057 ! |    NDP         | -->| NOMBRE DE NOEUDS PAR ELEMENTS
00058 ! |    NPOIN       |<-->| NOMBRE TOTAL DE NOEUDS DU MAILLAGE
00059 ! |    NELEM       |<-->| NOMBRE TOTAL D'ELEMENTS DU MAILLAGE
00060 ! |    NPMAX       | -->| DIMENSION EFFECTIVE DES TABLEAUX X ET Y
00061 ! |                |    | (NPMAX = NPOIN + 0.1*NELEM)
00062 ! |    NELMAX      | -->| DIMENSION EFFECTIVE DES TABLEAUX CONCERNANT
00063 ! |                |    | LES ELEMENTS (NELMAX = NELEM + 0.2*NELEM)
00064 ! |________________|____|______________________________________________
00065 ! MODE : -->(DONNEE NON MODIFIEE), <--(RESULTAT), <-->(DONNEE MODIFIEE)
00066 !----------------------------------------------------------------------
00067 ! APPELE PAR : STBTEL
00068 !***********************************************************************
00069 !
00070       IMPLICIT NONE
00071 !
00072       INTEGER      MESH, NDP , NPOIN , NELEM , NPMAX , NELMAX
00073       COMMON/GEO/ MESH , NDP , NPOIN , NELEM , NPMAX , NELMAX
00074 !
00075       INTEGER IKLE(NELMAX,4), ISDRY(NPMAX), NEW(NPMAX)
00076       INTEGER NCOLOR(NPMAX)
00077       INTEGER NBPB, NUMPB(100)
00078       INTEGER I, IEL, J, NELI
00079 !
00080       DOUBLE PRECISION X(NPMAX) , Y(NPMAX)
00081 !
00082       INTEGER LNG,LU
00083       COMMON/INFO/LNG,LU
00084 !
00085 !     -------------------------------------------------------------
00086 !     ELIMINATION DES ELEMENTS COMPORTANT DES POINTS A PROBLEME
00087 !     -------------------------------------------------------------
00088 !
00089       DO I=1,NBPB
00090         DO IEL = 1, NELEM
00091           IF (IKLE(IEL,1).EQ.NUMPB(I).OR.IKLE(IEL,2).EQ.NUMPB(I)
00092      &        .OR.IKLE(IEL,3).EQ.NUMPB(I)) THEN
00093             IKLE(IEL, 1) = 0
00094             IKLE(IEL, 2) = 0
00095             IKLE(IEL, 3) = 0
00096           ENDIF
00097         ENDDO
00098       ENDDO
00099 !
00100 !     ELIMINATION DES ELEMENTS
00101 !     ------------------------
00102 !
00103       NELI = 0
00104       IEL = 1
00105 !     POUR CHAQUE ELEMENT FAIRE
00106  20   CONTINUE
00107         IF ((IKLE(IEL, 1).EQ.0).AND.(IKLE(IEL, 2).EQ.0).AND.
00108      &     (IKLE(IEL, 3).EQ.0)) THEN
00109           NELI = NELI + 1
00110           DO I = IEL, NELEM - NELI
00111             IKLE(I,1) = IKLE(I+1, 1)
00112             IKLE(I,2) = IKLE(I+1, 2)
00113             IKLE(I,3) = IKLE(I+1, 3)
00114           ENDDO
00115         ELSE
00116           IEL = IEL + 1
00117         ENDIF
00118       IF (IEL .LE. NELEM-NELI) GOTO 20
00119 !     FIN POUR CHAQUE ELEMENT
00120 !
00121       IF (LNG.EQ.1) WRITE(LU,1009) NELI
00122       IF (LNG.EQ.2) WRITE(LU,2009) NELI
00123 !
00124       NELEM = NELEM - NELI
00125 !
00126 !      ELIMINATION DES POINTS NE FAISANT PLUS PARTIE DU MAILLAGE
00127 !      REUTILISATION DE ISDRY POUR MARQUER LES POINTS NON UTILISEES
00128 !      ---------------------------------------------
00129       DO I = 1, NPOIN
00130         ISDRY(I) = 0
00131         NEW(I) = 0
00132       ENDDO
00133 !
00134       DO IEL = 1, NELEM
00135       ENDDO
00136 !
00137       NELI = 0
00138       I = 1
00139 !     POUR CHAQUE POINT FAIRE
00140       DO I = 1, NPOIN
00141         IF (ISDRY(I) .EQ.0) THEN
00142           NELI = NELI + 1
00143           NEW(I) = 0
00144         ELSE
00145           NEW(I) = I - NELI
00146         ENDIF
00147       ENDDO
00148 !     FIN POUR CHAQUE POINT
00149 !
00150       NELI = 0
00151       I = 1
00152 !     POUR CHAQUE POINT FAIRE
00153  30   CONTINUE
00154         IF (ISDRY(I) .EQ.0) THEN
00155 !         POINT I  A ELIMINER
00156           NELI = NELI + 1
00157 !         DECALAGE DANS LE TABLEAU DES POINTS
00158           DO J = I, NPOIN - NELI
00159             X(J) = X(J+1)
00160             Y(J) = Y(J+1)
00161             NCOLOR(J) = NCOLOR(J+1)
00162             IF (ISDRY(J+1).GT.0) THEN
00163               ISDRY(J) = ISDRY(J+1) - 1
00164             ELSE
00165               ISDRY(J) = 0
00166             ENDIF
00167           ENDDO
00168         ELSE
00169           I = I + 1
00170         ENDIF
00171       IF (I .LE. NPOIN - NELI) GOTO 30
00172 !     FIN POUR CHAQUE POINT
00173       IF (LNG.EQ.1) WRITE(LU,1011) NELI
00174       IF (LNG.EQ.2) WRITE(LU,2011) NELI
00175       NPOIN = NPOIN - NELI
00176 !
00177 !     ON REPERCUTE LA RENUMEROTATION DANS IKLE
00178 !     ----------------------------------------
00179       DO IEL = 1, NELEM
00180         J = IKLE(IEL,1)
00181         IKLE(IEL,1) = NEW(J)
00182         J = IKLE(IEL,2)
00183         IKLE(IEL,2) = NEW(J)
00184         J = IKLE(IEL,3)
00185         IKLE(IEL,3) = NEW(J)
00186       ENDDO
00187       RETURN
00188 !***********************************************************************
00189  1009 FORMAT(1X,'ELEMENTS SUPPRIMES DU MAILLAGE :',I8)
00190  2009 FORMAT(1X,'ELEMENTS CANCELLED IN THE MESH:',I8)
00191  1011 FORMAT(1X,'POINTS SUPPRIMES DU MAILLAGE :  ',I8)
00192  2011 FORMAT(1X,'POINTS CANCELLED IN THE MESH:  ',I8)
00193       END

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