elmsec.f

Go to the documentation of this file.
00001 C:\opentelemac\v7p0\sources\stbtel\elmsec.f
00002 !
00031                         SUBROUTINE ELMSEC
00032 !                       *****************
00033 !
00034      &( ELPSEC, SEUSEC, TPSFIN,  X, Y, IKLE, NCOLOR, ISDRY,
00035      &  IHAUT, NVAR, H, WORK, NEW, STD, NGEO )
00036 !
00037 !***********************************************************************
00038 ! PROGICIEL : STBTEL V5.2                     A. CABAL / P. LANG SOGREAH
00039 !***********************************************************************
00040 !
00041 !     FONCTION  :  ELIMINATION DES ELEMENTS SECS DU MAILLAGE
00042 !
00043 !-----------------------------------------------------------------------
00044 !                             ARGUMENTS
00045 ! .________________.____.______________________________________________
00046 ! |      NOM       |MODE|                   ROLE
00047 ! |________________|____|______________________________________________
00048 ! |   X,Y          |<-->| COORDONNEES DU MAILLAGE .
00049 ! |   IKLE         |<-->| NUMEROS GLOBAUX DES NOEUDS DE CHAQUE ELEMENT
00050 ! |   NCOLOR       |<-->| TABLEAU DES COULEURS DES POINTS DU MAILLAGE
00051 ! | ELPSEC         | -->| INDICATEUR ELIMIN. DES ELEMENTS PARTIELLEMENT SECS
00052 ! | SEUSEC         | -->| VALEUR POUR LA DEFINITION SECHERESSE
00053 ! | ISDRY(NELMAX)  |<-- | TAB INDICATEUR ELEMENTS SECS
00054 ! |                |    | = 1 POINT TOUJOURS SEC,
00055 ! |                |    | = 0 SOUS SEUSEC M D'EAU AU MOINS POUR 1 PAS DE TEMPS
00056 ! | IHAUT          | -->| NUM D'ORDRE DE LA VARIABLE HAUT D'EAU DANS FICH TEL2D
00057 ! | NVAR           | -->| NB DE VAR STOCKEES DANS LE FICHIER TEL2D
00058 ! | H              | -->| TABLEAU DES HAUTEURS D'EAU
00059 ! | WORK           | -->| TABLEAU (REAL) DE TRAVAIL
00060 ! |________________|____|______________________________________________
00061 ! | COMMON:        |    |
00062 ! |  GEO:          |
00063 ! |    MESH        | -->| TYPE DES ELEMENTS DU MAILLAGE
00064 ! |    NDP         | -->| NOMBRE DE NOEUDS PAR ELEMENTS
00065 ! |    NPOIN       |<-->| NOMBRE TOTAL DE NOEUDS DU MAILLAGE
00066 ! |    NELEM       |<-->| NOMBRE TOTAL D'ELEMENTS DU MAILLAGE
00067 ! |    NPMAX       | -->| DIMENSION EFFECTIVE DES TABLEAUX X ET Y
00068 ! |                |    | (NPMAX = NPOIN + 0.1*NELEM)
00069 ! |    NELMAX      | -->| DIMENSION EFFECTIVE DES TABLEAUX CONCERNANT
00070 ! |                |    | LES ELEMENTS (NELMAX = NELEM + 0.2*NELEM)
00071 ! |  FICH:         |    |
00072 ! |    NRES        |--> | NUMERO DU CANAL DU FICHIER DE SERAFIN
00073 ! |    NGEO       |--> | NUMERO DU CANAL DU FICHIER MAILLEUR
00074 ! |    NLIM      |--> | NUMERO DU CANAL DU FICHIER DYNAM DE TELEMAC
00075 ! |    NFO1      |--> | NUMERO DU CANAL DU FICHIER TRIANGLE TRIGRID
00076 ! |________________|____|______________________________________________
00077 ! MODE : -->(DONNEE NON MODIFIEE), <--(RESULTAT), <-->(DONNEE MODIFIEE)
00078 !----------------------------------------------------------------------
00079 ! APPELE PAR : STBTEL
00080 !***********************************************************************
00081 !
00082       IMPLICIT NONE
00083       INTEGER LNG,LU
00084       COMMON/INFO/LNG,LU
00085 !
00086       LOGICAL ELPSEC
00087       DOUBLE PRECISION SEUSEC
00088 !
00089       INTEGER      MESH, NDP , NPOIN , NELEM , NPMAX , NELMAX
00090       COMMON/GEO/ MESH , NDP , NPOIN , NELEM , NPMAX , NELMAX
00091 !
00092       INTEGER IKLE(NELMAX,4), ISDRY(NPMAX), NEW(NPMAX)
00093       INTEGER NCOLOR(NPMAX)
00094       INTEGER IHAUT, NVAR
00095 !
00096       DOUBLE PRECISION X(NPMAX),Y(NPMAX),H(NPMAX),TPSFIN(1)
00097 !
00098       INTEGER NGEO
00099 !
00100       CHARACTER*3  STD
00101 !
00102       REAL WORK(*)
00103 !
00104 !     VARIABLES LOCALES
00105 !
00106       INTEGER I, IEL, NPDT, NPSEC, NSEC
00107       INTEGER J, NELI
00108       INTEGER IBID(1), ISTAT, NP1, NP2, NP3, ISECH
00109       CHARACTER*72 CBID
00110 !
00111 !     FONCTIONS
00112       LOGICAL BIEF_EOF
00113       EXTERNAL BIEF_EOF
00114 !------------------------------------------------------------
00115       IF (NVAR.EQ.0) THEN
00116         IF (LNG.EQ.1) WRITE(LU,1012)
00117         IF (LNG.EQ.2) WRITE(LU,2012)
00118         RETURN
00119       ENDIF
00120       IF (IHAUT.EQ.0) THEN
00121         IF (LNG.EQ.1) WRITE(LU,1013)
00122         IF (LNG.EQ.2) WRITE(LU,2013)
00123         RETURN
00124       ENDIF
00125 !     INITIALISATION DU TABLEAU ISDRY : PAS DEFAUT TOUS SECS
00126       DO I = 1, NPOIN
00127         ISDRY(I) = 1
00128       ENDDO
00129 !     LECTURE DES RESULTATS TELEMAC ET REMPLISSAGE DU TABLEAU ISDRY
00130 !     -------------------------------------------------------------
00131       NPDT = 0
00132  10   CONTINUE
00133 !     ENSEMBLE DES VARIABLES STOCKEES POUR UN PAS DE TEMPS
00134 !     ----------------------------------------------------
00135       IF (BIEF_EOF(NGEO)) GOTO 12
00136 !     LECTURE DU TEMPS
00137 !     ----------------
00138       CALL LIT(TPSFIN ,WORK,IBID,CBID,1,'R4',NGEO,STD,ISTAT)
00139       IF (BIEF_EOF(NGEO)) GOTO 12
00140       NPDT = NPDT + 1
00141       NPSEC = 0
00142 !
00143 !     ON LIT LES VARIABLES STOCKEES AVANT LA HAUTEUR
00144 !
00145       DO I = 1, IHAUT -1
00146         CALL LIT(H ,WORK,IBID,CBID,NPOIN,'R4',NGEO,STD,ISTAT)
00147       ENDDO
00148 !
00149 !     VARIABLE HAUTEUR D'EAU
00150 !
00151       CALL LIT(H ,WORK,IBID,CBID,NPOIN,'R4',NGEO,STD,ISTAT)
00152 !
00153 !     MISE A JOUR DE ISDRY EN FONCTION DE LA HAUTEUR D'EAU DU PAS DE TEMPS
00154       DO I = 1, NPOIN
00155         IF (H(I).GT.SEUSEC) THEN
00156           ISDRY(I) = 0
00157         ELSE
00158           NPSEC = NPSEC + 1
00159         ENDIF
00160       ENDDO
00161       IF (LNG.EQ.1) WRITE(LU,1000) TPSFIN(1), NPSEC, SEUSEC
00162       IF (LNG.EQ.2) WRITE(LU,2000) TPSFIN(1), NPSEC, SEUSEC
00163 !
00164 !
00165 !     LECTURE AUTRES VARIABLES RESTANTES
00166 !     ----------------------------------
00167       DO I = IHAUT +1, NVAR
00168         CALL LIT(H ,WORK,IBID,CBID,NPOIN,'R4',NGEO,STD,ISTAT)
00169       ENDDO
00170 !
00171       GOTO 10
00172  12   CONTINUE
00173 !
00174 !     FIN DE FICHIER ATTEINTE
00175 !     -----------------------
00176 !     ON RESSORT SI LE FICHIER NE CONTENAIT AUCUN PAS DE TEMPS
00177       IF (NPDT.EQ.0) THEN
00178         IF (LNG.EQ.1) WRITE(LU,1001)
00179         IF (LNG.EQ.2) WRITE(LU,2001)
00180         CALL PLANTE(1)
00181         STOP
00182       ENDIF
00183 !     TEST DES ELEMENTS SECS OU PARTIELLEMENTS SECS
00184 !     ---------------------------------------------
00185       NPSEC = 0
00186       NSEC = 0
00187 !
00188 !     PARCOURS DES ELEMENTS
00189       DO IEL = 1, NELEM
00190         NP1 = IKLE(IEL, 1)
00191         NP2 = IKLE(IEL, 2)
00192         NP3 = IKLE(IEL, 3)
00193         ISECH = ISDRY(NP1) * ISDRY(NP2) * ISDRY(NP3)
00194 !       SI ISECH (PRODUIT) = 1 ELEMENT IEL TOUJOURS SEC
00195         IF (ISECH.EQ.1) THEN
00196 !         POSITIONNE A 0 TOUS LES NUMEROS DES POINTS DE L'ELEMENT
00197           NSEC = NSEC + 1
00198           IKLE(IEL, 1) = 0
00199           IKLE(IEL, 2) = 0
00200           IKLE(IEL, 3) = 0
00201         ELSE
00202           IF (ELPSEC) THEN
00203 !         TEST SI ELEMENT PARTIELLEMENT SEC
00204             ISECH =  ISDRY(NP1) + ISDRY(NP2) + ISDRY(NP3)
00205             IF (ISECH.GE.1) THEN
00206 !             ELEMENT PARTIELLEMENT SEC A ELIMINER
00207 !             POSITIONNE A 0 TOUS LES NUMEROS DES POINTS DE L'ELEMENT
00208               IKLE(IEL, 1) = 0
00209               IKLE(IEL, 2) = 0
00210               IKLE(IEL, 3) = 0
00211               NPSEC = NPSEC + 1
00212             ENDIF
00213 !           FIN SI ELIMINATION PART. SECS
00214           ENDIF
00215         ENDIF
00216       ENDDO !IEL
00217 !     FIN PARCOURS DE TOUS LES ELEMENTS
00218       IF (NSEC.EQ.0) THEN
00219         IF (LNG.EQ.1) WRITE(LU,1002)
00220         IF (LNG.EQ.2) WRITE(LU,2002)
00221       ELSE IF (NSEC.EQ.1) THEN
00222         IF (LNG.EQ.1) WRITE(LU,1003)
00223         IF (LNG.EQ.2) WRITE(LU,2003)
00224       ELSE
00225         IF (LNG.EQ.1) WRITE(LU,1004) NSEC
00226         IF (LNG.EQ.2) WRITE(LU,2004) NSEC
00227       ENDIF
00228 !
00229       IF (ELPSEC) THEN
00230         IF (NPSEC.EQ.0) THEN
00231           IF (LNG.EQ.1) WRITE(LU,1005)
00232           IF (LNG.EQ.2) WRITE(LU,2005)
00233         ELSE IF (NPSEC.EQ.1) THEN
00234           IF (LNG.EQ.1) WRITE(LU,1006)
00235           IF (LNG.EQ.2) WRITE(LU,2006)
00236         ELSE
00237           IF (LNG.EQ.1) WRITE(LU,1007) NPSEC
00238           IF (LNG.EQ.2) WRITE(LU,2007) NPSEC
00239         ENDIF
00240       ENDIF
00241 !
00242 !     S'IL N'Y A PAS D'ELEMENTS SECS OU P.SECS ON S'EN VA
00243       IF ((NSEC.EQ.0) .AND. (NPSEC.EQ.0)) RETURN
00244 !
00245 !     ELIMINATION DES ELEMENTS SECS ET PARTIELLLEMENT SECS
00246 !     ---------------------------------------------
00247       NELI = 0
00248       IEL = 1
00249 !     POUR CHAQUE ELEMENT FAIRE
00250  20   CONTINUE
00251         IF ((IKLE(IEL, 1).EQ.0).AND.(IKLE(IEL, 2).EQ.0).AND.
00252      &     (IKLE(IEL, 3).EQ.0)) THEN
00253           NELI = NELI + 1
00254           DO I = IEL, NELEM - NELI
00255             IKLE(I,1) = IKLE(I+1, 1)
00256             IKLE(I,2) = IKLE(I+1, 2)
00257             IKLE(I,3) = IKLE(I+1, 3)
00258           ENDDO
00259         ELSE
00260           IEL = IEL + 1
00261         ENDIF
00262       IF (IEL .LE. NELEM-NELI) GOTO 20
00263 !     FIN POUR CHAQUE ELEMENT
00264 !
00265       IF (NELI .LE. 0) THEN
00266         IF (LNG.EQ.1) WRITE(LU,1008)
00267         IF (LNG.EQ.2) WRITE(LU,2008)
00268       ELSE
00269         IF (LNG.EQ.1) WRITE(LU,1009) NELI
00270         IF (LNG.EQ.2) WRITE(LU,2009) NELI
00271       ENDIF
00272 !
00273       NELEM = NELEM - NELI
00274 !
00275 !     ELIMINATION DES POINTS NE FAISANT PLUS PARTIE DU MAILLAGE
00276 !     REUTILISATION DE ISDRY POUR MARQUER LES POINTS NON UTILISEES
00277 !     ---------------------------------------------
00278       DO I = 1, NPOIN
00279         ISDRY(I) = 0
00280         NEW(I) = 0
00281       ENDDO
00282 !
00283       DO IEL = 1, NELEM
00284         ISDRY(IKLE(IEL,1)) = IKLE(IEL,1)
00285         ISDRY(IKLE(IEL,2)) = IKLE(IEL,2)
00286         ISDRY(IKLE(IEL,3)) = IKLE(IEL,3)
00287       ENDDO
00288 !
00289       NELI = 0
00290       I = 1
00291 !     POUR CHAQUE POINT FAIRE
00292       DO I = 1, NPOIN
00293         IF (ISDRY(I) .EQ.0) THEN
00294           NELI = NELI + 1
00295           NEW(I) = 0
00296         ELSE
00297           NEW(I) = I - NELI
00298         ENDIF
00299       ENDDO
00300 !     FIN POUR CHAQUE POINT
00301 !
00302       NELI = 0
00303       I = 1
00304 !     POUR CHAQUE POINT FAIRE
00305  30   CONTINUE
00306       IF (ISDRY(I).EQ.0) THEN
00307 !       POINT I  A ELIMINER
00308 !       WRITE(LU,*) 'POINT A ELIMINER',I,':',X(I),Y(I),NCOLOR(I)
00309         NELI = NELI + 1
00310 !       DECALAGE DANS LE TABLEAU DES POINTS
00311         DO J = I, NPOIN - NELI
00312           X(J) = X(J+1)
00313           Y(J) = Y(J+1)
00314           NCOLOR(J) = NCOLOR(J+1)
00315           IF (ISDRY(J+1).GT.0) THEN
00316             ISDRY(J) = ISDRY(J+1) - 1
00317           ELSE
00318             ISDRY(J) = 0
00319           ENDIF
00320         ENDDO
00321       ELSE
00322         I = I + 1
00323       ENDIF
00324       IF (I .LE. NPOIN - NELI) GOTO 30
00325 !     FIN POUR CHAQUE POINT
00326       IF (NELI .LE. 0) THEN
00327         IF (LNG.EQ.1) WRITE(LU,1010)
00328         IF (LNG.EQ.2) WRITE(LU,2010)
00329       ELSE
00330         IF (LNG.EQ.1) WRITE(LU,1011) NELI
00331         IF (LNG.EQ.2) WRITE(LU,2011) NELI
00332       ENDIF
00333       NPOIN = NPOIN - NELI
00334 !
00335 !     ON REPERCUTE LA RENUMEROTATION DANS IKLE
00336 !     ----------------------------------------
00337       DO IEL = 1, NELEM
00338         J = IKLE(IEL,1)
00339         IKLE(IEL,1) = NEW(J)
00340         J = IKLE(IEL,2)
00341         IKLE(IEL,2) = NEW(J)
00342         J = IKLE(IEL,3)
00343         IKLE(IEL,3) = NEW(J)
00344       ENDDO
00345       RETURN
00346 !***********************************************************************
00347  1000 FORMAT(1X,'TEMPS ',G15.3,' : ',I8,
00348      &' POINT(S) AVEC HAUTEUR D''EAU EN DESSOUS DE',G15.3)
00349  2000 FORMAT(1X,'TIME ',G15.3,' : ',I8,
00350      &' POINT(S) WITH WATER DEPTH BELOW',G15.3)
00351 !
00352  1001 FORMAT(/,1X,'DESOLE LE FICHIER UNIVERSEL NE CONTIENT PAS DE ',
00353      & /,1X,'RESULTATS DE SIMULATION.',
00354      & /,1X,'DETERMINATION DES ELEMENTS SECS IMPOSSIBLE !')
00355  2001 FORMAT(/,1X,'SORRY, THE UNIVERSAL FILE DOES NOT CONTAIN',
00356      & /,1X,'ANY COMPUTATION RESULTS.',
00357      & /,1X,'FINDING OUT DRY ELEMENTS IS IMPOSSIBLE !')
00358 !
00359  1002 FORMAT(1X,'AUCUN ELEMENT COMPLETEMENT SEC TROUVE ',
00360      & /,1X,'DANS LE MAILLAGE.')
00361  2002 FORMAT(1X,'NO COMPLETELY DRY ELEMENT IN THE MESH.')
00362 !
00363  1003 FORMAT(1X,'UN SEUL ELEMENT COMPLETEMENT SEC ',
00364      & /,1X,'TROUVE DANS LE MAILLAGE.')
00365  2003 FORMAT(1X,'ONLY ONE COMPLETELY DRY ELEMENT FOUND',
00366      & /,1X,'IN THE MESH.')
00367 !
00368  1004 FORMAT(1X,'ELEMENTS COMPLETEMENT SECS TROUVES',
00369      & 1X,'DANS LE MAILLAGE : ',I8)
00370  2004 FORMAT(1X,'COMPLETELY DRY ELEMENTS IN THE MESH: ',I8)
00371 !
00372  1005 FORMAT(1X,'AUCUN ELEMENT PARTIELLEMENT SEC DANS ',
00373      & /,1X,'LE MAILLAGE.')
00374  2005 FORMAT(1X,'NO PARTIALLY DRY ELEMENT IN THE MESH.')
00375 !
00376  1006 FORMAT(1X,'UN SEUL ELEMENT PARTIELLEMENT SEC DANS ',
00377      & /,1X,'LE MAILLAGE.')
00378  2006 FORMAT(1X,'ONLY ONE PARTIALLY DRY ELEMENT IN THE MESH.')
00379 !
00380  1007 FORMAT(1X,'ELEMENTS PARTIELLEMENT SECS TROUVES ',
00381      &'DANS LE MAILLAGE :',I8)
00382  2007 FORMAT(1X,'PARTIALLY DRY ELEMENTS IN THE MESH:',I8)
00383 !
00384  1008 FORMAT(1X,'AUCUN ELEMENT N''A ETE SUPPRIME DU MAILLAGE.')
00385  2008 FORMAT(1X,'NO ELEMENT HAS BEEN CANCELLED IN THE MESH.')
00386 !
00387  1009 FORMAT(1X,'ELEMENTS SUPPRIMES DU MAILLAGE :',I8)
00388  2009 FORMAT(1X,'ELEMENTS CANCELLED IN THE MESH:',I8)
00389 !
00390  1010 FORMAT(1X,'AUCUN POINT N''A ETE SUPPRIME DU MAILLAGE.')
00391  2010 FORMAT(1X,'NO POINT HAS BEEN CANCELLED IN THE MESH.')
00392 !
00393  1011 FORMAT(1X,'POINTS SUPPRIMES DU MAILLAGE :  ',I8)
00394  2011 FORMAT(1X,'POINTS CANCELLED IN THE MESH:  ',I8)
00395 !
00396  1012 FORMAT(/,1X,'AUCUNE VARIABLE N''EST STOCKEE DANS LE FICHIER',
00397      &/,1X,'ELIMINATION DES ELEMENTS SECS IMPOSSIBLE.')
00398  2012 FORMAT(/,1X,'NO VARIABLE STORED ON THE FILE. ',
00399      & /,1X,'DRY ELEMENT SUPPRESSION IS IMPOSSIBLE.')
00400 !
00401  1013 FORMAT(/,1X,'LA VARIABLE HAUTEUR D''EAU NE SEMBLE PAS ETRE',
00402      & /,1X,'STOCKEE DANS LE FICHIER.',
00403      & /,1X,'ELIMINATION DES ELEMENTS SECS IMPOSSIBLE.')
00404  2013 FORMAT(/,1X,'THE WATER DEPTH VARIABLE IS NOT STORED ON THE FILE',
00405      & /,1X,'DRY ELEMENT SUPPRESSION IS IMPOSSIBLE.')
00406       END

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