fbott3d.f

Go to the documentation of this file.

!#######################################################################
                        SUBROUTINE fbott3d
     &  (fbx, fby, fs, npoin2, xk, ndire, nf)
!
!     WAVE DISSIPATION DUE TO BOTTOM FRICTION
!
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!| FBX            |<--| WAVE DISSIPATION ALONG X
!| FBY            |<--| WAVE DISSIPATION ALONG Y 
!| FS             |-->| VARIANCE DENSITY DIRECTIONAL SPECTRUM
!| NF             |-->| NUMBER OF FREQUENCIES
!| NDIRE          |-->| NUMBER OF DIRECTIONS
!| NPOIN2         |-->| NUMBER OF POINTS IN 2D MESH
!| XK             |-->| DISCRETIZED WAVE NUMBER
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

      USE bief
      USE declarations_tomawac, ONLY : deupi, cfrot1, gravit, costet,
     &  dfreq, freq, sintet, depth
      USE interface_tomawac, ex_fbott3d => fbott3d
    
      IMPLICIT NONE
      
!.....VARIABLES IN ARGUMENT
!     """"""""""""""""""""
      INTEGER, INTENT(IN)    :: NPOIN2, NDIRE,NF
      DOUBLE PRECISION, INTENT(IN)    :: FS(npoin2,ndire,nf)
      DOUBLE PRECISION, INTENT(IN)    :: XK(npoin2,nf)
      DOUBLE PRECISION, INTENT(INOUT)    :: FBX(npoin2)
      DOUBLE PRECISION, INTENT(INOUT)    :: FBY(npoin2)  

!     """""""""""""""""
!.....LOCAL VARIABLES
!     """""""""""""""""
      INTEGER  JP    , JF    , IP
      DOUBLE PRECISION SIGMA,BETAMJ
      DOUBLE PRECISION DTETAR, AUX1

      DOUBLE PRECISION COEF , DEUKD
!
      dtetar=deupi/dble(ndire)
      DO ip=1,npoin2
        fbx(ip) = 0.d0
        fby(ip) = 0.d0
      ENDDO
      coef=-2.d0*cfrot1/gravit
!
      DO jf=1,nf
        sigma=deupi*freq(jf)
        aux1=dfreq(jf)*dtetar        
        DO jp=1,ndire
          DO ip=1,npoin2
            deukd = min(2.d0*depth(ip)*xk(ip,jf),7.d2)
            betamj = coef*xk(ip,jf)/sinh(deukd)
            fbx(ip)=fbx(ip)+((xk(ip,jf)/sigma)*sintet(jp)
     &            *betamj*fs(ip,jp,jf))*aux1
            fby(ip)=fby(ip)+((xk(ip,jf)/sigma)*costet(jp)
     &            *betamj*fs(ip,jp,jf))*aux1
          ENDDO
        ENDDO
      ENDDO

      RETURN
      END