couple.f

Go to the documentation of this file.
00001 C:\opentelemac\v7p0\sources\tomawac\couple.f
00002 !
00039                         FUNCTION COUPLE
00040 !                       ***************
00041 !
00042      &( XK1   , YK1   , XK2   , YK2   , XK3   , YK3   , XK4   , YK4   ,
00043      &  GRAVIT, PI    )
00044 !
00045 !***********************************************************************
00046 ! TOMAWAC   V6P1                                 14/06/2011
00047 !***********************************************************************
00048 !
00049 !
00050 !
00051 !
00052 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
00053 !| AT             |-->| COMPUTATION TIME
00054 !| GRAVIT         |-->| GRAVITY ACCELERATION
00055 !| XK1, YK1       |-->| COUPLING COEFFICIENT FOR QNL4 (GQM METHOD)
00056 !| XK2, YK2       |-->| COUPLING COEFFICIENT FOR QNL4 (GQM METHOD)
00057 !| XK3, YK3       |-->| COUPLING COEFFICIENT FOR QNL4 (GQM METHOD)
00058 !| XK4, YK4       |-->| COUPLING COEFFICIENT FOR QNL4 (GQM METHOD)
00059 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
00060 !
00061       IMPLICIT NONE
00062 !
00063 !.....VARIABLES IN ARGUMENT
00064 !     """""""""""""""""""""
00065       DOUBLE PRECISION XK1   , YK1   , XK2   , YK2   , XK3   , YK3
00066       DOUBLE PRECISION XK4   , YK4   , GRAVIT, PI    , COUPLE
00067 !
00068 !.....LOCAL VARIABLES
00069 !     """"""""""""""""""
00070       DOUBLE PRECISION RK1   , RK2   , RK3   , RK4   , WK1   , WK2
00071       DOUBLE PRECISION WK3   , WK4   , S12   , S13   , S14   , S23
00072       DOUBLE PRECISION S24   , S34   , W1P2  , Q12   , W1M3  , Q13
00073       DOUBLE PRECISION W1M4  , Q14   , DDD   , COEF  , DENO13, NUME13
00074       DOUBLE PRECISION DENO14, NUME14, ZERO
00075 !
00076       COEF=PI*GRAVIT*GRAVIT/4.D0
00077       ZERO=1.D-10
00078 !
00079       RK1=SQRT(XK1*XK1+YK1*YK1)
00080       RK2=SQRT(XK2*XK2+YK2*YK2)
00081       RK3=SQRT(XK3*XK3+YK3*YK3)
00082       RK4=SQRT(XK4*XK4+YK4*YK4)
00083 !
00084       WK1=SQRT(RK1)
00085       WK2=SQRT(RK2)
00086       WK3=SQRT(RK3)
00087       WK4=SQRT(RK4)
00088 !
00089       S12=XK1*XK2+YK1*YK2
00090       S13=XK1*XK3+YK1*YK3
00091       S14=XK1*XK4+YK1*YK4
00092       S23=XK2*XK3+YK2*YK3
00093       S24=XK2*XK4+YK2*YK4
00094       S34=XK3*XK4+YK3*YK4
00095 !
00096       W1P2=SQRT((XK1+XK2)*(XK1+XK2)+(YK1+YK2)*(YK1+YK2))
00097       W1M3=SQRT((XK1-XK3)*(XK1-XK3)+(YK1-YK3)*(YK1-YK3))
00098       W1M4=SQRT((XK1-XK4)*(XK1-XK4)+(YK1-YK4)*(YK1-YK4))
00099       Q12=(WK1+WK2)*(WK1+WK2)
00100       Q13=(WK1-WK3)*(WK1-WK3)
00101       Q14=(WK1-WK4)*(WK1-WK4)
00102 !
00103 !.....COMPUTES THE D COEFFICIENT OF WEBB (1978)
00104 !     """"""""""""""""""""""""""""""""""""""
00105       DDD=2.00D0*Q12*(RK1*RK2-S12)*(RK3*RK4-S34)/(W1P2-Q12)
00106      &   +0.50D0*(S12*S34+S13*S24+S14*S23)
00107      &   +0.25D0*(S13+S24)*Q13*Q13
00108      &   -0.25D0*(S12+S34)*Q12*Q12
00109      &   +0.25D0*(S14+S23)*Q14*Q14
00110      &   +2.50D0*RK1*RK2*RK3*RK4
00111      &   +Q12*Q13*Q14*(RK1+RK2+RK3+RK4)
00112       DENO13=W1M3-Q13
00113       NUME13=2.00D0*Q13*(RK1*RK3+S13)*(RK2*RK4+S24)
00114       IF (ABS(DENO13).LT.ZERO) THEN
00115         IF (ABS(NUME13).LT.ZERO) THEN
00116           WRITE(*,*) 'WARNING DANS COUPLE : (1-3) ON A : 0/0 !'
00117         ELSE
00118           WRITE(*,*) 'WARNING DANS COUPLE : (1-3) ON A : INFINI !'
00119         ENDIF
00120         WRITE(*,*) 'TERME (1-3) NON PRIS EN COMPTE DANS LE CALCUL.'
00121       ELSE
00122         DDD=DDD+NUME13/DENO13
00123       ENDIF
00124       DENO14=W1M4-Q14
00125       NUME14=2.00D0*Q14*(RK1*RK4+S14)*(RK2*RK3+S23)
00126       IF (ABS(DENO14).LT.ZERO) THEN
00127         IF (ABS(NUME14).LT.ZERO) THEN
00128           WRITE(*,*) 'WARNING DANS COUPLE : (1-4) ON A : 0/0 !'
00129         ELSE
00130           WRITE(*,*) 'WARNING DANS COUPLE : (1-4) ON A : INFINI !'
00131         ENDIF
00132         WRITE(*,*) 'TERME (1-4) NON PRIS EN COMPTE DANS LE CALCUL.'
00133       ELSE
00134         DDD=DDD+NUME14/DENO14
00135       ENDIF
00136 !
00137 !.....COMPUTES THE COUPLING COEFFICIENT FOR SPECTRAL DENSITIES EXPRESSED
00138 !.....IN TERMS OF VARIANCE (NOT IN TERMS OF ENERGY)
00139 !     """"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
00140       COUPLE=COEF*DDD*DDD/(WK1*WK2*WK3*WK4)
00141 !
00142       RETURN
00143       END

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