iniphy.f

Go to the documentation of this file.
00001 C:\opentelemac\v7p0\sources\tomawac\iniphy.f
00002 !
00068                      SUBROUTINE INIPHY
00069 !                    *****************
00070 !
00071      &( XK    , CG    , B     , DEPTH , FREQ  , COSPHI, NPOIN2, NF    ,
00072      &  PROINF, SPHE  )
00073 !
00074 !***********************************************************************
00075 ! TOMAWAC   V6P1                                   20/06/2011
00076 !***********************************************************************
00077 !
00078 !
00079 !
00080 !
00081 !
00082 !
00083 !
00084 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
00085 !| B              |<--| JACOBIAN TO TRANSFORM N(KX,KY) INTO F(FR,TETA)
00086 !| CG             |<--| DISCRETIZED GROUP VELOCITY
00087 !| COSPHI         |-->| COSINE OF THE LATITUDES OF THE POINTS 2D
00088 !| DEPTH          |-->| WATER DEPTH
00089 !| FREQ           |-->| DISCRETIZED FREQUENCIES
00090 !| NF             |-->| NUMBER OF FREQUENCIES
00091 !| NPOIN2         |-->| NUMBER OF POINTS IN 2D MESH
00092 !| PROINF         |-->| LOGICAL INDICATING INFINITE DEPTH ASSUMPTION
00093 !| SPHE           |-->| LOGICAL INDICATING SPHERICAL COORD ASSUMPTION
00094 !| XK             |<--| DISCRETIZED WAVE NUMBER
00095 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
00096 !
00097       USE DECLARATIONS_TOMAWAC, ONLY : DEUPI,GRAVIT,R2
00098 !
00099       IMPLICIT NONE
00100 !
00101 !.....VARIABLES IN ARGUMENT
00102 !     """"""""""""""""""""
00103       INTEGER          NF    , NPOIN2
00104       DOUBLE PRECISION DEPTH(NPOIN2)    , COSPHI(NPOIN2), FREQ(NF)
00105       DOUBLE PRECISION B(NPOIN2,NF)  , XK(NPOIN2,NF) , CG(NPOIN2,NF)
00106       LOGICAL          PROINF, SPHE
00107 !
00108 !.....LOCAL VARIABLES
00109 !     """""""""""""""""
00110       INTEGER          IP    , JF
00111       DOUBLE PRECISION DEUPI2,DPDSUG,AUX2,AUX1,AUX3,DEUKD
00112 !
00113       DEUPI2=DEUPI**2
00114       DPDSUG=DEUPI2/GRAVIT
00115 !
00116       IF (PROINF) THEN
00117 !                               +----------------------+
00118 !.............................. ! INFINITE WATER DEPTH !
00119 !                               +----------------------+
00120         DO JF=1,NF
00121           AUX1=DPDSUG*(FREQ(JF))**2
00122           AUX3=0.5D0*GRAVIT/(DEUPI*FREQ(JF))
00123           DO IP=1,NPOIN2
00124             XK(IP,JF)=AUX1
00125             CG(IP,JF)=AUX3
00126           ENDDO ! IP
00127         ENDDO ! JF
00128       ELSE
00129 !                               +--------------------+
00130 !.............................. ! FINITE WATER DEPTH !
00131 !                               +--------------------+
00132         DO JF=1,NF
00133           AUX2=DEUPI*FREQ(JF)
00134           DO IP=1,NPOIN2
00135             CALL WNSCOU(AUX1,FREQ(JF),DEPTH(IP))
00136             DEUKD=2.D0*AUX1*DEPTH(IP)
00137             IF (DEUKD.GT.7.D2) THEN
00138               AUX3=0.5D0*AUX2/AUX1
00139             ELSE
00140               AUX3=0.5D0*(1.D0+DEUKD/SINH(DEUKD))*AUX2/AUX1
00141             ENDIF
00142             XK(IP,JF)=AUX1
00143             CG(IP,JF)=AUX3
00144           ENDDO ! IP
00145         ENDDO ! JF
00146       ENDIF
00147 !
00148 !
00149 !.....COMPUTES B TO GO FROM (KX, KY) TO (FR, TETA)
00150 !     ===================================================
00151       IF (.NOT.SPHE) THEN
00152 !                               +-----------------------------+
00153 !.............................. ! CARTESIAN COORDINATE SYSTEM !
00154 !                               +-----------------------------+
00155         DO JF=1,NF
00156           AUX1=DEUPI2*FREQ(JF)
00157           DO IP=1,NPOIN2
00158             B(IP,JF)= CG(IP,JF)/(AUX1*XK(IP,JF))
00159           ENDDO ! IP
00160         ENDDO ! JF
00161 !
00162       ELSE
00163 !                               +-----------------------------+
00164 !.............................. ! SPHERICAL COORDINATE SYSTEM !
00165 !                               +-----------------------------+
00166         DO JF=1,NF
00167           AUX1=DEUPI2*FREQ(JF)*R2
00168           DO IP=1,NPOIN2
00169             B(IP,JF)= CG(IP,JF)/(AUX1*XK(IP,JF)*COSPHI(IP))
00170           ENDDO ! IP
00171         ENDDO ! JF
00172       ENDIF
00173 !
00174       RETURN
00175       END

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