fonstr.f

Go to the documentation of this file.
00001 C:\opentelemac\v7p0\sources\utils\bief\fonstr.f
00002 !
00072                      SUBROUTINE FONSTR
00073 !                    *****************
00074 !
00075      &(H,ZF,Z,CHESTR,NGEO,FFORMAT,NFON,NOMFON,MESH,FFON,LISTIN)
00076 !
00077 !***********************************************************************
00078 ! BIEF   V6P3                                   21/08/2010
00079 !***********************************************************************
00080 !
00081 !
00082 !
00083 !
00084 !
00085 !
00086 !
00087 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
00088 !| CHESTR         |<--| FRICTION COEFFICIENT (DEPENDING ON FRICTION LAW)
00089 !| FFON           |-->| FRICTION COEFFICIENT IF CONSTANT
00090 !| H              |<--| WATER DEPTH
00091 !| LISTIN         |-->| IF YES, WILL GIVE A REPORT
00092 !| MESH           |-->| MESH STRUCTURE
00093 !| NFON           |-->| LOGICAL UNIT OF BOTTOM FILE
00094 !| NGEO           |-->| LOGICAL UNIT OF GEOMETRY FILE
00095 !| NOMFON         |-->| NAME OF BOTTOM FILE
00096 !| Z              |<--| FREE SURFACE ELEVATION
00097 !| ZF             |-->| ELEVATION OF BOTTOM
00098 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
00099 !
00100       USE BIEF, EX_FONSTR => FONSTR
00101 !
00102       IMPLICIT NONE
00103       INTEGER LNG,LU
00104       COMMON/INFO/LNG,LU
00105 !
00106 !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
00107 !
00108       TYPE(BIEF_OBJ), INTENT(INOUT) :: H,ZF,Z,CHESTR
00109       CHARACTER(LEN=72), INTENT(IN) :: NOMFON
00110       TYPE(BIEF_MESH), INTENT(IN)   :: MESH
00111       DOUBLE PRECISION, INTENT(IN)  :: FFON
00112       LOGICAL, INTENT(IN)           :: LISTIN
00113       INTEGER, INTENT(IN)           :: NGEO,NFON
00114       CHARACTER(LEN=8), INTENT(IN)  :: FFORMAT
00115 !
00116 !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
00117 !
00118       INTEGER ERR
00119 !
00120       DOUBLE PRECISION BID
00121       REAL, ALLOCATABLE :: W(:)
00122 !
00123       LOGICAL CALFON,CALFRO,OK,LUZF,LUH,LUZ
00124 !
00125 !-----------------------------------------------------------------------
00126 !
00127       ALLOCATE(W(MESH%NPOIN),STAT=ERR)
00128       CALL CHECK_ALLOCATE(ERR,'FONSTR:W')
00129 !
00130 !-----------------------------------------------------------------------
00131 !
00132 !    ASSUMES THAT THE FILE HEADER LINES HAVE ALREADY BEEN READ
00133 !    WILL START READING THE RESULT RECORDS
00134 !
00135 !-----------------------------------------------------------------------
00136 !
00137 !    INITIALISES
00138 !
00139       LUH  =  .FALSE.
00140       LUZ  =  .FALSE.
00141       LUZF =  .FALSE.
00142       CALFRO = .TRUE.
00143 !
00144 !-----------------------------------------------------------------------
00145 !
00146 !     LOOKS FOR THE FRICTION COEFFICIENT IN THE FILE
00147 !
00148       IF(LNG.EQ.1) CALL FIND_IN_SEL(CHESTR,'FROTTEMENT      ',NGEO,
00149      &                              FFORMAT,W,OK,TIME=BID)
00150       IF(LNG.EQ.2) CALL FIND_IN_SEL(CHESTR,'BOTTOM FRICTION ',NGEO,
00151      &                              FFORMAT,W,OK,TIME=BID)
00152 !     CASE OF A GEOMETRY FILE IN ANOTHER LANGUAGE
00153       IF(.NOT.OK.AND.LNG.EQ.1) THEN
00154         CALL FIND_IN_SEL(CHESTR,'BOTTOM FRICTION ',NGEO,
00155      &                   FFORMAT,W,OK,TIME=BID)
00156       ENDIF
00157       IF(.NOT.OK.AND.LNG.EQ.2) THEN
00158         CALL FIND_IN_SEL(CHESTR,'FROTTEMENT      ',NGEO,
00159      &                   FFORMAT,W,OK,TIME=BID)
00160       ENDIF
00161       IF(OK) THEN
00162         CALFRO = .FALSE.
00163         IF(LNG.EQ.1) WRITE(LU,5)
00164         IF(LNG.EQ.2) WRITE(LU,6)
00165 5       FORMAT(1X,'FONSTR : COEFFICIENTS DE FROTTEMENT LUS DANS',/,
00166      &         1X,'         LE FICHIER DE GEOMETRIE')
00167 6       FORMAT(1X,'FONSTR : FRICTION COEFFICIENTS READ IN THE',/,
00168      &         1X,'         GEOMETRY FILE')
00169       ENDIF
00170 !
00171 !     LOOKS FOR THE BOTTOM ELEVATION IN THE FILE
00172 !
00173       IF(LNG.EQ.1) CALL FIND_IN_SEL(ZF,'FOND            ',NGEO,
00174      &                              FFORMAT,W,OK,TIME=BID)
00175       IF(LNG.EQ.2) CALL FIND_IN_SEL(ZF,'BOTTOM          ',NGEO,
00176      &                              FFORMAT,W,OK,TIME=BID)
00177       IF(.NOT.OK.AND.LNG.EQ.1) THEN
00178         CALL FIND_IN_SEL(ZF,'BOTTOM          ',NGEO,
00179      &                   FFORMAT,W,OK,TIME=BID)
00180       ENDIF
00181       IF(.NOT.OK.AND.LNG.EQ.2) THEN
00182         CALL FIND_IN_SEL(ZF,'FOND            ',NGEO,
00183      &                   FFORMAT,W,OK,TIME=BID)
00184       ENDIF
00185 !     MESHES FROM BALMAT ?
00186       IF(.NOT.OK) CALL FIND_IN_SEL(ZF,'ALTIMETRIE      ',NGEO,
00187      &                             FFORMAT,W,OK,TIME=BID)
00188 !     TOMAWAC IN FRENCH ?
00189       IF(.NOT.OK) CALL FIND_IN_SEL(ZF,'COTE_DU_FOND    ',NGEO,
00190      &                             FFORMAT,W,OK,TIME=BID)
00191 !     TOMAWAC IN ENGLISH ?
00192       IF(.NOT.OK) CALL FIND_IN_SEL(ZF,'BOTTOM_LEVEL    ',NGEO,
00193      &                             FFORMAT,W,OK,TIME=BID)
00194       LUZF = OK
00195 !
00196       IF(.NOT.LUZF) THEN
00197 !       LOOKS FOR WATER DEPTH AND FREE SURFACE ELEVATION
00198         IF(LNG.EQ.1) CALL FIND_IN_SEL(H,'HAUTEUR D''EAU   ',NGEO,
00199      &                                FFORMAT,W,OK,TIME=BID)
00200         IF(LNG.EQ.2) CALL FIND_IN_SEL(H,'WATER DEPTH     ',NGEO,
00201      &                                FFORMAT,W,OK,TIME=BID)
00202         IF(.NOT.OK.AND.LNG.EQ.1) THEN
00203           CALL FIND_IN_SEL(H,'WATER DEPTH     ',NGEO,
00204      &                     FFORMAT,W,OK,TIME=BID)
00205 
00206         ENDIF
00207         IF(.NOT.OK.AND.LNG.EQ.2) THEN
00208           CALL FIND_IN_SEL(H,'HAUTEUR D''EAU   ',NGEO,
00209      &                     FFORMAT,W,OK,TIME=BID)
00210         ENDIF
00211         LUH = OK
00212         IF(LNG.EQ.1) CALL FIND_IN_SEL(Z,'SURFACE LIBRE   ',NGEO,
00213      &                                FFORMAT,W,OK,TIME=BID)
00214         IF(LNG.EQ.2) CALL FIND_IN_SEL(Z,'FREE SURFACE    ',NGEO,
00215      &                                FFORMAT,W,OK,TIME=BID)
00216         IF(.NOT.OK.AND.LNG.EQ.1) THEN
00217           CALL FIND_IN_SEL(Z,'FREE SURFACE    ',NGEO,
00218      &                     FFORMAT,W,OK,TIME=BID)
00219         ENDIF
00220         IF(.NOT.OK.AND.LNG.EQ.2) THEN
00221           CALL FIND_IN_SEL(Z,'SURFACE LIBRE   ',NGEO,
00222      &                     FFORMAT,W,OK,TIME=BID)
00223         ENDIF
00224         LUZ = OK
00225       ENDIF
00226 !
00227 !     INITIALISES THE BOTTOM ELEVATION
00228 !
00229       IF(LUZF) THEN
00230 !
00231         CALFON = .FALSE.
00232 !
00233       ELSE
00234 !
00235         IF (LUZ.AND.LUH) THEN
00236 !
00237           CALL OS( 'X=Y-Z   ' , ZF , Z , H , BID )
00238           IF(LNG.EQ.1) WRITE(LU,24)
00239           IF(LNG.EQ.2) WRITE(LU,25)
00240 24        FORMAT(1X,'FONSTR (BIEF) : ATTENTION, FOND CALCULE AVEC',/,
00241      &              '                PROFONDEUR ET SURFACE LIBRE',/,
00242      &              '                DU FICHIER DE GEOMETRIE')
00243 25        FORMAT(1X,'FONSTR (BIEF): ATTENTION, THE BOTTOM RESULTS',/,
00244      &              '               FROM DEPTH AND SURFACE ELEVATION',
00245      &            /,'               FOUND IN THE GEOMETRY FILE')
00246           CALFON = .FALSE.
00247 !
00248         ELSE
00249 !
00250           CALFON = .TRUE.
00251 !
00252         ENDIF
00253 !
00254       ENDIF
00255 !
00256 !-----------------------------------------------------------------------
00257 !
00258 ! BUILDS THE BOTTOM IF IT WAS NOT IN THE GEOMETRY FILE
00259 !
00260       IF(NOMFON(1:1).NE.' ') THEN
00261 !       A BOTTOM FILE WAS GIVEN, (RE)COMPUTES THE BOTTOM ELEVATION
00262         IF(LISTIN) THEN
00263           IF(LNG.EQ.1) WRITE(LU,2223) NOMFON
00264           IF(LNG.EQ.2) WRITE(LU,2224) NOMFON
00265           IF(.NOT.CALFON) THEN
00266             IF(LNG.EQ.1) WRITE(LU,2225)
00267             IF(LNG.EQ.2) WRITE(LU,2226)
00268           ENDIF
00269         ENDIF
00270 2223    FORMAT(/,1X,'FONSTR (BIEF) : FOND DANS LE FICHIER : ',A72)
00271 2224    FORMAT(/,1X,'FONSTR (BIEF): BATHYMETRY GIVEN IN FILE : ',A72)
00272 2225    FORMAT(  1X,'                LE FOND TROUVE DANS LE FICHIER',/,
00273      &           1X,'                DE GEOMETRIE EST IGNORE',/)
00274 2226    FORMAT(  1X,'               BATHYMETRY FOUND IN THE',/,
00275      &           1X,'               GEOMETRY FILE IS IGNORED',/)
00276 !
00277         CALL FOND(ZF%R,MESH%X%R,MESH%Y%R,MESH%NPOIN,NFON,
00278      &            MESH%NBOR%I,MESH%KP1BOR%I,MESH%NPTFR)
00279 !
00280       ELSEIF(CALFON) THEN
00281         IF(LISTIN) THEN
00282           IF(LNG.EQ.1) WRITE(LU,2227)
00283           IF(LNG.EQ.2) WRITE(LU,2228)
00284         ENDIF
00285 2227    FORMAT(/,1X,'FONSTR (BIEF) : PAS DE FOND DANS LE FICHIER DE',
00286      &         /,1X,'                GEOMETRIE ET PAS DE FICHIER DES',
00287      &         /,1X,'                FONDS. LE FOND EST INITIALISE A'
00288      &         /,1X,'                ZERO MAIS PEUT ENCORE ETRE MODIFIE'
00289      &         /,1X,'                DANS CORFON.',
00290      &         /,1X)
00291 2228    FORMAT(/,1X,'FONSTR (BIEF): NO BATHYMETRY IN THE GEOMETRY FILE',
00292      &         /,1X,'               AND NO BATHYMETRY FILE. THE BOTTOM',
00293      &         /,1X,'               LEVEL IS FIXED TO ZERO BUT STILL',
00294      &         /,1X,'               CAN BE MODIFIED IN CORFON.',
00295      &         /,1X)
00296         CALL OS( 'X=C     ' , ZF , ZF , ZF , 0.D0 )
00297       ENDIF
00298 !
00299 !-----------------------------------------------------------------------
00300 !
00301 ! COMPUTES THE BOTTOM FRICTION COEFFICIENT
00302 !
00303       IF(CALFRO) THEN
00304         CALL OS( 'X=C     ' , CHESTR , CHESTR , CHESTR , FFON )
00305       ENDIF
00306       CALL STRCHE
00307 !
00308 !-----------------------------------------------------------------------
00309 !
00310       DEALLOCATE(W)
00311 !
00312 !-----------------------------------------------------------------------
00313 !
00314       RETURN
00315       END

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