couple.f

Go to the documentation of this file.

!                       ***************
                        FUNCTION couple
!                       ***************
!
     &( xk1   , yk1   , xk2   , yk2   , xk3   , yk3   , xk4   , yk4   )
!
!***********************************************************************
! TOMAWAC   V6P1                                 14/06/2011
!***********************************************************************
!
!brief   FUNCTION CALLED BY PRENL3
!+         IT COMPUTES THE COUPLING COEFFICIENT FOR THE NON-LINEAR
!+         INTERACTION TERM.
!
!history  E. GAGNAIRE-RENOU
!+        04/2011
!+        V6P1
!+   CREATED
!
!history  G.MATTAROLO (EDF - LNHE)
!+        14/06/2011
!+        V6P1
!+   Translation of French names of the variables in argument
!
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!| XK1, YK1       |-->| COUPLING COEFFICIENT FOR QNL4 (GQM METHOD)
!| XK2, YK2       |-->| COUPLING COEFFICIENT FOR QNL4 (GQM METHOD)
!| XK3, YK3       |-->| COUPLING COEFFICIENT FOR QNL4 (GQM METHOD)
!| XK4, YK4       |-->| COUPLING COEFFICIENT FOR QNL4 (GQM METHOD)
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
      USE interface_tomawac, ex_couple => couple
      USE declarations_tomawac, ONLY : pi, gravit                   
      IMPLICIT NONE
!
!.....VARIABLES IN ARGUMENT
!     """""""""""""""""""""
      DOUBLE PRECISION, INTENT(IN)    :: XK1   , YK1   , XK2   , YK2
      DOUBLE PRECISION, INTENT(IN)    :: XK3   , YK3   , XK4   , YK4
      DOUBLE PRECISION COUPLE
!
!.....LOCAL VARIABLES
!     """"""""""""""""""
      DOUBLE PRECISION RK1   , RK2   , RK3   , RK4   , WK1   , WK2
      DOUBLE PRECISION WK3   , WK4   , S12   , S13   , S14   , S23
      DOUBLE PRECISION S24   , S34   , W1P2  , Q12   , W1M3  , Q13
      DOUBLE PRECISION W1M4  , Q14   , DDD   , COEF  , DENO13, NUME13
      DOUBLE PRECISION DENO14, NUME14, ZERO
!
      coef=pi*gravit*gravit/4.d0
      zero=1.d-10
!
      rk1=sqrt(xk1*xk1+yk1*yk1)
      rk2=sqrt(xk2*xk2+yk2*yk2)
      rk3=sqrt(xk3*xk3+yk3*yk3)
      rk4=sqrt(xk4*xk4+yk4*yk4)
!
      wk1=sqrt(rk1)
      wk2=sqrt(rk2)
      wk3=sqrt(rk3)
      wk4=sqrt(rk4)
!
      s12=xk1*xk2+yk1*yk2
      s13=xk1*xk3+yk1*yk3
      s14=xk1*xk4+yk1*yk4
      s23=xk2*xk3+yk2*yk3
      s24=xk2*xk4+yk2*yk4
      s34=xk3*xk4+yk3*yk4
!
      w1p2=sqrt((xk1+xk2)*(xk1+xk2)+(yk1+yk2)*(yk1+yk2))
      w1m3=sqrt((xk1-xk3)*(xk1-xk3)+(yk1-yk3)*(yk1-yk3))
      w1m4=sqrt((xk1-xk4)*(xk1-xk4)+(yk1-yk4)*(yk1-yk4))
      q12=(wk1+wk2)*(wk1+wk2)
      q13=(wk1-wk3)*(wk1-wk3)
      q14=(wk1-wk4)*(wk1-wk4)
!
!.....COMPUTES THE D COEFFICIENT OF WEBB (1978)
!     """"""""""""""""""""""""""""""""""""""
      ddd=2.00d0*q12*(rk1*rk2-s12)*(rk3*rk4-s34)/(w1p2-q12)
     &   +0.50d0*(s12*s34+s13*s24+s14*s23)
     &   +0.25d0*(s13+s24)*q13*q13
     &   -0.25d0*(s12+s34)*q12*q12
     &   +0.25d0*(s14+s23)*q14*q14
     &   +2.50d0*rk1*rk2*rk3*rk4
     &   +q12*q13*q14*(rk1+rk2+rk3+rk4)
      deno13=w1m3-q13
      nume13=2.00d0*q13*(rk1*rk3+s13)*(rk2*rk4+s24)
      IF (abs(deno13).LT.zero) THEN
        IF (abs(nume13).LT.zero) THEN
          WRITE(*,*) 'WARNING DANS COUPLE : (1-3) ON A : 0/0 !'
        ELSE
          WRITE(*,*) 'WARNING DANS COUPLE : (1-3) ON A : INFINI !'
        ENDIF
        WRITE(*,*) 'TERME (1-3) NON PRIS EN COMPTE DANS LE CALCUL.'
      ELSE
        ddd=ddd+nume13/deno13
      ENDIF
      deno14=w1m4-q14
      nume14=2.00d0*q14*(rk1*rk4+s14)*(rk2*rk3+s23)
      IF (abs(deno14).LT.zero) THEN
        IF (abs(nume14).LT.zero) THEN
          WRITE(*,*) 'WARNING DANS COUPLE : (1-4) ON A : 0/0 !'
        ELSE
          WRITE(*,*) 'WARNING DANS COUPLE : (1-4) ON A : INFINI !'
        ENDIF
        WRITE(*,*) 'TERME (1-4) NON PRIS EN COMPTE DANS LE CALCUL.'
      ELSE
        ddd=ddd+nume14/deno14
      ENDIF
!
!.....COMPUTES THE COUPLING COEFFICIENT FOR SPECTRAL DENSITIES EXPRESSED
!.....IN TERMS OF VARIANCE (NOT IN TERMS OF ENERGY)
!     """"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
      couple=coef*ddd*ddd/(wk1*wk2*wk3*wk4)
!
      RETURN
      END