remail.f

Go to the documentation of this file.
00001 C:\opentelemac\v7p0\sources\stbtel\remail.f
00002 !
00024                         SUBROUTINE REMAIL
00025 !                       *****************
00026 !
00027      &(IKLE,NCOLOR,NEW,X,Y,EPSI)
00028 !
00029 !***********************************************************************
00030 !  PROGICIEL : STBTEL V5.2  17/08/89   J.M. JANIN    (LNH)
00031 !
00032 !***********************************************************************
00033 !
00034 !    FONCTION : ELIMINATION DES POINTS COINCIDENTS ET DES TROUS DU
00035 !               MAILLAGE , RECONSTRUCTION DES TABLEAUX IKLE ET NCOLOR
00036 !
00037 !-----------------------------------------------------------------------
00038 !                             ARGUMENTS
00039 ! .________________.____.______________________________________________.
00040 ! |      NOM       |MODE|                   ROLE                       |
00041 ! |________________|____|______________________________________________|
00042 ! |    IKLE        |<-->| NUMEROS GLOBAUX DES POINTS DE CHAQUE ELEMENT |
00043 ! |    NCOLOR      |<-->| TABLEAU DES COULEURS DES POINTS              |
00044 ! |    PTELI       |<-->| TABLEAU DE TRAVAIL ENTIER.                   |
00045 ! |    NEW         |<-->| TABLEAU DE TRAVAIL ENTIER.                   |
00046 ! |    X,Y         |<-->| COORDONNEES DES POINTS                       |
00047 ! |    EPSI        | -->| DISTANCE MINIMALE ENTRE 2 NOEUDS DU MAILLAGE |
00048 ! |________________|____|______________________________________________
00049 ! | COMMON:        |    |
00050 ! |  GEO:          |    |
00051 ! |    MESH        | -->| TYPE DES ELEMENTS DU MAILLAGE
00052 ! |    NDP         | -->| NOMBRE DE NOEUDS PAR ELEMENTS
00053 ! |    NPOIN       | -->| NOMBRE TOTAL DE NOEUDS DU MAILLAGE
00054 ! |    NELEM       | -->| NOMBRE TOTAL D'ELEMENTS DU MAILLAGE
00055 ! |    NPMAX       | -->| DIMENSION EFFECTIVE DES TABLEAUX X ET Y
00056 ! |                |    | (NPMAX = NPOIN + 0.1*NELEM)
00057 ! |    NELMAX      | -->| DIMENSION EFFECTIVE DES TABLEAUX CONCERNANT
00058 ! |                |    | LES ELEMENTS (NELMAX = NELEM + 0.2*NELEM)
00059 ! |________________|____|______________________________________________|
00060 !  MODE: -->(DONNEE NON MODIFIEE),<--(RESULTAT),<-->(DONNEE MODIFIEE)
00061 !-----------------------------------------------------------------------
00062 ! APPELE PAR : LECSTB
00063 ! APPEL DE : -
00064 !***********************************************************************
00065 !
00066       IMPLICIT NONE
00067       INTEGER LNG,LU
00068       COMMON/INFO/LNG,LU
00069 !
00070       INTEGER MESH , NDP , I , NPOIN , J , NELEM , NPTELI , NELELI
00071       INTEGER NELMAX , NPMAX , I1, I2, I3, I4, J1, J2, J3, J4
00072       INTEGER IKLE(NELMAX,4) , NEW(*) , NCOLOR(*)
00073 !
00074       DOUBLE PRECISION X(*) , Y(*) , EPSI
00075 !
00076       LOGICAL PTPRO , PTELI , ELELI
00077 !
00078       COMMON/GEO/ MESH , NDP , NPOIN , NELEM , NPMAX , NELMAX
00079 !
00080 !=======================================================================
00081 ! RECHERCHE DES POINTS N'APPARTENANT A AUCUN ELEMENT
00082 !=======================================================================
00083 !
00084       DO I=1,NPOIN
00085         NEW(I) = 0
00086       ENDDO
00087 !
00088       DO I=1,NELEM
00089         NEW(IKLE(I,1)) = IKLE(I,1)
00090         NEW(IKLE(I,2)) = IKLE(I,2)
00091         NEW(IKLE(I,3)) = IKLE(I,3)
00092         IF(NDP.EQ.4) NEW(IKLE(I,4)) = IKLE(I,4)
00093       ENDDO
00094 !
00095 !=======================================================================
00096 ! RECHERCHE DES POINTS TROP PROCHES
00097 !=======================================================================
00098 !
00099       EPSI   = EPSI * EPSI
00100       PTPRO  = .FALSE.
00101       PTELI  = .FALSE.
00102       NPTELI = 0
00103 !
00104       DO I=1,NPOIN-1
00105         IF(NEW(I).EQ.I) THEN
00106           DO J=I+1,NPOIN
00107             IF((X(I)-X(J))**2+(Y(I)-Y(J))**2.LT.EPSI
00108      &        .AND.NEW(J).EQ.J) THEN
00109               PTPRO  = .TRUE.
00110               NEW(J) = I
00111             ENDIF
00112           ENDDO
00113         ELSE
00114            PTELI = .TRUE.
00115         ENDIF
00116       ENDDO
00117 !
00118 !=======================================================================
00119 ! SEUL LE DERNIER POINT EST A ELIMINER
00120 !=======================================================================
00121 !
00122       IF(.NOT.PTELI.AND.NEW(NPOIN).NE.NPOIN) NPTELI = 1
00123 !
00124 !=======================================================================
00125 ! MODIFICATION DES IKLE SI DETECTION DE POINTS TROP PROCHES
00126 !=======================================================================
00127 !
00128       IF(PTPRO) THEN
00129         DO I=1,NELEM
00130           IKLE(I,1) = NEW(IKLE(I,1))
00131           IKLE(I,2) = NEW(IKLE(I,2))
00132           IKLE(I,3) = NEW(IKLE(I,3))
00133           IF(NDP.EQ.4) IKLE(I,4) = NEW(IKLE(I,4))
00134         ENDDO
00135       ENDIF
00136 !
00137 !=======================================================================
00138 ! REMPLISSAGE DES TROUS LAISSES PAR L'ELIMINATION DE POINTS
00139 !=======================================================================
00140 !
00141       IF(PTELI) THEN
00142         DO I=1,NPOIN
00143           IF(NEW(I).EQ.I) THEN
00144             NEW(I) = I - NPTELI
00145             X(I-NPTELI) = X(I)
00146             Y(I-NPTELI) = Y(I)
00147             NCOLOR(I-NPTELI) = NCOLOR(I)
00148           ELSE
00149             NPTELI = NPTELI + 1
00150           ENDIF
00151         ENDDO
00152 !
00153 !=======================================================================
00154 ! MODIFICATION DES IKLE DUE AU REMPLISSAGE DES TROUS
00155 !=======================================================================
00156 !
00157         DO I=1,NELEM
00158           IKLE(I,1) = NEW(IKLE(I,1))
00159           IKLE(I,2) = NEW(IKLE(I,2))
00160           IKLE(I,3) = NEW(IKLE(I,3))
00161           IF(NDP.EQ.4) IKLE(I,4) = NEW(IKLE(I,4))
00162         ENDDO
00163       ENDIF
00164 !
00165       NPOIN = NPOIN - NPTELI
00166 !
00167 !=======================================================================
00168 ! RECHERCHE ET ELIMINATION DES ELEMENTS DEGENERES
00169 ! RECHERCHE ET ELIMINATION DES ELEMENTS SUPERPOSES
00170 !=======================================================================
00171 !
00172       ELELI  = .FALSE.
00173       NELELI = 0
00174 !
00175       IF (NDP.EQ.3) THEN
00176 !
00177         DO I=1,NELEM
00178           I1 = IKLE(I,1)
00179           I2 = IKLE(I,2)
00180           I3 = IKLE(I,3)
00181           NEW(I) = 0
00182           IF (I1.EQ.I2.OR.I1.EQ.I3.OR.I2.EQ.I3) NEW(I) = 1
00183         ENDDO
00184 !
00185         DO I=1,NELEM-1
00186           IF (NEW(I).EQ.0) THEN
00187             I1 = IKLE(I,1)
00188             I2 = IKLE(I,2)
00189             I3 = IKLE(I,3)
00190             DO J=I+1,NELEM
00191               IF (NEW(J).EQ.0) THEN
00192                 J1 = IKLE(J,1)
00193                 J2 = IKLE(J,2)
00194                 J3 = IKLE(J,3)
00195                 IF ((I1.EQ.J1.OR.I1.EQ.J2.OR.I1.EQ.J3).AND.
00196      &              (I2.EQ.J1.OR.I2.EQ.J2.OR.I2.EQ.J3).AND.
00197      &              (I3.EQ.J1.OR.I3.EQ.J2.OR.I3.EQ.J3)) NEW(J) = 1
00198               ENDIF
00199             ENDDO
00200           ELSE
00201             ELELI = .TRUE.
00202           ENDIF
00203         ENDDO
00204 !
00205       ELSE
00206 !
00207         DO I=1,NELEM
00208           I1 = IKLE(I,1)
00209           I2 = IKLE(I,2)
00210           I3 = IKLE(I,3)
00211           I4 = IKLE(I,4)
00212           NEW(I) = 0
00213           IF (I1.EQ.I2.OR.I1.EQ.I3.OR.I1.EQ.I4.OR.
00214      &        I2.EQ.I3.OR.I2.EQ.I4.OR.I3.EQ.I4) NEW(I) = 1
00215         ENDDO
00216 !
00217         DO I=1,NELEM-1
00218           IF (NEW(I).EQ.0) THEN
00219             I1 = IKLE(I,1)
00220             I2 = IKLE(I,2)
00221             I3 = IKLE(I,3)
00222             I4 = IKLE(I,4)
00223             DO J=I+1,NELEM
00224               IF (NEW(J).EQ.0) THEN
00225                 J1 = IKLE(J,1)
00226                 J2 = IKLE(J,2)
00227                 J3 = IKLE(J,3)
00228                 J4 = IKLE(J,4)
00229                 IF((I1.EQ.J1.OR.I1.EQ.J2.OR.I1.EQ.J3.OR.I1.EQ.J4).AND.
00230      &       (I2.EQ.J1.OR.I2.EQ.J2.OR.I2.EQ.J3.OR.I2.EQ.J4).AND.
00231      &       (I3.EQ.J1.OR.I3.EQ.J2.OR.I3.EQ.J3.OR.I3.EQ.J4).AND.
00232      &       (I4.EQ.J1.OR.I4.EQ.J2.OR.I4.EQ.J3.OR.I4.EQ.J4)) NEW(J)=1
00233               ENDIF
00234             ENDDO
00235           ELSE
00236             ELELI = .TRUE.
00237           ENDIF
00238         ENDDO
00239 !
00240       ENDIF
00241 !
00242 !=======================================================================
00243 ! SEUL LE DERNIER ELEMENT EST A ELIMINER
00244 !=======================================================================
00245 !
00246       IF(.NOT.ELELI.AND.NEW(NELEM).EQ.1) NELELI = 1
00247 !
00248 !=======================================================================
00249 ! REMPLISSAGE DES TROUS LAISSES PAR L'ELIMINATION D'ELEMENTS
00250 !=======================================================================
00251 !
00252       IF(ELELI) THEN
00253         DO I=1,NELEM
00254           IF(NEW(I).EQ.0) THEN
00255             IKLE(I-NELELI,1) = IKLE(I,1)
00256             IKLE(I-NELELI,2) = IKLE(I,2)
00257             IKLE(I-NELELI,3) = IKLE(I,3)
00258             IF(NDP.EQ.4) IKLE(I-NELELI,4) = IKLE(I,4)
00259           ELSE
00260             NELELI = NELELI + 1
00261           ENDIF
00262         ENDDO
00263       ENDIF
00264 !
00265       NELEM = NELEM - NELELI
00266 !
00267 !=======================================================================
00268 !  SORTIE LISTING
00269 !=======================================================================
00270 !
00271       IF (LNG.EQ.1) WRITE(LU,130) NPTELI,NELELI,NPOIN,NELEM
00272       IF (LNG.EQ.2) WRITE(LU,3130) NPTELI,NELELI,NPOIN,NELEM
00273  130  FORMAT(//,1X,'MISE AU STANDARD TELEMAC',
00274      &        /,1X,'------------------------',/,
00275      &        /,1X,'RENUMEROTATION EFFECTUEE :',
00276      &        /,6X,I9,' POINTS ELIMINES',
00277      &        /,6X,I9,' ELEMENTS ELIMINES',
00278      &        /,1X,'NOUVEAU NOMBRE DE POINTS   :',I9,
00279      &        /,1X,'NOUVEAU NOMBRE D''ELEMENTS  :',I9)
00280  3130 FORMAT(//,1X,'SETTING TELEMAC STANDARD',
00281      &        /,1X,'------------------------',/,
00282      &        /,1X,'RENUMBERING DONE :',
00283      &        /,6X,I9,' POINTS CANCELLED',
00284      &        /,6X,I9,' ELEMENTS CANCELLED',
00285      &        /,1X,'NEW NUMBER OF POINTS   : ',I9,
00286      &        /,1X,'NEW NUMBER OF ELEMENTS : ',I9)
00287 !
00288       RETURN
00289       END

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