qdscur.f

Go to the documentation of this file.

!                       *****************
                        SUBROUTINE qdscur
!                       *****************
!
     &( tstot , tsder , f     , cf    , xk    , usold , usnew ,
     &  nf    , ndire , npoin2, f_int , betoto, betotn)
!
!**********************************************************************
! TOMAWAC   V7P0                                 30/07/2014
!**********************************************************************
!
!brief   COMPUTES THE CONTRIBUTION OF THE WAVE BLOCKING SINK TERM USING
!+          THE  PARAMETRISATION OF VAN DER WESTHUYSEN (2012).
!
!reference    VAN DER WESTHUYSEN (2012):  SPECTRAL
!+              MODELLING OF WAVES DISSIPATION ON NEGATIVE
!+                   CURRENT GRADIENTS
!
!history  E. GAGNAIRE-RENOU (EDF/LNHE)
!+        09/2014
!+        V7P0
!+        NEW SUBROUTINE CREATED / IMPLEMENTED
!
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!| BETOTN         |<->| WORK TABLE
!| BETOTO         |<->| WORK TABLE
!| F_INT          |<->| WORK TABLE
!| CF             |-->| ADVECTION FIELD ALONG FREQUENCY
!| F              |-->| DIRECTIONAL SPECTRUM
!| XK             |-->| DISCRETIZED WAVE NUMBER
!| NF             |-->| NUMBER OF FREQUENCIES
!| NDIRE          |-->| NUMBER OF DIRECTIONS
!| NPOIN2         |-->| NUMBER OF POINTS IN 2D MESH
!| TSDER          |<->| DERIVED PART OF THE SOURCE TERM CONTRIBUTION
!| TSTOT          |-->| TOTAL PART OF THE SOURCE TERM CONTRIBUTION
!| USNEW          |-->| FRICTION VELOCITY AT TIME N+1
!| USOLD          |<->| FRICTION VELOCITY AT TIME N
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
!  REMARKS:
!  ********
!
!  - THE CONSTANT CDSCUR (C"dis,break) UTILISED IN WESTHUYSEN (2012)
!                                    IS EQUAL TO 0.65 BY DEFAULT
!    CDSCUR       COEFFICIENT OF DISSIPATION BY STRONG CURRENT
!  - THE CONSTANT CMOUT4 (Br) UTILISED IN WESTHUYSEN (2007)
!                                    IS EQUAL TO 1.75*10^(-3)
!
      USE declarations_tomawac, ONLY : deupi,gravit,cmout4, cdscur,
     &                       cimpli, freq, depth, proinf
! FROM TOMAWAC MODULE      
! CIMPLI         IMPLICITATION COEFFICIENT FOR SOURCE TERM INTEG.
!
      USE declarations_special
      USE interface_tomawac, ex_qdscur => qdscur
      IMPLICIT NONE
!
!
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!
      INTEGER, INTENT(IN)             :: NF,NDIRE,NPOIN2
      DOUBLE PRECISION, INTENT(IN)    :: USNEW(npoin2),USOLD(npoin2)
      DOUBLE PRECISION, INTENT(IN)    :: XK(npoin2,nf)
      DOUBLE PRECISION, INTENT(INOUT) :: F_INT(npoin2)
      DOUBLE PRECISION, INTENT(INOUT) :: BETOTO(npoin2,ndire)
      DOUBLE PRECISION, INTENT(INOUT) :: BETOTN(npoin2,ndire)
      DOUBLE PRECISION, INTENT(INOUT) :: TSTOT(npoin2,ndire,nf)
      DOUBLE PRECISION, INTENT(INOUT) :: TSDER(npoin2,ndire,nf)
      DOUBLE PRECISION, INTENT(INOUT) :: F(npoin2,ndire,nf)
      DOUBLE PRECISION, INTENT(IN)    :: CF(npoin2,ndire,nf)
!
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!
      INTEGER JP,IFF,IP
      DOUBLE PRECISION P0O,P0N,W,SURDEUPIFREQ,B,DTETAR
      DOUBLE PRECISION CPHAS,CG1,SQBSCMOUT4,DEUKD,KD,SURCMOUT4
      DOUBLE PRECISION AA,BB,CC
!
!-----------------------------------------------------------------------
!
      dtetar=1.d0/dble(ndire)
      w=25.d0
      surcmout4=1.d0/cmout4
!
!     LOOP ON THE DISCRETISED FREQUENCIES
!
      DO iff=1,nf
!
        surdeupifreq=1.d0/(deupi*freq(iff))
!
        DO ip=1,npoin2
          f_int(ip)=f(ip,1,iff)
        ENDDO
        DO jp=2,ndire
          DO ip=1,npoin2
            f_int(ip)=f_int(ip)+f(ip,jp,iff)
          ENDDO
        ENDDO
        DO ip=1,npoin2
          f_int(ip)=f_int(ip)*dtetar
        ENDDO
!
        IF(proinf) THEN
!
          DO ip=1,npoin2
!
            cphas=xk(ip,iff)*surdeupifreq
            p0o=3.d0+tanh(w*(usold(ip)*cphas-0.1d0))
            p0n=3.d0+tanh(w*(usnew(ip)*cphas-0.1d0))
            cg1=0.5d0*gravit*surdeupifreq
            b=cg1*f_int(ip)*xk(ip,iff)**3
            sqbscmout4=sqrt(b*surcmout4)
            aa=-cdscur*sqbscmout4**(p0o/2)
            bb=-cdscur*sqbscmout4**(p0n/2)
            DO jp=1,ndire
              cc=max(cf(ip,jp,iff)/freq(iff),0.d0)
              betoto(ip,jp)=aa*cc
              betotn(ip,jp)=bb*cc
            ENDDO
!
          ENDDO
!
        ELSE
!
          DO ip=1,npoin2
!
            cphas=xk(ip,iff)*surdeupifreq
            p0o=3.d0+tanh(w*(usold(ip)*cphas-0.1d0))
            p0n=3.d0+tanh(w*(usnew(ip)*cphas-0.1d0))
            kd=min(xk(ip,iff)*depth(ip),350.d0)
            deukd=kd+kd
            cg1=( 0.5d0+xk(ip,iff)*depth(ip)/sinh(deukd) )/cphas
            b=cg1*f_int(ip)*xk(ip,iff)**3
            sqbscmout4=sqrt(b*surcmout4)
            aa=-cdscur*sqbscmout4**(p0o/2)
            bb=-cdscur*sqbscmout4**(p0n/2)
            DO jp=1,ndire
              cc=max(cf(ip,jp,iff)/freq(iff),0.d0)
              betoto(ip,jp)=aa*cc
              betotn(ip,jp)=bb*cc
            ENDDO
!
          ENDDO
!
        ENDIF
!
!       TAKES THE SOURCE TERM INTO ACCOUNT
!
        DO jp=1,ndire
          DO ip=1,npoin2
            tstot(ip,jp,iff)=tstot(ip,jp,iff)
     &      +(betoto(ip,jp)+cimpli*(betotn(ip,jp)-betoto(ip,jp)))
     &      *f(ip,jp,iff)
            tsder(ip,jp,iff)=tsder(ip,jp,iff)+betotn(ip,jp)
          ENDDO
        ENDDO
!
      ENDDO
!
!-----------------------------------------------------------------------
!
      RETURN
      END