lecwac1.f

Go to the documentation of this file.
00001 C:\opentelemac\v7p0\sources\artemis\lecwac1.f
00002 !
00057                      SUBROUTINE LECWAC1
00058 !                    ******************
00059 !
00060 !
00061 !***********************************************************************
00062 ! ARTEMIS   V7P0                                  07/2014
00063 !***********************************************************************
00064 !
00065 !         THIS SPECTRUM IS APPLIED ON THE WAVE INCIDENT BOURNDARIES
00066 !
00067 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
00068 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
00069       USE DECLARATIONS_TELEMAC
00070       USE DECLARATIONS_ARTEMIS
00071 !      USE INTERFACE_ARTEMIS, ONLY: SPE,SPD
00072 !
00073       IMPLICIT NONE
00074       INTEGER LNG,LU
00075       COMMON/INFO/LNG,LU
00076 !
00077       CHARACTER*80 TITRE,FILE_SPE,PATH
00078       CHARACTER*32 TEXTEBID
00079       INTEGER      NBI1,NSPE,IBID(10),NBCL,IP,ILEN
00080       INTEGER      IPLAN,IFF,ID,KK,J,IDEC,JD
00081       REAL         BID, CL1(MAXDIR,MAXFRE,1)
00082       REAL         XTWC(MAXDIR,MAXFRE),YTWC(MAXDIR,MAXFRE)
00083       REAL         READTWC(MAXDIR*MAXFRE),STOCKD(MAXDIR)
00084       REAL         PI,DEGRAD,DF,DTETA,FF,DD,EPS
00085       PARAMETER(PI = 3.1415926535897932384626433D0 , DEGRAD=PI/180.D0)
00086 
00087 !     A AJOUTER DANS LE DICO
00088 !      NFTWC  = 50
00089 !      NDTWC  = 48
00090 !      TPSTWC =30000D0
00091 !.....CONTROLE SIZE OF TABLES FROM TOMAWAC
00092       IF (NDTWC.GT.MAXDIR) THEN
00093         WRITE(LU,*) 'TOO MANY DIRECTIONS IN TOMAWAC SPECTRUM  '
00094         WRITE(LU,*) 'INCREASE MAXDIR IN declarations_artemis.f'
00095         CALL PLANTE(0)
00096       ENDIF
00097       IF (NFTWC.GT.MAXFRE) THEN
00098         WRITE(LU,*) 'TOO MANY FREQUENCIES IN TOMAWAC SPECTRUM  '
00099         WRITE(LU,*) 'INCREASE MAXFRE IN declarations_artemis.f'
00100         CALL PLANTE(0)
00101       ENDIF
00102 !-------------------------------------------
00103       WRITE(LU,*) '==================================================='
00104       WRITE(LU,*) '========== READING SPECTRUM FROM TOMAWAC =========='
00105 !=====READING SELAPHIN FILE (.spe)
00106       NBI1 = ART_FILES(ARTTC1)%LU
00107 !.....READ FIRST LINES
00108       READ(NBI1) TITRE
00109 !
00110       READ(NBI1) IBID(1),IBID(2)
00111 !
00112       NBCL=IBID(1)
00113       DO IP=1,NBCL
00114         READ(NBI1) TEXTEBID
00115       ENDDO
00116       READ(NBI1) (IBID(IP),IP=1,10)
00117 !
00118       IF (IBID(10).EQ.1) THEN
00119         READ(NBI1) (IBID(IP),IP=1,6)
00120 !
00121       ENDIF
00122       READ(NBI1) (IBID(IP),IP=1,4)
00123 !
00124       READ(NBI1) (IBID(IP),IP=1,1)
00125 !
00126       READ(NBI1) (IBID(IP),IP=1,1)
00127 !
00128       READ(NBI1)  ((XTWC(IPLAN,IFF),IPLAN=1,NDTWC),IFF=1,NFTWC)
00129       READ(NBI1)  ((YTWC(IPLAN,IFF),IPLAN=1,NDTWC),IFF=1,NFTWC)
00130 !
00131 !
00132 !.....READ DATA
00133    50 CONTINUE
00134       READ(NBI1) BID
00135 !     Looking for the right date
00136       IF (ABS(BID-TPSTWC).GE.1E-2) THEN
00137         READ(NBI1) (READTWC(KK),KK=1,NFTWC*NDTWC)
00138         GOTO 50
00139       ENDIF
00140 !
00141       DO IP=1,NBCL
00142         READ(NBI1) (READTWC(KK),KK=1,NFTWC*NDTWC)
00143         KK=1
00144 !       order DATA into line,column format : CL1
00145         DO IFF=1,NFTWC
00146           DO IPLAN=1,NDTWC
00147             CL1(IPLAN,IFF,IP)=READTWC(KK)
00148             KK=KK+1
00149           ENDDO
00150         ENDDO
00151       ENDDO
00152 !.....END READING
00153 !==========================================
00154 
00155 
00156 
00157 !.......SPECTRUM CONSTRUCTION
00158 !=============================
00159 !=====DIRECTION
00160       DO ID=1,NDTWC
00161 !       COMPUTE DIRECTION FROM .spe file
00162         DIRTWC(NDTWC-ID+1)  = ATAN2(YTWC(ID,NFTWC),XTWC(ID,NFTWC))
00163 !       Into degres
00164         DIRTWC(NDTWC-ID+1)  = DIRTWC(NDTWC-ID+1)/DEGRAD
00165 !       Into [0,360]
00166         IF (DIRTWC(NDTWC-ID+1).LT.0D0) THEN
00167           DIRTWC(NDTWC-ID+1)  =360D0+DIRTWC(NDTWC-ID+1)
00168         ENDIF
00169       ENDDO
00170 !     FIND THE SMALLEST DIRECTION IN [0;360] => IDEC
00171       IDEC=0
00172       EPS=1000D0
00173       DO ID=1,NDTWC
00174 !       STOCK THE DIRECTION
00175         STOCKD(ID)=DIRTWC(ID)
00176         IF (ABS(DIRTWC(ID)).LT.EPS) THEN
00177           IDEC=ID
00178           EPS=ABS(DIRTWC(ID))
00179         ENDIF
00180       ENDDO
00181 !     ORDER DIRTWC FROM 0 to 360
00182       DO ID=1,NDTWC
00183         IF (ID.GE.IDEC) THEN
00184           J=ID-IDEC+1
00185         ELSE
00186           J=NDTWC+ID-IDEC+1
00187         ENDIF
00188         DIRTWC(J)=STOCKD(ID)
00189       ENDDO
00190       DIRTWC(NDTWC+1)=DIRTWC(1)+360D0
00191 !
00192 !=====FREQUENCY
00193       DO IFF=1,NFTWC
00194         FREQTWC(IFF)  = SQRT(XTWC(1,IFF)**2+YTWC(1,IFF)**2)
00195       ENDDO
00196 !=====AMPLITUDE
00197       DO ID=1,NDTWC
00198 !       JD correspond to ID in the CL1 table
00199         JD=NDTWC-ID+1
00200 !       J correspond to ID in the DIRTWC table
00201         IF (ID.GE.IDEC) THEN
00202           J=ID-IDEC+1
00203         ELSE
00204           J=NDTWC+ID-IDEC+1
00205         ENDIF
00206         DO IFF=1,NFTWC
00207 !         Compute SPETWC(J,I) <=> (DIRTWC(J) ; FREQTWC(I))
00208           SPETWC(J,IFF)= CL1(JD,IFF,1)
00209           IF (J.EQ.1) THEN
00210             SPETWC(NDTWC+J,IFF)= SPETWC(J,IFF)
00211           ENDIF
00212         ENDDO
00213       ENDDO
00214 ! END BUILDING
00215 !===========================
00216 
00217       WRITE(LU,*) '========END READING SPRECTRUM FROM TOMAWAC========='
00218       WRITE(LU,*) '                                                   '
00219 
00220 ! TEST CHAINAGE
00221 !      DO ID=1,NDTWC+1
00222 !        DD= DIRTWC(ID)
00223 !        DO IFF=1,NFTWC
00224 !          FF=FREQTWC(IFF)
00225 !          SPETWC(ID,IFF) =SPE(FF)*SPD(DD-270D0)
00226 !        ENDDO
00227 !      ENDDO
00228 !-----------------------------------------------------------------------
00229 !
00230       RETURN
00231       END

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