#include "w3macros.h"
!/ ------------------------------------------------------------------- /
MODULE W3CANOMD
!/
!/ +-----------------------------------+
!/ | |
!/ | P.A.E.M. Janssen |
!/ | FORTRAN 90 |
!/ | Last update : 21-Aug-2014 |
!/ +-----------------------------------+
!/
!/ XX-Jul-2010 : Origination by PAEM JANSSEN
!/ 18-Oct-2012 : Adapted to WAVEWATCH III: F. Ardhuin( version 4.07 )
!/ 21-Aug-2014 : Bug corrected: only first call wasOK( version 5.01 )
!/
! 0. Note by F. Ardhuin:
! In adapting the orginal program to be a WAVEWATCH module, I
! have so far strived to keep the original code. As a result
! some routines are unnecessarily duplicated (e.g. the calculation of
! the group velocity ...). But this can improve the traceability of
! the code.
! The first spectrum (JONSWAP) has been removed from the code
!
! 1. Purpose :
!
!
! CALCULATION OF THE SECOND ORDER CORRECTION TO THE SURFACE GRAVITY
! WAVE SPECTRUM
!
! DOCUMENTATION.
! -------------
!
! PRESENTLY, THE SOFTWARE IS SET UP TO DO FOR A GIVING FIRST-ORDER
! SPECTRUM AT A GIVEN DEPTH THE DETERMINATION OF THE SECOND ORDER
! CORRECTION (INCLUDING SECOND-HARMONICS, WAVE SET DOWN AND DOPPLER SHIFT
! OWING TO THE STOKES FREQUENCY CORRECTION.
!
! EVALUATION OF THE INTERACTION COEFFICIENTS FOR ARBRITRARY DEPTH WOULD
! BE VERY TIME CONSUMING. THEREFORE, THE APPROACH IN THE WAM MODEL IS
! FOLLOWED, WHERE TABLES ARE GENERATED FOR A LOGARITHMIC DEPTH TABLE
!
! D(JD) = DEPTHA*DEPTHD**(JD-1)
!
! WITH JD AN INTEGER. IN THE PRESENT OPERATIONAL VERSION OF ECWAM JD
! RANGES FROM 1 TO NDEPTH = 74, WHILE DEPTHA = 1. AND DEPTHD = 1.1
!
! FINALLY, THIS IS A VERY TIME-CONSUMING CALCULATION, AT LEAST FOR AN
! OPERATIONAL MODEL. i HAVE THEREFORE INTRODUCED THE OPTION THAT THE SECOND-ORDER
! SPECTRUM IS CALCULATED ON A LOWER RESOLUTION GRID (TYPICALLY HALF THE
! RESOLUTION) WHILE THE INFORMATION CONTAINED IN THE FIRST-ORDER SPECTRUM
! IS KEPT ON THE ORIGINAL SPECTRAL GRID.
!
! ----------------------------------------------------------------------
!
!
! 2. Variables and types :
!
! Name Type Scope Description
! ----------------------------------------------------------------
! ----------------------------------------------------------------
!
! 3. Subroutines and functions :
!
! Name Type Scope Description
! ----------------------------------------------------------------
! W3SREF Subr. Public Reflection of waves (shorline, islands...)
! ----------------------------------------------------------------
!
! 4. Subroutines and functions used :
!
! Name Type Module Description
! ----------------------------------------------------------------
! STRACE Subr. W3SERVMD Subroutine tracing.
! ----------------------------------------------------------------
!
! 5. Remarks :
!
!
! 6. Switches :
!
! !/S Enable subroutine tracing.
!
! 7. Source code :
!/
!/ ------------------------------------------------------------------- /
!/
!
!/
!/ Public variables
!/
REAL :: G, PI, ZPI, RAD, DEG
INTEGER :: NDEPTH
REAL :: DEPTHA ! first depth in table
REAL, SAVE , PRIVATE, ALLOCATABLE :: OMEGA(:)
#ifdef W3_OMPG
!$omp threadprivate( OMEGA )
#endif
INTEGER, SAVE , PRIVATE :: COUNTER = 0
#ifdef W3_OMPG
!$omp threadprivate( COUNTER )
#endif
! Tables for non-linear coefficients ...
REAL, SAVE , PRIVATE, ALLOCATABLE :: TA(:,:,:,:),TB(:,:,:,:),TC_QL(:,:,:,:),&
TT_4M(:,:,:,:),TT_4P(:,:,:,:),TFAKH(:,:), &
TFAK(:,:)
#ifdef W3_OMPG
!$omp threadprivate( TA, TB, TC_QL, TT_4M, TT_4P, TFAKH, TFAK )
#endif
INTEGER, SAVE, PRIVATE, ALLOCATABLE :: IM_P(:,:),IM_M(:,:)
#ifdef W3_OMPG
!$omp threadprivate( IM_P, IM_M )
#endif
!
!/
CONTAINS
!/ ------------------------------------------------------------------- /
SUBROUTINE W3ADD2NDORDER(E,DEPTH,WN,CG,IACTION)
!/
!/ +-----------------------------------+
!/ | WAVEWATCH III NOAA/NCEP |
!/ | F. Ardhuin |
!/ | FORTRAN 90 |
!/ | Last update : 19-Oct-2012 |
!/ +-----------------------------------+
!/
!/ 19-Oct-2012 : Origination ( version 4.08 )
!/
! 1. Purpose :
!
! Adds second order spectrum on top of first order spectrum
!
! 2. Method :
!
! Uses P. Janssen's code for the inverse canonical transform
!
!
! 3. Parameters :
!
! Parameter list
! ----------------------------------------------------------------
! A R.A. I Action density spectrum (1-D)
! CG R.A. I Group velocities.
! WN R.A. I Wavenumbers.
! DEPTH Real I Mean water depth.
! S R.A. O Source term (1-D version).
! D R.A. O Diagonal term of derivative (1-D version).
! ----------------------------------------------------------------
! ----------------------------------------------------------------
! E R.A. I/O Energy density spectrum (1-D), f-theta
! DEPTH Real I Water depth
! WN R.A. wavenumbers
! CG R.A. group velocities
! IACTION Int I Switch to specify if the input spectrum
! is E(f,theta) or A(k,theta)
! ----------------------------------------------------------------
!
! 4. Subroutines used :
!
! Name Type Module Description
! ----------------------------------------------------------------
! STRACE Subr. W3SERVMD Subroutine tracing.
! ----------------------------------------------------------------
!
! 5. Called by :
!
! Name Type Module Description
! ----------------------------------------------------------------
! W3SREF Subr. W3REF1MD Shoreline reflection source term
! W3EXPO Subr. N/A Point output post-processor.
! ----------------------------------------------------------------
!
! 6. Error messages :
!
! None.
!
! 7. Remarks :
!
! 8. Structure :
!
! See source code.
!
! 9. Switches :
!
! !/S Enable subroutine tracing.
!
! 10. Source code :
!
!/ ------------------------------------------------------------------- /
USE CONSTANTS, ONLY: GRAV
USE W3DISPMD
USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, TH, DTH, IGPARS
#ifdef W3_S
USE W3SERVMD, ONLY: STRACE
#endif
!/
!
IMPLICIT NONE
!/
!/ ------------------------------------------------------------------- /
!/ Parameter list
!/
REAL, INTENT(INOUT) :: E(NSPEC)
REAL, INTENT(IN) :: DEPTH
REAL, INTENT(IN) :: WN(NK)
REAL, INTENT(IN) :: CG(NK)
INTEGER, INTENT(IN) :: IACTION
!/
!/ ------------------------------------------------------------------- /
!/ Local parameters
!/
INTEGER :: ISPEC, IK, ITH, M
REAL :: CO1, ATOE, DPTH
#ifdef W3_S
INTEGER, SAVE :: IENT = 0
#endif
LOGICAL, SAVE :: FIRST = .TRUE.
#ifdef W3_OMPG
!$omp threadprivate( FIRST )
#endif
REAL, ALLOCATABLE, SAVE :: FR(:), DFIM(:)
REAL, ALLOCATABLE, SAVE :: F1(:,:), F3(:,:)
#ifdef W3_OMPG
!$omp threadprivate( FR, DFIM, F1, F3 )
#endif
INTEGER, SAVE :: NFRE, NANG
INTEGER, SAVE :: NFREH, NANGH
#ifdef W3_OMPG
!$omp threadprivate( NFRE, NANG, NFREH, NANGH )
#endif
!/
!/ ------------------------------------------------------------------- /
!/
#ifdef W3_S
CALL STRACE (IENT, 'W3ADD2NDORDER')
#endif
!
! 0. Initializations ------------------------------------------------ *
!
IF (FIRST) THEN
FIRST=.FALSE.
NFRE=NK
NANG=NTH
NFREH=NK
NANGH=NTH
G=GRAV
PI = 4.*ATAN(1.)
ZPI=2*PI
RAD = PI/180.
DEG = 180./PI
ALLOCATE(FR(NFRE), DFIM(NFRE))
FR(1:NFRE)=SIG(1:NK)/ZPI
! The following can be replaced using DSIP from WWATCH
CO1 = 0.5*DTH
DFIM(1)= CO1*(FR(2)-FR(1))
DO M=2,NFRE-1
DFIM(M)=CO1*(FR(M+1)-FR(M-1))
ENDDO
DFIM(NFRE)=CO1*(FR(NFRE)-FR(NFRE-1))
!
ALLOCATE(F1(NANG,NFRE), F3(NANG,NFRE))
NDEPTH=IGPARS(6)
DEPTHA=IGPARS(7)
END IF
DPTH = DEPTH
DO IK=1,NK
IF (IACTION.EQ.0) THEN
ATOE=1
ELSE
ATOE=SIG(IK)*ZPI / CG(IK)
END IF
DO ITH=1,NTH
ISPEC=ITH+(IK-1)*NTH
F1(ITH,IK)=E(ISPEC)*ATOE
END DO
!WRITE(100,'(100G16.8)') SIG(IK)*ZPI,(F1(ITH,IK),ITH=1,NTH)
END DO
!
! 1. DETERMINE SECOND-ORDER SPECTRUM.
!
CALL CAL_SEC_ORDER_SPEC(F1,F3,NFRE,NANG,FR,DFIM,TH, &
DTH,DPTH,+1., NFREH, NANGH)
!
! 2. Adds 2nd order spectrum to 1st order
!
DO IK=1,NK
IF (IACTION.EQ.0) THEN
ATOE=1
ELSE
ATOE=SIG(IK)*ZPI / CG(IK)
END IF
DO ITH=1,NTH
ISPEC=ITH+(IK-1)*NTH
E(ISPEC)=F3(ITH,IK)/ATOE
END DO
!WRITE(101,'(I3,100G16.8)') SIG(IK)*ZPI,(F3(ITH,IK),ITH=1,NTH)
END DO
#ifdef W3_T
PRINT*,' END CAL_SEC_ORDER_SPEC'
#endif
RETURN
END SUBROUTINE W3ADD2NDORDER
!/ ------------------------------------------------------------------- /
!-----------------------------------------------------------------------
!
SUBROUTINE CAL_SEC_ORDER_SPEC(F1,F3,NFRE,NANG,FR,DFIM,TH,DELTH, &
DPTH,SIGM, NFREH, NANGH)
!
!*** *CAL_SEC_ORDER_SPEC* DETERMINES SECOND_ORDER SPECTRUM
!
! PETER JANSSEN
!
! PURPOSE.
! --------
!
! DETERMINATION OF SECOND-ORDER SPECTRUM
!
! INTERFACE.
! ----------
! *CALL* *CAL_SEC_ORDER_SPEC(F1,F3,NFRE,NANG,FR,
! DFIM,TH,DELTH,DPTH,SIGM)*
!
! INPUT:
! *F1* - 2-D FREE WAVE SPECTRUM
! *NFRE* - NUMBER OF FREQUENCIES
! *NANG* - NUMBER OF DIRECTIONS
! *FR* - FREQUENCIES
! *DFIM* - FREQUENCY INCREMENT
! *TH* - DIRECTIONAL ARRAY
! *DELTH* - DIRECTIONAL INCREMENT
! *DPTH* - DEPTH ARRAY
! *SIGM* - FOR SIGM = 1 FORWARD MAPPING
! WHILE FOR SIGM = -1 INVERSE
! MAPPING.
!
! OUTPUT:
! *F3* - 2-D SPECTRUM INCLUDING SECOND-ORDER
! CORRECTION
!
! METHOD.
! -------
! IS DESCRIBED IN JANSSEN (2009), JFM, 637, 1-44.
!
! EXTERNALS.
! ----------
! NONE
!
!-----------------------------------------------------------------------
!
IMPLICIT NONE
REAL, INTENT(IN) :: F1(NANG,NFRE)
REAL, INTENT(OUT) :: F3(NANG,NFRE)
INTEGER, INTENT(IN) :: NFRE,NANG,NFREH, NANGH
REAL, INTENT(IN) :: DFIM(NFRE),FR(NFRE), TH(NANG), DELTH
REAL, INTENT(IN) :: DPTH, SIGM
LOGICAL FRSTIME,DOUBLEP
INTEGER MDW,M,K, K0,M0,MP,KP,MM,KM,KL,KLL,ML,JD
INTEGER, SAVE :: MR, MA,NMAX
#ifdef W3_OMPG
!$omp threadprivate( MR, MA, NMAX )
#endif
! PARAMETER (NFREH=32,NANGH=36)
INTEGER, SAVE :: INDEP
#ifdef W3_OMPG
!$omp threadprivate( INDEP )
#endif
REAL,ALLOCATABLE :: PF1(:,:),PF3(:,:)
REAL DEPTH,ALPHA,GAM_J,DEPTHD
REAL OM0,AA1,BB1,&
F,EPSMIN,DELFF,SPEC1,SQRTK
REAL FRAC,DEL,DELF,D1,D2,D3,D4,C1,&
C2,XM,XK
REAL, SAVE :: OMSTART
REAL, SAVE :: XMR,XMA, DELTHH, CO1
#ifdef W3_OMPG
!$omp threadprivate( OMSTART, XMR,XMA, DELTHH, CO1 )
#endif
REAL :: F13(NFREH,NANGH)
REAL :: SUM0,AKMEAN
REAL :: DELOM(NFREH),THH(NANGH),DFDTH(NFREH)
DATA FRSTIME/.TRUE./
COMMON/CONST/DEPTH,ALPHA,MDW,GAM_J,DEPTHD
COMMON/PRECIS/DOUBLEP
!
!*** 2. DETERMINE SECOND ORDER CORRECTION TO THE SPECTRUM
! ----------------------------------------------------
!
#ifdef W3_T
PRINT*,' START SECOND-ORDER CALC.'
#endif
DOUBLEP = .TRUE.
!
!*** 2.1 SET UP OF LOW-RESOLUTION CALCULATION GRID.
! ---------------------------------------------
!
EPSMIN = 1.0E-4
FRAC = 0.1
OMSTART = ZPI*FR(1)
MR = MAX(1,NFRE/NFREH)
XMR = 1./FLOAT(MR)
MA = NANG/NANGH
XMA = 1./FLOAT(MA)
DELTHH = FLOAT(MA)*DELTH
IF (FRSTIME) THEN
! IF (COUNTER.GT.0) THEN
! DEALLOCATE(OMEGA,TFAK,TA,TB,TC_QL,TT_4M,TT_4P,IM_P,IM_M,TFAKH)
! ENDIF
ALLOCATE(OMEGA(NFREH))
ALLOCATE(TFAK(NFRE,NDEPTH))
ALLOCATE(TA(NANGH,NFREH,NFREH,NDEPTH))
ALLOCATE(TB(NANGH,NFREH,NFREH,NDEPTH))
ALLOCATE(TC_QL(NANGH,NFREH,NFREH,NDEPTH))
ALLOCATE(TT_4M(NANGH,NFREH,NFREH,NDEPTH))
ALLOCATE(TT_4P(NANGH,NFREH,NFREH,NDEPTH))
ALLOCATE(IM_P(NFREH,NFREH))
ALLOCATE(IM_M(NFREH,NFREH))
ALLOCATE(TFAKH(NFREH,NDEPTH))
DO M=1,NFREH
OMEGA(M) = ZPI*FR(MR*M)
ENDDO
DO K=1,NANGH
K0 = MA*K+1
IF (K0.GT.NANG) K0 = K0-NANG
THH(K) = TH(K0)
ENDDO
CO1 = 1./2.*DELTHH
DELOM(1) = CO1*(OMEGA(2)-OMEGA(1))
DO M=2,NFREH-1
DELOM(M)=CO1*(OMEGA(M+1)-OMEGA(M-1))
ENDDO
DELOM(NFREH)=CO1*(OMEGA(NFREH)-OMEGA(NFREH-1))
!
DFDTH = DELOM/ZPI
!
!*** 2.2 INITIALISE TABLES
! ---------------------
!
NMAX = XMR*(1+NINT(LOG(2.*OMEGA(NFREH)/OMSTART)/LOG(1.+FRAC)))
NMAX = NMAX+1
#ifdef W3_T
PRINT*,' NMAX = ',NMAX
#endif
DEPTHD = 1.1
DO JD=1,NDEPTH
DEPTH = DEPTHA*DEPTHD**(JD-1)
DO M=1,NFRE
OM0 = ZPI*FR(M)
TFAK(M,JD) = AKI(OM0,DEPTH)
ENDDO
ENDDO
INDEP = 1+NINT(LOG(DPTH/DEPTHA)/LOG(DEPTHD))
INDEP = MIN(NDEPTH,INDEP)
INDEP = MAX(1,INDEP)
CALL TABLES_2ND(NFREH,NANGH,NDEPTH,DEPTHA,OMSTART,FRAC,XMR,&
DFDTH,OMEGA,THH)
PRINT*, '2ND ORDER TABLES GENERATED:',NDEPTH,DEPTHA, DELTHH
FRSTIME = .FALSE.
ENDIF ! end of test on FRSTIME
!
COUNTER=COUNTER+1
!
!*** DETERMINE SOME MOMENTS.
! ----------------------
!
SUM0 = 0.
AKMEAN = 0.
DO M=1,NFRE
DO K=1,NANG
SQRTK=SQRT(TFAK(M,INDEP))
SUM0 = SUM0+F1(K,M)*DFIM(M)
AKMEAN = AKMEAN+F1(K,M)*DFIM(M)/SQRTK
ENDDO
ENDDO
!
! NB: AKMEAN is the mean wavenumber corresponding to Tm0,-1 in deep water
!
AKMEAN = (SUM0/AKMEAN)**2
!
!*** 2.2 INTERPOLATION OR NOT.
! ------------------------
!
IF (MR.EQ.1 .AND. MA.EQ.1) THEN
!
!*** 2.21 NO INTERPOLATION.
! ----------------------
!
#ifdef W3_T
PRINT*,' NO THINNING AND INTERPOLATION'
PRINT*,'nanG:',NANG,NMAX,NFRE,NDEPTH,DEPTHA,DEPTHD,DPTH,'##',DELTH,DELTHH
#endif
CALL SECSPOM(F1,F3,NFRE,NANG,NMAX,NDEPTH,&
DEPTHA,DEPTHD,OMSTART,FRAC,MR,DFDTH,OMEGA,&
DPTH,AKMEAN,TA,TB,TC_QL,TT_4M,TT_4P,&
IM_P,IM_M,COUNTER)
DO M=1,NFRE
DO K=1,NANG
DELF = F3(K,M)
F3(K,M)=MAX(0.00000001,F1(K,M)+SIGM*DELF)
ENDDO
ENDDO
ELSE
!
!*** 2.22 ENERGY CONSERVING INTERPOLATION SCHEME
! -------------------------------------------
!
PRINT*,' !THINNING AND INTERPOLATION!'
ALLOCATE(PF1(NANGH,NFREH))
ALLOCATE(PF3(NANGH,NFREH))
PF1 = 0.
DO M=1,NFREH
DO K=1,NANGH
M0 = MR*M
MP = M0+1
MP = MIN(NFRE,MP)
MM = M0-1
K0 = MA*K+1
KP = K0+1
KM = K0-1
DELFF = 0.
DO KL = KM,KP
KLL = KL
IF (KLL.GT.NANG) KLL = KLL-NANG
IF (KLL.LT.1) KLL = KLL+NANG
DO ML = MM,MP
DEL = DFIM(ML)
DELFF = DELFF+DEL
SPEC1 = F1(KLL,ML)
PF1(K,M)=PF1(K,M)+SPEC1*DEL
ENDDO
ENDDO
PF1(K,M) =PF1(K,M)/DELFF
ENDDO
ENDDO
!
!*** 2.23 DETERMINE SECOND-ORDER SPEC
! --------------------------------
!
CALL SECSPOM(PF1,PF3,NFREH,NANGH,NMAX,NDEPTH,&
DEPTHA,DEPTHD,OMSTART,FRAC,MR,DFDTH,OMEGA,&
DPTH,AKMEAN,TA,TB,TC_QL,TT_4M,TT_4P,&
IM_P,IM_M,COUNTER)
!
!*** 2.24 INTERPOLATE TOWARDS HIGH-RES GRID
! --------------------------------------
!
DO M=1,NFRE
DO K=1,NANG
XM = REAL(M/MR)
XK = REAL((K-1)/MA)
M0 = MAX(1,INT(XM))
K0 = INT(XK)
D1 = REAL(M)/REAL(MR)-XM
D2 = 1.-D1
D3 = REAL(K-1)/REAL(MA)-XK
D4 = 1.-D3
IF (K0.LT.1) K0 = K0+NANGH
MP = MIN(NFREH,M0+1)
KP = K0+1
IF (KP.GT.NANGH) KP = KP-NANGH
C1 = PF3(K0,M0)*D4+PF3(KP,M0)*D3
C2 = PF3(KP,MP)*D3+PF3(K0,MP)*D4
DELF = C1*D2+C2*D1
F3(K,M)=MAX(0.00000001,F1(K,M)+SIGM*DELF)
ENDDO
ENDDO
ENDIF
IF (MR.GT.1 .OR. MA.GT.1 ) THEN
DO M=1,NFREH
AA1 = 0.
DO K=1,NANGH
AA1 = AA1+PF1(K,M)*DELTHH
ENDDO
AA1 = MAX(AA1,EPSMIN)
BB1 = 0.
DO K=1,NANGH
BB1 = BB1+(PF1(K,M)+PF3(K,M))*DELTHH
ENDDO
BB1 = MAX(BB1,EPSMIN)
F = OMEGA(M)/ZPI
#ifdef W3_T
WRITE(6,62) M,F,AA1,BB1,DELTHH
WRITE(80,62) M,F,AA1,BB1,DELTHH
#endif
ENDDO
DO M=1,NFREH
DO K=1,NANGH
F13(M,K)=PF1(K,M)+PF3(K,M)
ENDDO
ENDDO
ENDIF
!
#ifdef W3_T
62 FORMAT(I4,9F16.9)
#endif
!
RETURN
END SUBROUTINE CAL_SEC_ORDER_SPEC
!
!--------------------------------------------------------------------
!
SUBROUTINE TABLES_2ND(NFRE,NANG,NDEPTH,DEPTHA,OMSTART,FRAC,XMR,&
DFDTH,OMEGA,TH)
!
!--------------------------------------------------------------------
!
!*****TABLES** COMPUTES TABLES FOR SECOND ORDER SPECTRUM IN FREQUENCY SPACE.
!
! P.JANSSEN DECEMBER 2008
!
! PURPOSE
! -------
! DETERMINES TABLES, BASED ON JANSSEN (2008)
! THERE ARE THREE CORRECTIONS:
! 1) GENERATION OF SECOND-HARMONICS
! 2) QUASI-LINEAR EFFECT
! 3) SHIFT OF SPECTRUM BECAUSE OF STOKES FREQUENCY
! CORRECTION.
!
! INTERFACE
! ---------
! *CALL* *TABLES(NFRE,NANG,NDEPTH,OMSTART,FRAC,XMR,
! OMEGA,TA,TB,TC_QL,TT_4M,TT_4P,IM_P,IM_M,
! TFAK)*
!
!
! PARAMETER TYPE PURPOSE.
! --------- ---- -------
!
! NFRE INTEGER NUMBER OF FREQUENCIES
! NANG INTEGER NUMBER OF DIRECTIONS
! NDEPTH INTEGER NUMBER OF ENTRIES IN THE DEPTH TABLE
! OMSTART REAL START FREQUENCY
! FRAC REAL FRACTIONAL INCREASE IN FREQUENCY SPACE
! XMR REAL INVERSE OF THINNING FACTOR IN FREQUENCY SPACE
! OMEGA REAL ANGULAR FREQUENCY ARRAY
! DFDTH REAL PRODUCT OF INCREMENT IN FREQUENCY AND DIRECTION
! TH REAL DIRECTION ARRAY
! TA REAL TABLE FOR MINUS INTERACTIONS
! TB REAL TABLE FOR PLUS INTERACTIONS
! TC_QL REAL TABLE FOR QUASI-LINEAR INTERACTIONS
! TT_4M REAL TABLE FOR STOKES FREQUENCY CORRECTION
! TT_4P REAL TABLE FOR STOKES FREQUENCY CORRECTION
! IM_P INTEGER TABLE FOR WAVENUMBER M2 PLUS
! IM_M INTEGER TABLE FOR WAVENUMBER M2 MIN
! TFAK REAL WAVENUMBER TABLE
!
!
! METHOD
! ------
!
! EXTERNALS
! ---------
! NONE
!
! REFERENCES
! ----------
! V.E. ZAKHAROV, HAMILTONIAN APPROACH (1968)
! M.A. SROKOSZ, J.G.R.,91,995-1006 (1986)
! P.A.E.M. JANSSEN, ECMWF TECH MEMO (2008),JFM PAPER (2009)
!
!
!--------------------------------------------------------------------
!
!
!
IMPLICIT NONE
INTEGER NFRE,NANG,NDEPTH,MDW,JD,M,K,M1,K1,MP,MM,L
REAL DEPTH,ALPHA,GAM_J,DEPTHA,DEPTHD
REAL OM0,TH0,XK0,OM1,TH1,XK1,OM2,XK2,OM0P,XK0P,OM0M,XK0M,OMSTART,&
FRAC,XMR,XM2,FAC
REAL OMEGA(NFRE),TH(NANG),DFDTH(NFRE)
COMMON/CONST/DEPTH,ALPHA,MDW,GAM_J,DEPTHD
!
! 1. COMPUTATION OF WAVENUMBER ARRAY TFAK
! ---------------------------------------
!
!
DO JD=1,NDEPTH
DEPTH = DEPTHA*DEPTHD**(JD-1)
DO M=1,NFRE
OM0 = OMEGA(M)
TFAK(M,JD) = AKI(OM0,DEPTH)
ENDDO
WRITE(6,*) 'GENERATING TABLES FOR DEPTH:',JD,DEPTH,DEPTHA,NDEPTH
!
! 2. COMPUTATION OF THE 2nd ORDER COEFFICIENTS.
! ---------------------------------------------
!
!
K1 = 0
TH1 = TH(NANG)
DO M=1,NFRE
OM0 = OMEGA(M)
XK0 = TFAK(M,JD)
MP = MIN(M+1,NFRE)
OM0P = OMEGA(MP)
XK0P = TFAK(MP,JD)
MM = MAX(M-1,1)
OM0M = OMEGA(MM)
XK0M = TFAK(MM,JD)
DO M1=1,NFRE
OM1 = OMEGA(M1)
DO L=1,NANG
!
! XK0-XK1 CASE
!
K = K1+L
TH0 = TH(K)
OM2 = OM0-OM1
IF (ABS(OM1).LT.OM0/2.) THEN
XM2 = LOG(OM2/OMSTART)/LOG(1.+FRAC)
IM_M(M1,M) = NINT(XMR*(XM2+1.))
XK1 = TFAK(M1,JD)
XK2 = AKI(OM2,DEPTH)
TA(L,M1,M,JD) = DFDTH(M1)*A(XK1,XK2,TH1,TH0)**2
ELSE
TA(L,M1,M,JD) = 0.
IM_M(M1,M) = 1
ENDIF
!
! XK1+XK0 CASE
!
OM2 = OM1+OM0
XM2 = LOG(OM2/OMSTART)/LOG(1.+FRAC)
IM_P(M1,M) = NINT(XMR*(XM2+1.))
XK1 = TFAK(M1,JD)
XK2 = AKI(OM2,DEPTH)
TB(L,M1,M,JD) = DFDTH(M1)*B(XK1,XK2,TH1,TH0)**2
!
! QUASI-LINEAR EFFECT
!
!
TC_QL(L,M1,M,JD) = DFDTH(M1)*C_QL(XK0,XK1,TH0,TH1)
!
! STOKES-FREQUENCY CORRECTION
!
!
FAC = 2.*G/OM1*DFDTH(M1)
TT_4M(L,M1,M,JD) = &
FAC*(W2(XK0M,XK1,XK1,XK0M,TH0,TH1,TH1,TH0)+&
V2(XK0M,XK1,XK1,XK0M,TH0,TH1,TH1,TH0))
TT_4P(L,M1,M,JD) = &
FAC*(W2(XK0P,XK1,XK1,XK0P,TH0,TH1,TH1,TH0)+&
V2(XK0P,XK1,XK1,XK0P,TH0,TH1,TH1,TH0))
! Table identical to Janssen: verified.
! IF (JD.EQ.1) WRITE(998,'(F4.1,3I3,5G11.3)') DEPTH,M,M1,L, TB(L,M1,M,JD), &
! TC_QL(L,M1,M,JD) , FAC, TT_4M(L,M1,M,JD), TT_4P(L,M1,M,JD)
ENDDO
ENDDO
ENDDO
ENDDO
!
!
!--------------------------------------------------------------------
!
RETURN
END SUBROUTINE TABLES_2ND
!
!--------------------------------------------------------------------
!
SUBROUTINE SECSPOM(F1,F3,NFRE,NANG,NMAX,NDEPTH,&
DEPTHA,DEPTHD,OMSTART,FRAC,MR,DFDTH,OMEGA,&
DEPTH,AKMEAN,TA,TB,TC_QL,TT_4M,TT_4P,&
IM_P,IM_M,COUNTER)
!
!--------------------------------------------------------------------
!
!*****SECSPOM** COMPUTES SECOND ORDER SPECTRUM IN FREQUENCY SPACE.
!
! P.JANSSEN JULY 2008
!
! PURPOSE
! -------
! DETERMINES SECOND-ORDER SPECTRUM, BASED ON JANSSEN (2008)
! THERE ARE THREE CORRECTIONS:
! 1) GENERATION OF SECOND-HARMONICS
! 2) QUASI-LINEAR EFFECT
! 3) SHIFT OF SPECTRUM BECAUSE OF STOKES FREQUENCY
! CORRECTION.
!
! INTERFACE
! ---------
! *CALL* *SECSPOM(F1,F3,NFRE,NANG,NMAX,NDEPTH,
! DEPTHA,DEPTHD,OMSTART,FRAC,MR,DFDTH,OMEGA,
! DEPTH,AKMEAN,TA,TB,TC_QL,TT_4M,TT_4P,
! IM_P,IM_M)*
!
!
! PARAMETER TYPE PURPOSE.
! --------- ---- -------
!
! F1 REAL 2D FREE WAVE SPECTRUM (INPUT)
! F3 REAL BOUND WAVES SPECTRUM (OUTPUT)
! NFRE INTEGER NUMBER OF FREQUENCIES
! NANG INTEGER NUMBER OF DIRECTIONS
! NMAX INTEGER MAXIMUM INDEX CORRESPONDS TO TWICE THE CUT-OFF
! FREQUENCY
! NDEPTH INTEGER NUMBER OF ENTRIES IN DEPTH TABLE
! DEPTHA REAL START VALUE DEPTH ARRAY
! DEPTHD REAL INCREMENT DEPTH ARRAY
! OMSTART REAL START VALUE ANG. FREQUENCY ARRAY
! FRAC REAL FRACTIONAL INCREASE IN FREQUENCY SPACE
! MR INTEGER THINNING FACTOR IN FREQUENCY SPACE
! OMEGA REAL ANGULAR FREQUENCY ARRAY
! DEPTH REAL DEPTH ARRAY
! AKMEAN REAL MEAN WAVENUMBER ARRAY
! TA REAL TABLE FOR MINUS INTERACTIONS
! TB REAL TABLE FOR PLUS INTERACTIONS
! TC_QL REAL TABLE FOR QUASI-LINEAR INTERACTIONS
! TT_4M REAL TABLE FOR STOKES FREQUENCY CORRECTION
! TT_4P REAL TABLE FOR STOKES FREQUENCY CORRECTION
! IM_P INTEGER TABLE FOR WAVENUMBER M2 PLUS
! IM_M INTEGER TABLE FOR WAVENUMBER M2 MIN
!
!
!
! METHOD
! ------
! EVALUATE SECOND ORDER SPECTRUM IN FREQUENCY BASED ON
! KRASITSKII'S CANONICAL TRANSFORMATION.
!
! EXTERNALS
! ---------
! NONE
!
! REFERENCES
! ----------
! V.E. ZAKHAROV, HAMILTONIAN APPROACH (1968)
! M.A. SROKOSZ, J.G.R.,91,995-1006 (1986)
! P.A.E.M. JANSSEN, JFM (2009)
!
!
!--------------------------------------------------------------------
!
!
!
USE W3GDATMD, ONLY: IGPARS
IMPLICIT NONE
INTEGER NFRE,NANG,NDEPTH,M,K,M1,K1,M2_M,M2_P,K2,MP,&
MM,L,MR,NMAX,JD,COUNTER
INTEGER IM_P(NFRE,NFRE),IM_M(NFRE,NFRE),IL(NANG,NANG)
REAL OM0,OM0H,OM1,OM0P,OM0M,&
OMSTART,FRAC,XINCR1,XINCR2,XINCR3,XINCR4,FAC1,FAC2,&
FAC3,T_4M,T_4P,F2K,F2KP,F2KM,F2K1,F2K2,DELM1,DEPTHA,DEPTHD,&
XD,X_MIN
REAL OMEGA(NFRE), DFDTH(NFRE), OMEGAHF(NFRE+1:NMAX)
REAL TA(NANG,NFRE,NFRE,NDEPTH),TB(NANG,NFRE,NFRE,NDEPTH),&
TC_QL(NANG,NFRE,NFRE,NDEPTH),TT_4M(NANG,NFRE,NFRE,NDEPTH),&
TT_4P(NANG,NFRE,NFRE,NDEPTH)
REAL F1(NANG,NFRE),F3(NANG,NFRE),DEPTH
REAL AKMEAN
REAL G1(NANG,NMAX),G3(NANG,NFRE)
LOGICAL :: LL2H
!
!*** 1. COMPUTATION OF TAIL OF THE SPECTRUM AND INDEX JD
! ---------------------------------------------------
!
!
X_MIN = IGPARS(9) ! this was 1.1 in Janssen's original code
DO M=NFRE+1,NMAX
OMEGAHF(M) = OMSTART*(1.+FRAC)**(MR*M-1)
ENDDO
DO K=1,NANG
DO K1=1,NANG
L = K-K1
IF (L.GT.NANG) L=L-NANG
IF (L.LT.1) L=L+NANG
IL(K,K1) = L
ENDDO
ENDDO
! This was Janssen's version ... limited to kD > X_MIN ... (here set to 1.1)
XD = MAX(X_MIN/AKMEAN,DEPTH) ! note by FA: why do we have X_MIN/AKMEAN??!
XD = DEPTH
XD = LOG(XD/DEPTHA)/LOG(DEPTHD)+1.
JD = NINT(XD)
JD = MAX(JD,1)
JD = MIN(JD,NDEPTH)
DO M=1,NFRE
DO K=1,NANG
G1(K,M) = F1(K,M)
G3(K,M) = 0.
ENDDO
ENDDO
DO M=NFRE+1,NMAX
DO K=1,NANG
G1(K,M) = OMEGA(NFRE)**5*G1(K,NFRE)/OMEGAHF(M)**5
ENDDO
ENDDO
!
!
!
!
!*** 2. COMPUTATION OF THE 2nd ORDER FREQUENCY SPECTRUM.
! ---------------------------------------------------
!
!
DO M=1,NFRE
OM0 = OMEGA(M)
OM0H = OM0/2.
MP = MIN(M+1,NFRE)
OM0P = OMEGA(MP)
MM = MAX(M-1,1)
OM0M = OMEGA(MM)
DELM1 = 1./(OM0P-OM0M)
DO K=1,NANG
K2 = K
F2K = G1(K,M)
F2KP = G1(K,MP)
F2KM = G1(K,MM)
DO M1=1,NFRE
OM1 = OMEGA(M1)
LL2H = (ABS(OM1).LT.OM0H)
M2_M = IM_M(M1,M)
M2_P = IM_P(M1,M)
DO K1=1,NANG
F2K1 = G1(K1,M1)
L = IL(K,K1)
!
! 2.1 OM0-OM1 CASE: SECOND HARMONICS
! OM2 = OM0-OM1
!
IF (LL2H) THEN
F2K2 = G1(K2,M2_M)
FAC1 = TA(L,M1,M,JD)
FAC2 = F2K1*F2K2+G1(K2,M1)*G1(K1,M2_M)
XINCR1 = FAC1*FAC2
G3(K,M) = G3(K,M)+XINCR1
ENDIF
!
! 2.2 OM1+OM0 CASE: INFRA-GRAVITY WAVES
! OM2 = OM1+OM0
!
F2K2 = G1(K2,M2_P)
FAC3 = 2.*TB(L,M1,M,JD)
XINCR2 = FAC3*F2K2
!
! 2.3 QUASI-LINEAR EFFECT
!
XINCR3 = TC_QL(L,M1,M,JD)*F2K
!
! 2.4 STOKES-FREQUENCY CORRECTION
!
T_4M = TT_4M(L,M1,M,JD)
T_4P = TT_4P(L,M1,M,JD)
XINCR4 = -(F2KP*T_4P-F2KM*T_4M)*DELM1
G3(K,M) = G3(K,M)+F2K1*(XINCR2+XINCR3+XINCR4)
ENDDO
ENDDO
ENDDO
ENDDO
!
DO M=1,NFRE
DO K=1,NANG
F3(K,M) = G3(K,M)
ENDDO
ENDDO
!
!--------------------------------------------------------------------
!
RETURN
END SUBROUTINE SECSPOM
!
!
!-----------------------------------------------------------------------
!
!*** *REAL FUNCTION* *A(XI,XJ,THI,THJ)
!
!-----------------------------------------------------------------------
REAL FUNCTION A(XI,XJ,THI,THJ)
!
!*** *A* DETERMINES THE MINUS INTERACTIONS.
!
! PETER JANSSEN
!
! PURPOSE.
! --------
!
! GIVES NONLINEAR TRANSFER COEFFICIENT FOR THREE
! WAVE INTERACTIONS OF GRAVITY WAVES IN THE
! IDEAL CASE OF NO CURRENT. (CF.ZAKHAROV)
!
! INTERFACE.
! ----------
! *A(XI,XJ)*
! *XI* - WAVE NUMBER
! *XJ* - WAVE NUMBER
! METHOD.
! -------
! NONE
!
! EXTERNALS.
! ----------
! NONE.
!
!-----------------------------------------------------------------------
!
IMPLICIT NONE
COMMON/CONST/DEPTH,ALPHA,MDW,GAM_J,DEPTHD
INTEGER MDW
REAL DEPTH,ALPHA,GAM_J,DEPTHA,DEPTHD
REAL RI,RJ,RK,XI,XJ,THI,THJ,THK,OI,OJ,OK,FI,FJ,FK
!
!*** 1. DETERMINE NONLINEAR TRANSFER.
! --------------------------------
!
RI = XI
RJ = XJ
RK = VABS(RI,RJ,THI,THJ)
THK = VDIR(RI,RJ,THI,THJ)
OI=OMEG(RI)
OJ=OMEG(RJ)
OK=OMEG(RK)
FI = SQRT(OI/(2.*G))
FJ = SQRT(OJ/(2.*G))
FK = SQRT(OK/(2.*G))
A = FK/(FI*FJ)*(A1(RK,RI,RJ,THK,THI,THJ)+&
A3(RK,RI,RJ,THK-PI,THI,THJ))
RETURN
END FUNCTION A
!
!*** *REAL FUNCTION* *B(XI,XJ,THI,THJ)
!
!-----------------------------------------------------------------------
REAL FUNCTION B(XI,XJ,THI,THJ)
!
!*** *B* DETERMINES THE PLUS INTERACTION COEFFICIENTS.
!
! PETER JANSSEN
!
! PURPOSE.
! --------
!
! GIVES NONLINEAR TRANSFER COEFFICIENT FOR THREE
! WAVE INTERACTIONS OF GRAVITY WAVES IN THE
! IDEAL CASE OF NO CURRENT. (CF.ZAKHAROV)
!
! INTERFACE.
! ----------
! *B(XI,XJ)*
! *XI* - WAVE NUMBER
! *XJ* - WAVE NUMBER
! METHOD.
! -------
! NONE
!
! EXTERNALS.
! ----------
! NONE.
!
!-----------------------------------------------------------------------
!
IMPLICIT NONE
COMMON/CONST/DEPTH,ALPHA,MDW,GAM_J,DEPTHD
INTEGER MDW
REAL DEPTH,ALPHA,GAM_J,DEPTHA,DEPTHD
REAL DEL,RI,RJ,RK,XI,XJ,THI,THJ,THK,OI,OJ,OK,FI,FJ,FK
!
!*** 1. DETERMINE NONLINEAR TRANSFER.
! --------------------------------
!
DEL = 0.
RI = XI
RJ = XJ
RK = VABS(RJ,RI,THJ,THI-PI)
THK = VDIR(RJ,RI,THJ,THI-PI)
OI=OMEG(RI)+DEL
OJ=OMEG(RJ)+DEL
OK=OMEG(RK)+DEL
FI = SQRT(OI/(2.*G))
FJ = SQRT(OJ/(2.*G))
FK = SQRT(OK/(2.*G))
B = 0.5*FK/(FI*FJ)*(A2(RK,RI,RJ,THK,THI,THJ)+&
A2(RK,RJ,RI,THK-PI,THJ,THI))
RETURN
END FUNCTION B
!
!-----------------------------------------------------------------------
!
!*** *REAL FUNCTION* *C_QL(XK0,XK1,TH0,TH1)
!
!-----------------------------------------------------------------------
REAL FUNCTION C_QL(XK0,XK1,TH0,TH1)
!
!*** *A* DETERMINES THE QUASI-LINEAR TERM.
!
! PETER JANSSEN
!
! PURPOSE.
! --------
!
! DETERMINE CONTRIBUTION BY QUASI-LINEAR TERMS
!
! INTERFACE.
! ----------
! *C_QL(XK0,XK1)*
! *XK0* - WAVE NUMBER
! *XK1* - WAVE NUMBER
! METHOD.
! -------
! NONE
!
! EXTERNALS.
! ----------
! NONE.
!
!-----------------------------------------------------------------------
!
IMPLICIT NONE
COMMON/CONST/DEPTH,ALPHA,MDW,GAM_J,DEPTHD
INTEGER MDW
REAL DEPTH,ALPHA,GAM_J,DEPTHA,DEPTHD
REAL XK0,XK1,TH0,TH1,OM1,F1
!
!*** 1. DETERMINE NONLINEAR TRANSFER.
! --------------------------------
!
OM1 = OMEG(XK1)
F1 = SQRT(OM1/(2.*G))
C_QL = 2./F1**2*(B2(XK0,XK1,XK1,XK0,TH0,TH1,TH1,TH0)+&
B3(XK0,XK0,XK1,XK1,TH0-PI,TH0,TH1,TH1))
RETURN
END FUNCTION C_QL
!
!
!-----------------------------------------------------------------------
!
!*** *REAL FUNCTION* *VPLUS(XI,XJ,XK,THI,THJ,THK)
!
!-----------------------------------------------------------------------
REAL FUNCTION VPLUS(XI,XJ,XK,THI,THJ,THK)
!
!*** *VPLUS* DETERMINES THE SECOND-ORDER TRANSFER COEFFICIENT
! FOR THREE WAVE INTERACTIONS OF GRAVITY WAVES.
!
! PETER JANSSEN
!
! PURPOSE.
! --------
!
! GIVES NONLINEAR TRANSFER COEFFICIENT FOR THREE
! WAVE INTERACTIONS OF GRAVITY WAVES IN THE
! IDEAL CASE OF NO CURRENT. (CF.ZAKHAROV)
!
! INTERFACE.
! ----------
! *VPLUS(XI,XJ,XK)*
! *XI* - WAVE NUMBER
! *XJ* - WAVE NUMBER
! *XK* - WAVE NUMBER
! *THI* - WAVE DIRECTION
! *THJ* - WAVE DIRECTION
! *THK* - WAVE DIRECTION
! METHOD.
! -------
! NONE
!
! EXTERNALS.
! ----------
! NONE.
!
!-----------------------------------------------------------------------
!
IMPLICIT NONE
COMMON/CONST/DEPTH,ALPHA,MDW,GAM_J,DEPTHD
INTEGER MDW
REAL DEPTH,ALPHA,GAM_J,DEPTHA,DEPTHD
REAL DEL1,RI,RJ,RK,XI,XJ,XK,THI,THJ,THK,OI,OJ,OK,QI,QJ,QK,&
RIJ,RIK,RJK,SQIJK,SQIKJ,SQJKI,ZCONST
!
!*** 1. DETERMINE NONLINEAR TRANSFER.
! --------------------------------
!
DEL1 = 10.**(-12)
ZCONST=1./(4*SQRT(2.))
RI = XI
RJ = XJ
RK = XK
OI=OMEG(RI)+DEL1
OJ=OMEG(RJ)+DEL1
OK=OMEG(RK)+DEL1
QI=OI**2/G
QJ=OJ**2/G
QK=OK**2/G
RIJ = RI*RJ*COS(THJ-THI)
RIK = RI*RK*COS(THK-THI)
RJK = RJ*RK*COS(THK-THJ)
SQIJK=SQRT(G*OK/(OI*OJ))
SQIKJ=SQRT(G*OJ/(OI*OK))
SQJKI=SQRT(G*OI/(OJ*OK))
VPLUS=ZCONST*( (RIJ+QI*QJ)*SQIJK + (RIK+QI*QK)*SQIKJ&
+ (RJK+QJ*QK)*SQJKI )
RETURN
END FUNCTION VPLUS
!
!-----------------------------------------------------------------------
!
!*** *REAL FUNCTION* *VMIN(XI,XJ,XK,THI,THJ,THK)
!
!-----------------------------------------------------------------------
REAL FUNCTION VMIN(XI,XJ,XK,THI,THJ,THK)
!
!*** *VMIN* DETERMINES THE SECOND-ORDER TRANSFER COEFFICIENT FOR
! THREE WAVE INTERACTIONS OF GRAVITY WAVES.
!
! PETER JANSSEN
!
! PURPOSE.
! --------
!
! GIVES NONLINEAR TRANSFER COEFFICIENT FOR THREE
! WAVE INTERACTIONS OF GRAVITY WAVES IN THE
! IDEAL CASE OF NO CURRENT. (CF.ZAKHAROV)
!
! INTERFACE.
! ----------
! *VMIN(XI,XJ,XK)*
! *XI* - WAVE NUMBER
! *XJ* - WAVE NUMBER
! *XK* - WAVE NUMBER
! *THI* - WAVE DIRECTION
! *THJ* - WAVE DIRECTION
! *THK* - WAVE DIRECTION
! METHOD.
! -------
! NONE
!
! EXTERNALS.
! ----------
! NONE.
!
!-----------------------------------------------------------------------
!
IMPLICIT NONE
COMMON/CONST/DEPTH,ALPHA,MDW,GAM_J,DEPTHD
INTEGER MDW
REAL DEPTH,ALPHA,GAM_J,DEPTHA,DEPTHD
REAL DEL1,RI,RJ,RK,XI,XJ,XK,THI,THJ,THK,OI,OJ,OK,QI,QJ,QK,&
RIJ,RIK,RJK,SQIJK,SQIKJ,SQJKI,ZCONST
!
!*** 1. DETERMINE NONLINEAR TRANSFER.
! --------------------------------
!
DEL1 = 10.**(-12)
ZCONST=1./(4*SQRT(2.))
RI = XI
RJ = XJ
RK = XK
OI=OMEG(RI)+DEL1
OJ=OMEG(RJ)+DEL1
OK=OMEG(RK)+DEL1
QI=OI**2/G
QJ=OJ**2/G
QK=OK**2/G
RIJ = RI*RJ*COS(THJ-THI)
RIK = RI*RK*COS(THK-THI)
RJK = RJ*RK*COS(THK-THJ)
SQIJK=SQRT(G*OK/(OI*OJ))
SQIKJ=SQRT(G*OJ/(OI*OK))
SQJKI=SQRT(G*OI/(OJ*OK))
VMIN=ZCONST*( (RIJ-QI*QJ)*SQIJK + (RIK-QI*QK)*SQIKJ&
+ (RJK+QJ*QK)*SQJKI )
RETURN
END FUNCTION VMIN
!
!-----------------------------------------------------------------------
!
!*** *REAL FUNCTION* *U(XI,XJ,XK,XL,THI,THJ,THK,THL)
!
!-----------------------------------------------------------------------
REAL FUNCTION U(XI,XJ,XK,XL,THI,THJ,THK,THL)
!
!*** *U* DETERMINES THE THIRD-ORDER TRANSFER COEFFICIENT FOR FOUR
! WAVE INTERACTIONS OF GRAVITY WAVES.
!
! PETER JANSSEN
!
! PURPOSE.
! --------
!
! GIVES NONLINEAR TRANSFER COEFFICIENT FOR FOUR
! WAVE INTERACTIONS OF GRAVITY-CAPILLARY WAVES IN THE
! IDEAL CASE OF NO CURRENT. (CF.ZAKHAROV,AND CRAWFORD ET AL)
!
! INTERFACE.
! ----------
! *U(XI,XJ,XK,XL)*
! *XI* - WAVE NUMBER
! *XJ* - WAVE NUMBER
! *XK* - WAVE NUMBER
! *XL* - WAVE NUMBER
! METHOD.
! -------
! NONE
!
! EXTERNALS.
! ----------
! NONE.
!
!-----------------------------------------------------------------------
!
IMPLICIT NONE
COMMON/CONST/DEPTH,ALPHA,MDW,GAM_J,DEPTHD
INTEGER MDW
REAL DEPTH,ALPHA,GAM_J,DEPTHA,DEPTHD
REAL XI,XJ,XK,XL,THI,THJ,THK,THL,OI,OJ,OK,OL,XIK,XJK,XIL,XJL,&
OIK,OJK,OIL,OJL,QI,QJ,QIK,QJK,QIL,QJL,SQIJKL,ZCONST
!
!*** 1. DETERMINE NONLINEAR TRANSFER.
! --------------------------------
!
ZCONST=1./(16.)
OI=OMEG(XI)
OJ=OMEG(XJ)
OK=OMEG(XK)
OL=OMEG(XL)
XIK = VABS(XI,XK,THI,THK)
XJK = VABS(XJ,XK,THJ,THK)
XIL = VABS(XI,XL,THI,THL)
XJL = VABS(XJ,XL,THJ,THL)
OIK=OMEG(XIK)
OJK=OMEG(XJK)
OIL=OMEG(XIL)
OJL=OMEG(XJL)
QI=OI**2/G
QJ=OJ**2/G
QIK=OIK**2/G
QJK=OJK**2/G
QIL=OIL**2/G
QJL=OJL**2/G
SQIJKL=SQRT(OK*OL/(OI*OJ))
U = ZCONST*SQIJKL*( 2.*(XI**2*QJ+XJ**2*QI)-QI*QJ*(&
QIK+QJK+QIL+QJL) )
RETURN
END FUNCTION U
!
!-----------------------------------------------------------------------
!
!*** *REAL FUNCTION* *W2(XI,XJ,XK,XL,THI,THJ,THK,THL)
!
!-----------------------------------------------------------------------
REAL FUNCTION W2(XI,XJ,XK,XL,THI,THJ,THK,THL)
!
!*** *W2* DETERMINES THE CONTRIBUTION OF THE DIRECT FOUR-WAVE
! INTERACTIONS OF GRAVITY WAVES OF THE TYPE
! A_2^*A_3A_4.
!
! PETER JANSSEN
!
! PURPOSE.
! --------
!
! GIVES NONLINEAR TRANSFER COEFFICIENT FOR FOUR
! WAVE INTERACTIONS OF GRAVITY WAVES IN THE
! IDEAL CASE OF NO CURRENT. (CF.ZAKHAROV,AND CRAWFORD ET AL)
!
! INTERFACE.
! ----------
! *W(XI,XJ,XK,XL)*
! *XI* - WAVE NUMBER
! *XJ* - WAVE NUMBER
! *XK* - WAVE NUMBER
! *XL* - WAVE NUMBER
! METHOD.
! -------
! NONE
!
! EXTERNALS.
! ----------
! NONE.
!
!-----------------------------------------------------------------------
!
IMPLICIT NONE
REAL XI,XJ,XK,XL,THI,THJ,THK,THL
!
!*** 1. DETERMINE NONLINEAR TRANSFER.
! --------------------------------
!
W2= U(XI,XJ,XK,XL,THI-PI,THJ-PI,THK,THL)+&
U(XK,XL,XI,XJ,THK,THL,THI-PI,THJ-PI)-&
U(XK,XJ,XI,XL,THK,THJ-PI,THI-PI,THL)-&
U(XI,XK,XJ,XL,THI-PI,THK,THJ-PI,THL)-&
U(XI,XL,XK,XJ,THI-PI,THL,THK,THJ-PI)-&
U(XL,XJ,XK,XI,THL,THJ-PI,THK,THI-PI)
RETURN
END FUNCTION W2
!
!-----------------------------------------------------------------------
!
!*** *REAL FUNCTION* *V2(XI,XJ,XK,XL,THI,THJ,THK,THL)
!
!-----------------------------------------------------------------------
REAL FUNCTION V2(XI,XJ,XK,XL,THI,THJ,THK,THL)
!
!*** *V2* DETERMINES THE CONTRIBUTION OF THE VIRTUAL
! FOUR-WAVE INTERACTIONS OF GRAVITY WAVES.
!
! PETER JANSSEN
!
! PURPOSE.
! --------
!
! GIVES NONLINEAR TRANSFER COEFFICIENT FOR FOUR
! WAVE INTERACTIONS OF GRAVITY WAVES IN THE
! IDEAL CASE OF NO CURRENT. (CF.ZAKHAROV,AND
! CRAWFORD ET AL)
!
! INTERFACE.
! ----------
! *V2(XI,XJ,XK,XL)*
! *XI* - WAVE NUMBER
! *XJ* - WAVE NUMBER
! *XK* - WAVE NUMBER
! *XL* - WAVE NUMBER
! METHOD.
! -------
! NONE
!
!
! EXTERNALS.
! ----------
! NONE.
!
!-----------------------------------------------------------------------
!
IMPLICIT NONE
COMMON/CONST/DEPTH,ALPHA,MDW,GAM_J,DEPTHD
COMMON/PRECIS/DOUBLEP
LOGICAL DOUBLEP
INTEGER MDW
REAL DEPTH,ALPHA,GAM_J,DEPTHA,DEPTHD
REAL DEL1,XI,XJ,XK,XL,THI,THJ,THK,THL,OI,OJ,OK,OL,RI,RJ,RK,RL,&
RIJ,RIK,RLI,RJL,RJK,RKL,THIJ,THIK,THLI,THJL,THJK,THKL,OIJ,&
OIK,OJL,OJK,OLI,OKL,XNIK,XNJL,XNJK,XNIL,YNIL,YNJK,YNJL,YNIK,&
ZNIJ,ZNKL,ZPIJ,ZPKL,THLJ,THIL,THKJ,THKI,THJI,THLK
!
!*** 1. DETERMINE NONLINEAR TRANSFER.
! --------------------------------
!
IF (DOUBLEP) THEN
DEL1=10.**(-5)
ELSE
DEL1=10.**(-2)
ENDIF
RI=XI+DEL1
RJ=XJ+DEL1/2.
RK=XK+DEL1/3.
RL=XL+DEL1*(1.+1./2.-1./3.)
OI=OMEG(RI)
OJ=OMEG(RJ)
OK=OMEG(RK)
OL=OMEG(RL)
RIJ = VABS(RI,RJ,THI,THJ)
THIJ = VDIR(RI,RJ,THI,THJ)
RIK = VABS(RI,RK,THI,THK-PI)
THIK = VDIR(RI,RK,THI,THK-PI)
RLI = VABS(RL,RI,THL,THI-PI)
THLI = VDIR(XL,XI,THL,THI-PI)
RJL = VABS(RJ,RL,THJ,THL-PI)
THJL = VDIR(RJ,RL,THJ,THL-PI)
RJK = VABS(RJ,RK,THJ,THK-PI)
THJK = VDIR(RJ,RK,THJ,THK-PI)
RKL = VABS(RK,RL,THK,THL)
THKL = VDIR(RK,RL,THK,THL)
OIJ=OMEG(RIJ)
OIK=OMEG(RIK)
OJL=OMEG(RJL)
OJK=OMEG(RJK)
OLI=OMEG(RLI)
OKL=OMEG(RKL)
XNIK = OK+OIK-OI
XNJL = OJ+OJL-OL
XNJK = OK+OJK-OJ
XNIL = OI+OLI-OL
YNIL = OL+OLI-OI
YNJK = OJ+OJK-OK
YNJL = OL+OJL-OJ
YNIK = OI+OIK-OK
ZNIJ = OIJ-OI-OJ
ZNKL = OKL-OK-OL
ZPIJ = OIJ+OI+OJ
ZPKL = OKL+OK+OL
THLJ = THJL-PI
THIL = THLI-PI
THKJ = THJK-PI
THKI = THIK-PI
THJI = THIJ-PI
THLK = THKL-PI
V2= VMIN(RI,RK,RIK,THI,THK,THIK)*VMIN(RL,RJ,RJL,THL,THJ,THLJ)*&
(1./XNIK+1./XNJL)&
+VMIN(RJ,RK,RJK,THJ,THK,THJK)*VMIN(RL,RI,RLI,THL,THI,THLI)*&
(1./XNJK+1./XNIL)&
+VMIN(RI,RL,RLI,THI,THL,THIL)*VMIN(RK,RJ,RJK,THK,THJ,THKJ)*&
(1./YNIL+1./YNJK)&
+VMIN(RJ,RL,RJL,THJ,THL,THJL)*VMIN(RK,RI,RIK,THK,THI,THKI)*&
(1./YNJL+1./YNIK)&
+VMIN(RIJ,RI,RJ,THIJ,THI,THJ)*VMIN(RKL,RK,RL,THKL,THK,THL)*&
(1./ZNIJ+1./ZNKL)&
+VPLUS(RIJ,RI,RJ,THJI,THI,THJ)*VPLUS(RKL,RK,RL,THLK,THK,THL)*&
(1./ZPIJ+1./ZPKL)
V2 = -V2
RETURN
END FUNCTION V2
!
!-----------------------------------------------------------------------
!
!*** *REAL FUNCTION* *W1(XI,XJ,XK,XL,THI,THJ,THK,THL)
!
!-----------------------------------------------------------------------
REAL FUNCTION W1(XI,XJ,XK,XL,THI,THJ,THK,THL)
!
!*** *W1* DETERMINES THE NONLINEAR TRANSFER COEFFICIENT FOR FOUR
! WAVE INTERACTIONS OF GRAVITY WAVES OF THE TYPE
! A_2A_3A_4.
!
! PETER JANSSEN
!
! PURPOSE.
! --------
!
! GIVES NONLINEAR TRANSFER COEFFICIENT FOR FOUR
! WAVE INTERACTIONS OF GRAVITY-CAPILLARY WAVES IN THE
! IDEAL CASE OF NO CURRENT. (CF.ZAKHAROV,AND CRAWFORD ET AL)
!
! INTERFACE.
! ----------
! *W1(XI,XJ,XK,XL)*
! *XI* - WAVE NUMBER
! *XJ* - WAVE NUMBER
! *XK* - WAVE NUMBER
! *XL* - WAVE NUMBER
! METHOD.
! -------
! NONE
!
! EXTERNALS.
! ----------
! NONE.
!
!-----------------------------------------------------------------------
!
IMPLICIT NONE
COMMON/CONST/DEPTH,ALPHA,MDW,GAM_J,DEPTHD
INTEGER MDW
REAL DEPTH,ALPHA,GAM_J,DEPTHA,DEPTHD
REAL XI,XJ,XK,XL,THI,THJ,THK,THL
!
!
!*** 1. DETERMINE NONLINEAR TRANSFER.
! --------------------------------
!
W1= -U(XI,XJ,XK,XL,THI-PI,THJ,THK,THL)-&
U(XI,XK,XJ,XL,THI-PI,THK,THJ,THL)-&
U(XI,XL,XJ,XK,THI-PI,THL,THJ,THK)+&
U(XJ,XK,XI,XL,THJ,THK,THI-PI,THL)+&
U(XJ,XL,XI,XK,THJ,THL,THI-PI,THK)+&
U(XK,XL,XI,XJ,THK,THL,THI-PI,THJ)
W1=W1/3.
RETURN
END FUNCTION W1
!
!*** *REAL FUNCTION* *W4(XI,XJ,XK,XL,THI,THJ,THK,THL)
!
!-----------------------------------------------------------------------
REAL FUNCTION W4(XI,XJ,XK,XL,THI,THJ,THK,THL)
!
!*** *W4* DETERMINES THE NONLINEAR TRANSFER COEFFICIENT FOR FOUR
! WAVE INTERACTIONS OF GRAVITY WAVES of the type
! A_^*A_3^*A_4^*.
!
! PETER JANSSEN
!
! PURPOSE.
! --------
!
! GIVES NONLINEAR TRANSFER COEFFICIENT FOR FOUR
! WAVE INTERACTIONS OF GRAVITY-CAPILLARY WAVES IN THE
! IDEAL CASE OF NO CURRENT. (CF.ZAKHAROV,AND CRAWFORD ET AL)
!
! INTERFACE.
! ----------
! *W4(XI,XJ,XK,XL)*
! *XI* - WAVE NUMBER
! *XJ* - WAVE NUMBER
! *XK* - WAVE NUMBER
! *XL* - WAVE NUMBER
! METHOD.
! -------
! NONE
!
! EXTERNALS.
! ----------
! NONE.
!
!-----------------------------------------------------------------------
!
IMPLICIT NONE
COMMON/CONST/DEPTH,ALPHA,MDW,GAM_J,DEPTHD
INTEGER MDW
REAL DEPTH,ALPHA,GAM_J,DEPTHA,DEPTHD
REAL XI,XJ,XK,XL,THI,THJ,THK,THL
!
!
!*** 1. DETERMINE NONLINEAR TRANSFER.
! --------------------------------
!
W4= U(XI,XJ,XK,XL,THI,THJ,THK,THL)+&
U(XI,XK,XJ,XL,THI,THK,THJ,THL)+&
U(XI,XL,XJ,XK,THI,THL,THJ,THK)+&
U(XJ,XK,XI,XL,THJ,THK,THI,THL)+&
U(XJ,XL,XI,XK,THJ,THL,THI,THK)+&
U(XK,XL,XI,XJ,THK,THL,THI,THJ)
W4=W4/3.
RETURN
END FUNCTION W4
!
!-----------------------------------------------------------------------
!
!*** *REAL FUNCTION* *B3(XI,XJ,XK,XL,THI,THJ,THK,THL)
!
!-----------------------------------------------------------------------
REAL FUNCTION B3(XI,XJ,XK,XL,THI,THJ,THK,THL)
!
!*** *B3* WEIGHTS OF THE A_2^*A_3^*A_4 PART OF THE
! CANONICAL TRANSFORMATION.
!
! PETER JANSSEN
!
! PURPOSE.
! --------
!
! GIVES NONLINEAR TRANSFER COEFFICIENT FOR FOUR
! WAVE INTERACTIONS OF GRAVITY-CAPILLARY WAVES IN THE
! IDEAL CASE OF NO CURRENT. (CF.ZAKHAROV,AND CRAWFORD ET AL)
!
! INTERFACE.
! ----------
! *B3(XI,XJ,XK,XL)*
! *XI* - WAVE NUMBER
! *XJ* - WAVE NUMBER
! *XK* - WAVE NUMBER
! *XL* - WAVE NUMBER
! METHOD.
! -------
! NONE
!
!
! EXTERNALS.
! ----------
! NONE.
!
!-----------------------------------------------------------------------
!
IMPLICIT NONE
COMMON/CONST/DEPTH,ALPHA,MDW,GAM_J,DEPTHD
COMMON/PRECIS/DOUBLEP
LOGICAL DOUBLEP
INTEGER MDW
REAL DEPTH,ALPHA,GAM_J,DEPTHA,DEPTHD
REAL DEL1,XI,XJ,XK,XL,THI,THJ,THK,THL,OI,OJ,OK,OL,RI,RJ,RK,RL,&
RIJ,RJI,RIK,RKI,RLJ,RJL,RJK,RKJ,RLI,RIL,RLK,RKL,THIJ,THJI,&
THIK,THKI,THLJ,THJL,THJK,THKJ,THLI,THIL,THLK,THKL,ZIJKL
!
!*** 1. DETERMINE NONLINEAR TRANSFER.
! --------------------------------
!
IF (DOUBLEP) THEN
DEL1=10.**(-5)
ELSE
DEL1=0.01
ENDIF
RI=XI
RJ=XJ
RK=XK
RL=XL
OI=OMEG(RI)+DEL1
OJ=OMEG(RJ)+DEL1
OK=OMEG(RK)+DEL1
OL=OMEG(RL)+DEL1
RIJ = VABS(RI,RJ,THI,THJ)
THIJ = VDIR(RI,RJ,THI,THJ)
RJI = VABS(RJ,RI,THJ,THI)
THJI = VDIR(RJ,RI,THJ,THI)
RIK = VABS(RI,RK,THI,THK)
THIK = VDIR(RI,RK,THI,THK)
RKI = VABS(RK,RI,THK,THI)
THKI = VDIR(RK,RI,THK,THI)
RLJ = VABS(RL,RJ,THL,THJ-PI)
THLJ = VDIR(RL,RJ,THL,THJ-PI)
RJL = VABS(RJ,RL,THJ,THL-PI)
THJL = VDIR(RJ,RL,THJ,THL-PI)
RJK = VABS(RJ,RK,THJ,THK)
THJK = VDIR(RJ,RK,THJ,THK)
RKJ = VABS(RK,RJ,THK,THJ)
THKJ = VDIR(RK,RJ,THK,THJ)
RLI = VABS(RL,RI,THL,THI-PI)
THLI = VDIR(RL,RI,THL,THI-PI)
RIL = VABS(RI,RL,THI,THL-PI)
THIL = VDIR(RI,RL,THI,THL-PI)
RLK = VABS(RL,RK,THL,THK-PI)
THLK = VDIR(RL,RK,THL,THK-PI)
RKL = VABS(RK,RL,THK,THL-PI)
THKL = VDIR(RK,RL,THK,THL-PI)
ZIJKL = OI+OJ+OK-OL
B3= -1./ZIJKL*(2.*( &
VMIN(RL,RI,RLI,THL,THI,THLI)*A1(RJK,RJ,RK,THJK,THJ,THK)&
-VMIN(RIJ,RI,RJ,THIJ,THI,THJ)*A1(RL,RK,RLK,THL,THK,THLK)&
-VMIN(RIK,RI,RK,THIK,THI,THK)*A1(RL,RJ,RLJ,THL,THJ,THLJ)&
-VPLUS(RJ,RI,RJI,THJ,THI,THJI-PI)*A1(RK,RL,RKL,THK,THL,THKL)&
-VPLUS(RK,RI,RKI,THK,THI,THKI-PI)*A1(RJ,RL,RJL,THJ,THL,THJL)&
+VMIN(RI,RL,RIL,THI,THL,THIL)*A3(RJ,RK,RJK,THJ,THK,THJK-PI))&
+3.*W1(RL,RK,RJ,RI,THL,THK,THJ,THI) )
RETURN
END FUNCTION B3
!
!-----------------------------------------------------------------------
!
!*** *REAL FUNCTION* *B4(XI,XJ,XK,XL,THI,THJ,THK,THL)
!
!-----------------------------------------------------------------------
REAL FUNCTION B4(XI,XJ,XK,XL,THI,THJ,THK,THL)
!
!*** *B4* WEIGHTS OF THE A_2^*A_3^*A_4^* PART OF THE CANONICAL
! TRANSFORMATION.
!
! PETER JANSSEN
!
! PURPOSE.
! --------
!
! GIVES NONLINEAR TRANSFER COEFFICIENT FOR FOUR
! WAVE INTERACTIONS OF GRAVITY-CAPILLARY WAVES IN THE
! IDEAL CASE OF NO CURRENT. (CF.ZAKHAROV,AND CRAWFORD ET AL)
!
! INTERFACE.
! ----------
! *B4(XI,XJ,XK,XL)*
! *XI* - WAVE NUMBER
! *XJ* - WAVE NUMBER
! *XK* - WAVE NUMBER
! *XL* - WAVE NUMBER
! METHOD.
! -------
! NONE
!
!
! EXTERNALS.
! ----------
! NONE.
!
!-----------------------------------------------------------------------
!
IMPLICIT NONE
COMMON/CONST/DEPTH,ALPHA,MDW,GAM_J,DEPTHD
COMMON/PRECIS/DOUBLEP
LOGICAL DOUBLEP
INTEGER MDW
REAL DEPTH,ALPHA,GAM_J,DEPTHA,DEPTHD
REAL DEL1,XI,XJ,XK,XL,THI,THJ,THK,THL,OI,OJ,OK,OL,RI,RJ,RK,RL,&
RIJ,RIK,RIL,RJL,RJK,RKL,THIJ,THIK,THIL,THJL,THJK,THLK,THKL,&
ZIJKL
!
!*** 1. DETERMINE NONLINEAR TRANSFER.
! --------------------------------
!
RI=XI
RJ=XJ
RK=XK
RL=XL
OI=OMEG(RI)
OJ=OMEG(RJ)
OK=OMEG(RK)
OL=OMEG(RL)
RIJ = VABS(RI,RJ,THI,THJ)
THIJ = VDIR(RI,RJ,THI,THJ)
RIK = VABS(RI,RK,THI,THK)
THIK = VDIR(RI,RK,THI,THK)
RIL = VABS(RI,RL,THI,THL)
THIL = VDIR(RI,RL,THI,THL)
RJL = VABS(RJ,RL,THJ,THL)
THJL = VDIR(RJ,RL,THJ,THL)
RJK = VABS(RJ,RK,THJ,THK)
THJK = VDIR(RJ,RK,THJ,THK)
RKL = VABS(RK,RL,THK,THL)
THKL = VDIR(RK,RL,THK,THL)
ZIJKL = OI+OJ+OK+OL
B4= -1./ZIJKL*(2./3.*( &
VPLUS(RIJ,RI,RJ,THIJ-PI,THI,THJ)*A1(RKL,RK,RL,THKL,THK,THL)&
+VPLUS(RIK,RI,RK,THIK-PI,THI,THK)*A1(RJL,RJ,RL,THJL,THJ,THL)&
+VPLUS(RIL,RI,RL,THIL-PI,THI,THL)*A1(RJK,RJ,RK,THJK,THJ,THK)&
+VMIN(RIK,RI,RK,THIK,THI,THK)*A3(RJL,RJ,RL,THJL-PI,THJ,THL)&
+VMIN(RIL,RI,RL,THIL,THI,THL)*A3(RJK,RJ,RK,THJK-PI,THJ,THK)&
+VMIN(RIJ,RI,RJ,THIJ,THI,THJ)*A3(RKL,RK,RL,THKL-PI,THK,THL) )&
+W4(RI,RJ,RK,RL,THI,THJ,THK,THL) )
RETURN
END FUNCTION B4
!
!-----------------------------------------------------------------------
!
!*** *REAL FUNCTION* *B1(XI,XJ,XK,XL,THI,THJ,THK,THL)
!
!-----------------------------------------------------------------------
REAL FUNCTION B1(XI,XJ,XK,XL,THI,THJ,THK,THL)
!
!*** *B1* WEIGHTS OF THE A_2A_3A_4 PART OF THE CANONICAL
! TRANSFORMATION.
!
! PETER JANSSEN
!
! PURPOSE.
! --------
!
! GIVES NONLINEAR TRANSFER COEFFICIENT FOR FOUR
! WAVE INTERACTIONS OF GRAVITY-CAPILLARY WAVES IN THE
! IDEAL CASE OF NO CURRENT. (CF.ZAKHAROV,AND CRAWFORD ET AL)
!
! INTERFACE.
! ----------
! *B1(XI,XJ,XK,XL)*
! *XI* - WAVE NUMBER
! *XJ* - WAVE NUMBER
! *XK* - WAVE NUMBER
! *XL* - WAVE NUMBER
! METHOD.
! -------
! NONE
!
!
! EXTERNALS.
! ----------
! NONE.
!
!-----------------------------------------------------------------------
!
IMPLICIT NONE
COMMON/CONST/DEPTH,ALPHA,MDW,GAM_J,DEPTHD
COMMON/PRECIS/DOUBLEP
LOGICAL DOUBLEP
INTEGER MDW
REAL DEPTH,ALPHA,GAM_J,DEPTHA,DEPTHD
REAL DEL1,XI,XJ,XK,XL,THI,THJ,THK,THL,OI,OJ,OK,OL,RI,RJ,RK,RL,&
RIJ,RJI,RIK,RKI,RJL,RJK,RLI,RIL,RKL,THIJ,THJI,&
THIK,THKI,THJL,THJK,THLI,THIL,THKL,ZIJKL
!
!
!*** 1. DETERMINE NONLINEAR TRANSFER.
! --------------------------------
!
RI=XI
RJ=XJ
RK=XK
RL=XL
OI=OMEG(RI)
OJ=OMEG(RJ)
OK=OMEG(RK)
OL=OMEG(RL)
RIJ = VABS(RI,RJ,THI,THJ-PI)
THIJ = VDIR(RI,RJ,THI,THJ-PI)
RJI = VABS(RJ,RI,THJ,THI-PI)
THJI = VDIR(RJ,RI,THJ,THI-PI)
RIK = VABS(RI,RK,THI,THK-PI)
THIK = VDIR(RI,RK,THI,THK-PI)
RKI = VABS(RK,RI,THK,THI-PI)
THKI = VDIR(RK,RI,THK,THI-PI)
RIL = VABS(RI,RL,THI,THL-PI)
THIL = VDIR(RI,RL,THI,THL-PI)
RLI = VABS(RL,RI,THL,THI-PI)
THLI = VDIR(RL,RI,THL,THI-PI)
RJL = VABS(RJ,RL,THJ,THL)
THJL = VDIR(RJ,RL,THJ,THL)
RJK = VABS(RJ,RK,THJ,THK)
THJK = VDIR(RJ,RK,THJ,THK)
RKL = VABS(RK,RL,THK,THL)
THKL = VDIR(RK,RL,THK,THL)
ZIJKL = OI-OJ-OK-OL
B1= -1./ZIJKL*(2./3.*( &
MIN(RI,RJ,RIJ,THI,THJ,THIJ)*A1(RKL,RK,RL,THKL,THK,THL)&
+VMIN(RI,RK,RIK,THI,THK,THIK)*A1(RJL,RJ,RL,THJL,THJ,THL)&
+VMIN(RI,RL,RIL,THI,THL,THIL)*A1(RJK,RJ,RK,THJK,THJ,THK)&
+VMIN(RK,RI,RKI,THK,THI,THKI)*A3(RJL,RJ,RL,THJL-PI,THJ,THL)&
+VMIN(RL,RI,RLI,THL,THI,THLI)*A3(RJK,RJ,RK,THJK-PI,THJ,THK)&
+VMIN(RJ,RI,RJI,THJ,THI,THJI)*A3(RKL,RK,RL,THKL-PI,THK,THL) &
) +W1(RI,RJ,RK,RL,THI,THJ,THK,THL) )
RETURN
END FUNCTION B1
!
!-----------------------------------------------------------------------
!
!*** *REAL FUNCTION* *B2(XI,XJ,XK,XL,THI,THJ,THK,THL)
!
!-----------------------------------------------------------------------
REAL FUNCTION B2(XI,XJ,XK,XL,THI,THJ,THK,THL)
!
!
!*** *B2* WEIGHTS OF THE A_2^*A_3A_4 PART OF THE CANONICAL
! TRANSFORMATION.
!
! PETER JANSSEN
!
! PURPOSE.
! --------
!
! GIVES NONLINEAR TRANSFER COEFFICIENT FOR FOUR
! WAVE INTERACTIONS OF GRAVITY-CAPILLARY WAVES IN THE
! IDEAL CASE OF NO CURRENT. (CF.ZAKHAROV,AND CRAWFORD ET AL)
!
! INTERFACE.
! ----------
! *B2(XI,XJ,XK,XL)*
! *XI* - WAVE NUMBER
! *XJ* - WAVE NUMBER
! *XK* - WAVE NUMBER
! *XL* - WAVE NUMBER
! METHOD.
! -------
! NONE
!
!
! EXTERNALS.
! ----------
! NONE.
!
!-----------------------------------------------------------------------
!
IMPLICIT NONE
COMMON/CONST/DEPTH,ALPHA,MDW,GAM_J,DEPTHD
COMMON/PRECIS/DOUBLEP
LOGICAL DOUBLEP
INTEGER MDW
REAL DEPTH,ALPHA,GAM_J,DEPTHA,DEPTHD
REAL DEL1,XI,XJ,XK,XL,THI,THJ,THK,THL,OI,OJ,OK,OL,RI,RJ,RK,RL,&
RIJ,RIK,RKI,RJL,RLJ,RJK,RKJ,RLI,RIL,RKL,THIJ,&
THIK,THKI,THJL,THLJ,THJK,THKJ,THLI,THIL,THKL,ZIJKL
!
!*** 1. DETERMINE NONLINEAR TRANSFER.
! --------------------------------
!
RI=XI
RJ=XJ
RK=XK
RL=XL
RIJ = VABS(RI,RJ,THI,THJ)
THIJ = VDIR(RI,RJ,THI,THJ)
RIK = VABS(RI,RK,THI,THK-PI)
THIK = VDIR(RI,RK,THI,THK-PI)
RKI = VABS(RK,RI,THK,THI-PI)
THKI = VDIR(RK,RI,THK,THI-PI)
RIL = VABS(RI,RL,THI,THL-PI)
THIL = VDIR(RI,RL,THI,THL-PI)
RLI = VABS(RL,RI,THL,THI-PI)
THLI = VDIR(RL,RI,THL,THI-PI)
RJL = VABS(RJ,RL,THJ,THL-PI)
THJL = VDIR(RJ,RL,THJ,THL-PI)
RLJ = VABS(RL,RJ,THL,THJ-PI)
THLJ = VDIR(RL,RJ,THL,THJ-PI)
RJK = VABS(RJ,RK,THJ,THK-PI)
THJK = VDIR(RJ,RK,THJ,THK-PI)
RKJ = VABS(RK,RJ,THK,THJ-PI)
THKJ = VDIR(RK,RJ,THK,THJ-PI)
RKL = VABS(RK,RL,THK,THL)
THKL = VDIR(RK,RL,THK,THL)
B2= A3(RI,RJ,RIJ,THI,THJ,THIJ-PI)*A3(RK,RL,RKL,THK,THL,THKL-PI)&
+A1(RJ,RK,RJK,THJ,THK,THJK)*A1(RL,RI,RLI,THL,THI,THLI)&
+A1(RJ,RL,RJL,THJ,THL,THJL)*A1(RK,RI,RKI,THK,THI,THKI)&
-A1(RIJ,RI,RJ,THIJ,THI,THJ)*A1(RKL,RK,RL,THKL,THK,THL)&
-A1(RI,RK,RIK,THI,THK,THIK)*A1(RL,RJ,RLJ,THL,THJ,THLJ)&
-A1(RI,RL,RIL,THI,THL,THIL)*A1(RK,RJ,RKJ,THK,THJ,THKJ)
RETURN
END FUNCTION B2
!
!-----------------------------------------------------------------------
!
!*** *REAL FUNCTION* *A1(XI,XJ,XK,THI,THJ,THK)
!
!-----------------------------------------------------------------------
REAL FUNCTION A1(XI,XJ,XK,THI,THJ,THK)
!
!*** *A1* AUXILIARY SECOND-ORDER COEFFICIENT.
!
! PETER JANSSEN
!
! PURPOSE.
! --------
!
! GIVES NONLINEAR TRANSFER COEFFICIENT FOR THREE
! WAVE INTERACTIONS OF GRAVITY-CAPILLARY WAVES IN THE
! IDEAL CASE OF NO CURRENT. (CF.ZAKHAROV)
!
! INTERFACE.
! ----------
! *VMIN(XI,XJ,XK)*
! *XI* - WAVE NUMBER
! *XJ* - WAVE NUMBER
! *XK* - WAVE NUMBER
! METHOD.
! -------
! NONE
!
! EXTERNALS.
! ----------
! NONE.
!
!-----------------------------------------------------------------------
!
IMPLICIT NONE
COMMON/CONST/DEPTH,ALPHA,MDW,GAM_J,DEPTHD
COMMON/PRECIS/DOUBLEP
LOGICAL DOUBLEP
INTEGER MDW
REAL DEPTH,ALPHA,GAM_J,DEPTHA,DEPTHD
REAL DEL1,XI,XJ,XK,THI,THJ,THK,OI,OJ,OK
!
!*** 1. DETERMINE NONLINEAR TRANSFER.
! --------------------------------
!
IF (DOUBLEP) THEN
DEL1 = 10.**(-8)
ELSE
DEL1 = 10.**(-4)
ENDIF
OI=OMEG(XI)+DEL1
OJ=OMEG(XJ)+DEL1
OK=OMEG(XK)+DEL1
A1 = -VMIN(XI,XJ,XK,THI,THJ,THK)/(OI-OJ-OK)
RETURN
END FUNCTION A1
!
!-----------------------------------------------------------------------
!
!*** *REAL FUNCTION* *A2(XI,XJ,XK,THI,THJ,THK)
!
!-----------------------------------------------------------------------
REAL FUNCTION A2(XI,XJ,XK,THI,THJ,THK)
!
!*** *A2* AUXILIARY SECOND-ORDER FUNCTION.
!
! PETER JANSSEN
!
! PURPOSE.
! --------
!
! GIVES NONLINEAR TRANSFER COEFFICIENT FOR THREE
! WAVE INTERACTIONS OF GRAVITY-CAPILLARY WAVES IN THE
! IDEAL CASE OF NO CURRENT. (CF.ZAKHAROV)
!
! INTERFACE.
! ----------
! *VMIN(XI,XJ,XK)*
! *XI* - WAVE NUMBER
! *XJ* - WAVE NUMBER
! *XK* - WAVE NUMBER
! METHOD.
! -------
! NONE
!
! EXTERNALS.
! ----------
! NONE.
!
!-----------------------------------------------------------------------
!
IMPLICIT NONE
REAL DEL1,XI,XJ,XK,THI,THJ,THK
!
!*** 1. DETERMINE NONLINEAR TRANSFER.
! --------------------------------
!
A2 = -2.*A1(XK,XJ,XI,THK,THJ,THI)
RETURN
END FUNCTION A2
!
!-----------------------------------------------------------------------
!
!*** *REAL FUNCTION* *A3(XI,XJ,XK,THI,THJ,THK)
!
!-----------------------------------------------------------------------
REAL FUNCTION A3(XI,XJ,XK,THI,THJ,THK)
!
!*** *A3* AUXILIARY SECOND-ORDER FUNCTION.
!
! PETER JANSSEN
!
! PURPOSE.
! --------
!
! GIVES NONLINEAR TRANSFER COEFFICIENT FOR THREE
! WAVE INTERACTIONS OF GRAVITY-CAPILLARY WAVES IN THE
! IDEAL CASE OF NO CURRENT. (CF.ZAKHAROV)
!
! INTERFACE.
! ----------
! *VMIN(XI,XJ,XK)*
! *XI* - WAVE NUMBER
! *XJ* - WAVE NUMBER
! *XK* - WAVE NUMBER
! METHOD.
! -------
! NONE
!
! EXTERNALS.
! ----------
! NONE.
!
!-----------------------------------------------------------------------
!
IMPLICIT NONE
COMMON/PRECIS/DOUBLEP
LOGICAL DOUBLEP
REAL DEL1,OI,OJ,OK,XI,XJ,XK,THI,THJ,THK
!
!*** 1. DETERMINE NONLINEAR TRANSFER.
! --------------------------------
!
IF (DOUBLEP) THEN
DEL1 = 10.**(-8)
ELSE
DEL1 = 10.**(-4)
ENDIF
OI=OMEG(XI)+DEL1
OJ=OMEG(XJ)+DEL1
OK=OMEG(XK)+DEL1
A3 = -VPLUS(XI,XJ,XK,THI,THJ,THK)/(OI+OJ+OK)
RETURN
END FUNCTION A3
!
!-----------------------------------------------------------------------
!
!
!*** *REAL FUNCTION* *OMEG(X)*
!
!-----------------------------------------------------------------------
!
REAL FUNCTION OMEG(X)
!
!*** *OMEG* DETERMINES THE DISPERSION RELATION FOR GRAVITY
! WAVES.
!
! PETER JANSSEN
!
! PURPOSE.
! --------
!
! GIVES DISPERSION RELATION FOR GRAVITY-
! WAVES IN THE IDEAL CASE OF NO CURRENT.
!
! INTERFACE.
! ----------
! *OMEG(X)*
! *X* - WAVE NUMBER
!
! METHOD.
! -------
! NONE
!
! EXTERNALS.
! ----------
! NONE.
!
!-----------------------------------------------------------------------
!
IMPLICIT NONE
COMMON/CONST/DEPTH,ALPHA,MDW,GAM_J,DEPTHD
INTEGER MDW
REAL DEPTH,ALPHA,GAM_J,DEPTHD
REAL D,XK,X,T
D = DEPTH
XK = ABS(X)
T = TANH(XK*D)
OMEG=SQRT(G*XK*T)
RETURN
END FUNCTION OMEG
!
!
!-----------------------------------------------------------------------
!
!
!*** *REAL FUNCTION* *VG(X)*
!
!-----------------------------------------------------------------------
!
REAL FUNCTION VG(X)
!
!*** *VG* DETERMINES THE GROUP VELOCITY FOR GRAVITY- WAVES.
!
! PETER JANSSEN
!
! PURPOSE.
! --------
!
! GIVES GROUP VELOCITY FOR GRAVITY-
! WAVES IN THE IDEAL CASE OF NO CURRENT.
!
! INTERFACE.
! ----------
! *VG(X)*
! *X* - WAVE NUMBER
!
! METHOD.
! -------
! NONE
!
! EXTERNALS.
! ----------
! NONE.
!
!-----------------------------------------------------------------------
!
IMPLICIT NONE
COMMON/CONST/DEPTH,ALPHA,MDW,GAM_J,DEPTHD
INTEGER MDW
REAL DEPTH,ALPHA,GAM_J,DEPTHD
REAL D,XK,X,XD
D = DEPTH
XK = ABS(X)
XD = XK*DEPTH
VG = 0.5*SQRT(G*TANH(XD)/XK)*(1.+2.*XD/SINH(2.*XD))
RETURN
END FUNCTION VG
!---------------------------------------------------------------------
REAL FUNCTION AKI(OM,BETA)
! This function gives the wavenumber ...
!---------------------------------------------------------------------
!
IMPLICIT NONE
REAL OM,BETA,G,EBS,AKM1,AKM2,AO,AKP,BO,TH,STH
G =9.806
EBS=0.0001
AKM1=OM**2/(4.*G )
AKM2=OM/(2.*SQRT(G*BETA))
AO=MAX(AKM1,AKM2)
10 CONTINUE
AKP=AO
BO=BETA*AO
! IF (BO.GT.10) GO TO 20
IF (BO.GT.20.) GO TO 20
TH=G*AO*TANH(BO)
STH=SQRT(TH)
AO=AO+(OM-STH)*STH*2./(TH/AO+G*BO/COSH(BO)**2)
IF (ABS(AKP-AO).GT.EBS*AO) GO TO 10
AKI=AO
RETURN
20 CONTINUE
AKI=OM**2/G
RETURN
END FUNCTION AKI
!
REAL FUNCTION VABS(XI,XJ,THI,THJ)
!
!---------------------------------------------------------------------
!
IMPLICIT NONE
REAL XI,XJ,THI,THJ,ARG
ARG = XI**2+XJ**2+2.*XI*XJ*COS(THI-THJ)
IF (ARG.LE.0.) THEN
VABS = 0.
ELSE
VABS = SQRT(ARG)
ENDIF
RETURN
END FUNCTION VABS
!
REAL FUNCTION VDIR(XI,XJ,THI,THJ)
!
!---------------------------------------------------------------------
!
IMPLICIT NONE
REAL XI,XJ,THI,THJ,EPS,Y,X
EPS = 0.
Y = XJ*SIN(THJ-THI)
X = XI+XJ*COS(THJ-THI)+EPS
VDIR = ATAN2(Y,X)+THI
IF (X.EQ.0.) VDIR = 0.
RETURN
END FUNCTION VDIR
!/
!/ End of module W3CANOMD -------------------------------------------- /
!/
END MODULE W3CANOMD