From d7da32eb49b887d1733ad3b40dc7cc281f312538 Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Wed, 4 Jun 2025 15:07:26 +0000 Subject: [PATCH 01/89] first commit of bydbr physics --- src/ecwam/CMakeLists.txt | 8 + src/ecwam/airsea.F90 | 56 +- src/ecwam/airsea_iter.F90 | 199 +++++++ src/ecwam/airsea_jan.F90 | 129 +++++ src/ecwam/calcphiwa.F90 | 57 ++ src/ecwam/irange.F90 | 52 ++ src/ecwam/lfactor.F90 | 285 ++++++++++ src/ecwam/sdissip.F90 | 12 +- src/ecwam/sdissip_bydbr.F90 | 271 ++++++++++ src/ecwam/setwavphys.F90 | 29 +- src/ecwam/sinflx.F90 | 3 +- src/ecwam/sinput.F90 | 17 +- src/ecwam/sinput_bydbr.F90 | 539 +++++++++++++++++++ src/ecwam/swldissip_bydbr.F90 | 250 +++++++++ src/ecwam/tau_wave_atmos.F90 | 162 ++++++ src/ecwam/tauwinds.F90 | 62 +++ src/ecwam/userin.F90 | 4 +- src/ecwam/yowcout.F90 | 4 +- src/ecwam/yowfred.F90 | 1 - src/ecwam/yowphys.F90 | 3 + tests/etopo1_oper_an_fc_O48_cy50r1_bydbr.yml | 123 +++++ 21 files changed, 2214 insertions(+), 52 deletions(-) create mode 100644 src/ecwam/airsea_iter.F90 create mode 100644 src/ecwam/airsea_jan.F90 create mode 100644 src/ecwam/calcphiwa.F90 create mode 100644 src/ecwam/irange.F90 create mode 100644 src/ecwam/lfactor.F90 create mode 100644 src/ecwam/sdissip_bydbr.F90 create mode 100644 src/ecwam/sinput_bydbr.F90 create mode 100644 src/ecwam/swldissip_bydbr.F90 create mode 100644 src/ecwam/tau_wave_atmos.F90 create mode 100644 src/ecwam/tauwinds.F90 create mode 100644 tests/etopo1_oper_an_fc_O48_cy50r1_bydbr.yml diff --git a/src/ecwam/CMakeLists.txt b/src/ecwam/CMakeLists.txt index 739484bd6..f928cbd4b 100644 --- a/src/ecwam/CMakeLists.txt +++ b/src/ecwam/CMakeLists.txt @@ -48,6 +48,8 @@ list( APPEND ecwam_srcs abort1.F90 adjust.F90 airsea.F90 + airsea_jan.F90 + airsea_iter.F90 aki.F90 aki_ice.F90 alphap_tail.F90 @@ -112,6 +114,7 @@ list( APPEND ecwam_srcs intrpolchk.F90 intspec.F90 inwgrib.F90 + irange.F90 iwam_get_unit.F90 jafu.F90 jonswap.F90 @@ -120,6 +123,7 @@ list( APPEND ecwam_srcs ktoobs.F90 kurtosis.F90 kzeone.F90 + lfactor.F90 makegrid.F90 mblock.F90 mbounc.F90 @@ -217,6 +221,7 @@ list( APPEND ecwam_srcs sdissip.F90 sdissip_ard.F90 sdissip_jan.F90 + sdissip_bydbr.F90 sdiwbk.F90 sdice.F90 sdice1.F90 @@ -241,6 +246,7 @@ list( APPEND ecwam_srcs sinput.F90 sinput_ard.F90 sinput_jan.F90 + sinput_bydbr.F90 skewness.F90 snonlin.F90 spectra.F90 @@ -252,10 +258,12 @@ list( APPEND ecwam_srcs stress_gc.F90 stresso.F90 strspec.F90 + swldissip_bydbr.F90 tables_2nd.F90 tabu_swellft.F90 tau_phi_hf.F90 taut_z0.F90 + tauwinds.F90 topoar.F90 transf.F90 transf_bfi.F90 diff --git a/src/ecwam/airsea.F90 b/src/ecwam/airsea.F90 index a7ce406bc..39a6b9b34 100644 --- a/src/ecwam/airsea.F90 +++ b/src/ecwam/airsea.F90 @@ -62,6 +62,7 @@ SUBROUTINE AIRSEA (KIJS, KIJL, & USE YOWPHYS, ONLY : XKAPPA, XNLEV USE YOWTEST, ONLY : IU06 USE YOWWIND, ONLY : WSPMIN + USE YOWSTAT, ONLY : IPHYS USE YOMHOOK, ONLY: LHOOK, DR_HOOK, JPHOOK @@ -69,8 +70,8 @@ SUBROUTINE AIRSEA (KIJS, KIJL, & IMPLICIT NONE #include "abort1.intfb.h" -#include "taut_z0.intfb.h" -#include "z0wave.intfb.h" +#include "airsea_jan.intfb.h" +#include "airsea_iter.intfb.h" INTEGER(KIND=JWIM), INTENT(IN) :: KIJS, KIJL, ICODE_WND, IUSFG REAL(KIND=JWRB), DIMENSION(KIJL), INTENT (IN) :: HALP, U10DIR, TAUW, TAUWDIR, RNFAC @@ -87,45 +88,18 @@ SUBROUTINE AIRSEA (KIJS, KIJL, & ! ---------------------------------------------------------------------- IF (LHOOK) CALL DR_HOOK ('AIRSEA', 0, ZHOOK_HANDLE) -!* 2. DETERMINE TOTAL STRESS (if needed) -! ---------------------------------- - - IF (ICODE_WND == 3) THEN - - !$loki inline - CALL TAUT_Z0 (KIJS, KIJL, IUSFG, & - & HALP, U10, U10DIR, TAUW, TAUWDIR, RNFAC, & - & US, Z0, Z0B, CHRNCK) - - ELSEIF (ICODE_WND == 1 .OR. ICODE_WND == 2) THEN - -!$loki remove -!* 3. DETERMINE ROUGHNESS LENGTH (if needed). -! --------------------------- - - !$loki inline - CALL Z0WAVE (KIJS, KIJL, US, TAUW, U10, Z0, Z0B, CHRNCK) - -!* 3. DETERMINE U10 (if needed). -! --------------------------- - - XKAPPAD = 1.0_JWRB / XKAPPA - XLOGLEV = LOG (XNLEV) - - DO IJ = KIJS, KIJL - U10 (IJ) = XKAPPAD * US (IJ) * (XLOGLEV - LOG (Z0 (IJ))) - U10 (IJ) = MAX (U10 (IJ), WSPMIN) - ENDDO - -!$loki end remove - ELSE - WRITE (IU06, * ) ' ++++++++++++++++++++++++++++++++++++++++++' - WRITE (IU06, * ) ' + AIRSEA : INVALID VALUE OF ICODE_WND +' - WRITE (IU06, * ) ' ICODE_WND = ', ICODE_WND - WRITE (IU06, * ) ' ++++++++++++++++++++++++++++++++++++++++++' - CALL ABORT1 - ENDIF - + SELECT CASE (IPHYS) + CASE(0,1) + CALL AIRSEA_JAN (KIJS, KIJL, & +& HALP, U10, U10DIR, TAUW, TAUWDIR, RNFAC, & +& US, Z0, Z0B, CHRNCK, ICODE_WND, IUSFG) + CASE(2) + CALL AIRSEA_ITER(KIJS, KIJL, & + & HALP, U10, U10DIR, TAUW, TAUWDIR, RNFAC, & + & US, Z0, Z0B, CHRNCK, ICODE_WND, IUSFG) + + END SELECT + IF (LHOOK) CALL DR_HOOK ('AIRSEA', 1, ZHOOK_HANDLE) END SUBROUTINE AIRSEA diff --git a/src/ecwam/airsea_iter.F90 b/src/ecwam/airsea_iter.F90 new file mode 100644 index 000000000..e57e11ad5 --- /dev/null +++ b/src/ecwam/airsea_iter.F90 @@ -0,0 +1,199 @@ +! (C) Copyright 1989- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! + + SUBROUTINE AIRSEA_ITER (KIJS, KIJL, & +& HALP, U10, U10DIR, TAUW, TAUWDIR, RNFAC, & +& US, Z0, Z0B, CHRNCK, ICODE_WND, IUSFG) + +! ---------------------------------------------------------------------- + +!**** *AIRSEA_ITER* - DETERMINE TOTAL STRESS IN SURFACE LAYER. + +! P.A.E.M. JANSSEN KNMI AUGUST 1990 +! JEAN BIDLOT ECMWF FEBRUARY 1999 : TAUT is already +! SQRT(TAUT) +! JEAN BIDLOT ECMWF OCTOBER 2004: QUADRATIC STEP FOR +! TAUW + +!* PURPOSE. +! -------- + +! COMPUTE TOTAL STRESS. + +!** INTERFACE. +! ---------- + +! *CALL* *AIRSEA_ITER (KIJS, KIJL, FL1, WAVNUM, +! HALP, U10, U10DIR, TAUW, TAUWDIR, RNFAC, +! US, Z0, Z0B, CHRNCK, ICODE_WND, IUSFG)* + +! *KIJS* - INDEX OF FIRST GRIDPOINT. +! *KIJL* - INDEX OF LAST GRIDPOINT. +! *FL1* - SPECTRA +! *WAVNUM* - WAVE NUMBER +! *HALP* - 1/2 PHILLIPS PARAMETER +! *U10* - WINDSPEED U10. +! *U10DIR* - WINDSPEED DIRECTION. +! *TAUW* - WAVE STRESS. +! *TAUWDIR* - WAVE STRESS DIRECTION. +! *RNFAC* - WIND DEPENDENT FACTOR USED IN THE GROWTH RENORMALISATION. +! *US* - OUTPUT OR OUTPUT BLOCK OF FRICTION VELOCITY. +! *Z0* - OUTPUT BLOCK OF ROUGHNESS LENGTH. +! *Z0B* - BACKGROUND ROUGHNESS LENGTH. +! *CHRNCK* - CHARNOCK COEFFICIENT +! *ICODE_WND* SPECIFIES WHICH OF U10 OR US HAS BEEN FILED UPDATED: +! U10: ICODE_WND=3 --> US will be updated +! US: ICODE_WND=1 OR 2 --> U10 will be updated +! *IUSFG* - IF = 1 THEN USE THE FRICTION VELOCITY (US) AS FIRST GUESS in TAUT_Z0 +! 0 DO NOT USE THE FIELD US + + +! ---------------------------------------------------------------------- + + USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU + + USE YOWPARAM, ONLY : NANG ,NFRE + USE YOWPHYS, ONLY : XKAPPA, XNLEV + USE YOWPCONS, ONLY : G + USE YOWTEST, ONLY : IU06 + USE YOWWIND, ONLY : WSPMIN + + USE YOMHOOK, ONLY: LHOOK, DR_HOOK, JPHOOK + +! ---------------------------------------------------------------------- + IMPLICIT NONE + +#include "abort1.intfb.h" +#include "taut_z0.intfb.h" +#include "z0wave.intfb.h" + + INTEGER(KIND=JWIM), INTENT(IN) :: KIJS, KIJL, ICODE_WND, IUSFG + REAL(KIND=JWRB), DIMENSION(KIJL), INTENT (IN) :: HALP, U10DIR, TAUW, TAUWDIR, RNFAC + REAL(KIND=JWRB), DIMENSION(KIJL), INTENT (INOUT) :: U10, US + REAL(KIND=JWRB), DIMENSION(KIJL), INTENT (OUT) :: Z0, Z0B, CHRNCK + + INTEGER(KIND=JWIM) :: IJ, I, J + + REAL(KIND=JWRB) :: ZNLEV + REAL(KIND=JWRB), PARAMETER :: RKAP = 0.4_JWRB + REAL(KIND=JWRB), PARAMETER :: ZRN=1.65E-6_JWRB ! effective kinematic viscosity (0.11*1.5e-5) + + ! for the ietrative scheme + INTEGER(KIND=JWIM), PARAMETER :: NITER=15 + +! CD=ACD+BCD*U10 + REAL(KIND=JWRB), PARAMETER :: ACD=0.0008_JWRB + REAL(KIND=JWRB), PARAMETER :: BCD=0.00008_JWRB + +! CD = ACDLIN + BCDLIN*SQRT(PCHAR) * U10 + REAL(KIND=JWRB), PARAMETER :: ACDLIN=0.0008_JWRB + REAL(KIND=JWRB), PARAMETER :: BCDLIN=0.00047_JWRB + REAL(KIND=JWRB), PARAMETER :: XEPS=0.00001_JWRB + REAL(KIND=JWRB), PARAMETER :: USTMIN=0.000001_JWRB + REAL(KIND=JWRB), PARAMETER :: PCHARMAX=0.1_JWRB + REAL(KIND=JWRB), PARAMETER :: Z0FG=0.01_JWRB + + INTEGER(KIND=JWIM) :: ITER + REAL(KIND=JWRB) :: XZNLEV, PCHAROG, XKUTOP, XOLOGZ0 + REAL(KIND=JWRB) :: CDLIN, UST, USTOLD, Z0CH, Z0VIS, F, DELF + + REAL(KIND=JWRB) :: XI, XJ, DELI1, DELI2, DELJ1, DELJ2, UST2, ARG, SQRTCDM1 + REAL(KIND=JWRB) :: XKAPPAD, XLOGLEV + REAL(KIND=JWRB) :: XLEV + REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ---------------------------------------------------------------------- + IF (LHOOK) CALL DR_HOOK ('AIRSEA_ITER', 0, ZHOOK_HANDLE) + +!* 2. DETERMINE TOTAL STRESS AND ROUGHNESS (if needed) +! ---------------------------------- + + IF (ICODE_WND == 3) THEN + + !$loki inline + +! Wind height + ZNLEV = 10._JWRB + + DO IJ=KIJS,KIJL + ! -------------------------------------------- + ! Iterative method + + XKUTOP = RKAP*U10(IJ) + + ! Start with old charnock (and protect the scheme) + PCHAROG = MIN(CHRNCK(IJ),PCHARMAX/G) + + ! Cd as a linear relation with slope function of Charnock + CDLIN= ACDLIN + BCDLIN*SQRT(PCHAROG*G) * U10(IJ) + + ! first guess for u* + ! UST = U10(IJ)*SQRT(ACD+BCD*U10(IJ)) ! Use linear approx + ! UST = SQRT(CD)*U10(IJ) ! Use Hersbach approx + UST = SQRT(CDLIN)*U10(IJ) ! Use Hersbach approx + + ! iterate + DO ITER=1,NITER + USTOLD = MAX(UST,USTMIN) + Z0CH = PCHAROG*UST**2 + Z0VIS = ZRN/UST + Z0(IJ) = Z0CH+Z0VIS + XZNLEV = ZNLEV/(ZNLEV+Z0(IJ)) + XOLOGZ0 = 1.0_JWRB/LOG(1.0_JWRB+ZNLEV/Z0(IJ)) + F = UST-XKUTOP*XOLOGZ0 + DELF = 1.0_JWRB-XKUTOP*XOLOGZ0**2*XZNLEV* & + & (2.0_JWRB*Z0CH-Z0VIS)/(UST*Z0(IJ)) + IF(DELF /= 0.0_JWRB) UST = UST-F/DELF + + IF(ABS(UST-USTOLD)<=UST*XEPS .AND. ABS(F)<=XEPS) EXIT + ENDDO + + ! Update Z0, US and then charnock + IF(ITER > NITER) THEN + ! failed to iterate + Z0(IJ) = Z0FG + US(IJ) = XKUTOP/LOG(1.0+ZNLEV/Z0(IJ)) + ELSE + US(IJ) = MAX(UST,USTMIN) + ! Z0(IJ) = Z0CH ! Commented out -> Z0=Z0TOT + ENDIF + + + ENDDO + + ELSEIF (ICODE_WND == 1 .OR. ICODE_WND == 2) THEN + +!* 3. DETERMINE ROUGHNESS LENGTH (if needed). +! --------------------------- + + !$loki inline + CALL Z0WAVE (KIJS, KIJL, US, TAUW, U10, Z0, Z0B, CHRNCK) + +!* 3. DETERMINE U10 (if needed). +! --------------------------- + + XKAPPAD = 1.0_JWRB / XKAPPA + XLOGLEV = LOG (XNLEV) + + DO IJ = KIJS, KIJL + U10 (IJ) = XKAPPAD * US (IJ) * (XLOGLEV - LOG (Z0 (IJ))) + U10 (IJ) = MAX (U10 (IJ), WSPMIN) + ENDDO + + ELSE + WRITE (IU06, * ) ' ++++++++++++++++++++++++++++++++++++++++++' + WRITE (IU06, * ) ' + AIRSEA_ITER : INVALID VALUE OF ICODE_WND +' + WRITE (IU06, * ) ' ICODE_WND = ', ICODE_WND + WRITE (IU06, * ) ' ++++++++++++++++++++++++++++++++++++++++++' + CALL ABORT1 + ENDIF + + IF (LHOOK) CALL DR_HOOK ('AIRSEA_ITER', 1, ZHOOK_HANDLE) + + END SUBROUTINE AIRSEA_ITER diff --git a/src/ecwam/airsea_jan.F90 b/src/ecwam/airsea_jan.F90 new file mode 100644 index 000000000..819152cd6 --- /dev/null +++ b/src/ecwam/airsea_jan.F90 @@ -0,0 +1,129 @@ +! (C) Copyright 1989- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! + + SUBROUTINE AIRSEA_JAN (KIJS, KIJL, & +& HALP, U10, U10DIR, TAUW, TAUWDIR, RNFAC, & +& US, Z0, Z0B, CHRNCK, ICODE_WND, IUSFG) + +! ---------------------------------------------------------------------- + +!**** *AIRSEA_JAN* - DETERMINE TOTAL STRESS IN SURFACE LAYER. + +! P.A.E.M. JANSSEN KNMI AUGUST 1990 +! JEAN BIDLOT ECMWF FEBRUARY 1999 : TAUT is already +! SQRT(TAUT) +! JEAN BIDLOT ECMWF OCTOBER 2004: QUADRATIC STEP FOR +! TAUW + +!* PURPOSE. +! -------- + +! COMPUTE TOTAL STRESS. + +!** INTERFACE. +! ---------- + +! *CALL* *AIRSEA_JAN (KIJS, KIJL, FL1, WAVNUM, +! HALP, U10, U10DIR, TAUW, TAUWDIR, RNFAC, +! US, Z0, Z0B, CHRNCK, ICODE_WND, IUSFG)* + +! *KIJS* - INDEX OF FIRST GRIDPOINT. +! *KIJL* - INDEX OF LAST GRIDPOINT. +! *FL1* - SPECTRA +! *WAVNUM* - WAVE NUMBER +! *HALP* - 1/2 PHILLIPS PARAMETER +! *U10* - WINDSPEED U10. +! *U10DIR* - WINDSPEED DIRECTION. +! *TAUW* - WAVE STRESS. +! *TAUWDIR* - WAVE STRESS DIRECTION. +! *RNFAC* - WIND DEPENDENT FACTOR USED IN THE GROWTH RENORMALISATION. +! *US* - OUTPUT OR OUTPUT BLOCK OF FRICTION VELOCITY. +! *Z0* - OUTPUT BLOCK OF ROUGHNESS LENGTH. +! *Z0B* - BACKGROUND ROUGHNESS LENGTH. +! *CHRNCK* - CHARNOCK COEFFICIENT +! *ICODE_WND* SPECIFIES WHICH OF U10 OR US HAS BEEN FILED UPDATED: +! U10: ICODE_WND=3 --> US will be updated +! US: ICODE_WND=1 OR 2 --> U10 will be updated +! *IUSFG* - IF = 1 THEN USE THE FRICTION VELOCITY (US) AS FIRST GUESS in TAUT_Z0 +! 0 DO NOT USE THE FIELD US + + +! ---------------------------------------------------------------------- + + USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU + + USE YOWPARAM, ONLY : NANG ,NFRE + USE YOWPHYS, ONLY : XKAPPA, XNLEV + USE YOWTEST, ONLY : IU06 + USE YOWWIND, ONLY : WSPMIN + + USE YOMHOOK, ONLY: LHOOK, DR_HOOK, JPHOOK + +! ---------------------------------------------------------------------- + IMPLICIT NONE + +#include "abort1.intfb.h" +#include "taut_z0.intfb.h" +#include "z0wave.intfb.h" + + INTEGER(KIND=JWIM), INTENT(IN) :: KIJS, KIJL, ICODE_WND, IUSFG + REAL(KIND=JWRB), DIMENSION(KIJL), INTENT (IN) :: HALP, U10DIR, TAUW, TAUWDIR, RNFAC + REAL(KIND=JWRB), DIMENSION(KIJL), INTENT (INOUT) :: U10, US + REAL(KIND=JWRB), DIMENSION(KIJL), INTENT (OUT) :: Z0, Z0B, CHRNCK + + INTEGER(KIND=JWIM) :: IJ, I, J + + REAL(KIND=JWRB) :: XI, XJ, DELI1, DELI2, DELJ1, DELJ2, UST2, ARG, SQRTCDM1 + REAL(KIND=JWRB) :: XKAPPAD, XLOGLEV + REAL(KIND=JWRB) :: XLEV + REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ---------------------------------------------------------------------- + IF (LHOOK) CALL DR_HOOK ('AIRSEA_JAN', 0, ZHOOK_HANDLE) + +!* 2. DETERMINE TOTAL STRESS (if needed) +! ---------------------------------- + + IF (ICODE_WND == 3) THEN + + !$loki inline + CALL TAUT_Z0 (KIJS, KIJL, IUSFG, & + & HALP, U10, U10DIR, TAUW, TAUWDIR, RNFAC, & + & US, Z0, Z0B, CHRNCK) + + ELSEIF (ICODE_WND == 1 .OR. ICODE_WND == 2) THEN + +!* 3. DETERMINE ROUGHNESS LENGTH (if needed). +! --------------------------- + + !$loki inline + CALL Z0WAVE (KIJS, KIJL, US, TAUW, U10, Z0, Z0B, CHRNCK) + +!* 3. DETERMINE U10 (if needed). +! --------------------------- + + XKAPPAD = 1.0_JWRB / XKAPPA + XLOGLEV = LOG (XNLEV) + + DO IJ = KIJS, KIJL + U10 (IJ) = XKAPPAD * US (IJ) * (XLOGLEV - LOG (Z0 (IJ))) + U10 (IJ) = MAX (U10 (IJ), WSPMIN) + ENDDO + + ELSE + WRITE (IU06, * ) ' ++++++++++++++++++++++++++++++++++++++++++' + WRITE (IU06, * ) ' + AIRSEA_JAN : INVALID VALUE OF ICODE_WND +' + WRITE (IU06, * ) ' ICODE_WND = ', ICODE_WND + WRITE (IU06, * ) ' ++++++++++++++++++++++++++++++++++++++++++' + CALL ABORT1 + ENDIF + + IF (LHOOK) CALL DR_HOOK ('AIRSEA_JAN', 1, ZHOOK_HANDLE) + + END SUBROUTINE AIRSEA_JAN diff --git a/src/ecwam/calcphiwa.F90 b/src/ecwam/calcphiwa.F90 new file mode 100644 index 000000000..5449e63f2 --- /dev/null +++ b/src/ecwam/calcphiwa.F90 @@ -0,0 +1,57 @@ +FUNCTION CALCPHIWA(SPOS,SNEG,DSII) RESULT(PHIWA) + + ! ---------------------------------------------------------------------------- + ! + ! 1. Purpose : + ! + ! Calculate energy flux from wind into waves, obtained from wind-energy-input (Sin). + ! + ! / FRMAX + ! tau = g * rho_water * | Sin(f) df + ! / + + !---------------------------------------------------------------------- + ! + ! INTERFACE VARIABLES. + ! -------------------- + + ! ORIGIN. + ! ---------- + ! Adapted from TAUWINDS + ! Implementation into ECWAM DECEMBER 2021 by J. Kousal + + ! ---------------------------------------------------------------------------- + ! + + USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU + USE YOWPCONS , ONLY : G ,ROWATER + USE YOWFRED , ONLY : DELTH + USE YOWPARAM , ONLY : NANG ,NFRE + USE YOMHOOK , ONLY : LHOOK, DR_HOOK + + !---------------------------------------------------------------------- + + IMPLICIT NONE + + REAL(KIND=JWRB), DIMENSION(NANG,NFRE), INTENT(IN) :: SPOS ! POS Sin(sigma) in [m2/rad-Hz] + REAL(KIND=JWRB), DIMENSION(NANG,NFRE), INTENT(IN) :: SNEG ! NEG Sin(sigma) in [m2/rad-Hz] + REAL(KIND=JWRB), DIMENSION(NFRE), INTENT(IN) :: DSII ! freq. bandwidths in [radians] + + REAL(KIND=JWRB), DIMENSION(NFRE) :: SPOSDENSIG, SNEGDENSIG + + REAL(KIND=JWRB) :: PHIWA + REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + + ! ---------------------------------------------------------------------------- + ! + + IF (LHOOK) CALL DR_HOOK('CALCPHIWA',0,ZHOOK_HANDLE) + + SPOSDENSIG = SUM(SPOS,1) * DELTH + SNEGDENSIG = SUM(SNEG,1) * DELTH + PHIWA = G * ROWATER * ( SUM(SPOSDENSIG*DSII) + SUM(SNEGDENSIG*DSII) ) + + IF (LHOOK) CALL DR_HOOK('CALCPHIWA',1,ZHOOK_HANDLE) + + END FUNCTION CALCPHIWA + \ No newline at end of file diff --git a/src/ecwam/irange.F90 b/src/ecwam/irange.F90 new file mode 100644 index 000000000..861d9cf9f --- /dev/null +++ b/src/ecwam/irange.F90 @@ -0,0 +1,52 @@ +FUNCTION IRANGE(X0,X1,DX) RESULT(IX) + + ! ---------------------------------------------------------------------------- + ! + ! 1. Purpose : + ! + ! Generate a sequence of linear-spaced integer numbers. + ! Used for instance array addressing (indexing). + ! ---------------------------------------------------------------------------- + ! + ! INTERFACE VARIABLES. + ! -------------------- + + ! ORIGIN. + ! ---------- + ! Adapted from Babanin Young Donelan & Banner (BYDB) physics + ! as implemented as ST6 in WAVEWATCH-III + ! WW3 module: W3SRC6MD + ! WW3 subroutine: IRANGE + ! Implementation into ECWAM DECEMBER 2021 by J. Kousal + + ! ---------------------------------------------------------------------------- + + USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU + USE YOMHOOK , ONLY : LHOOK ,DR_HOOK, JPHOOK + + ! ---------------------------------------------------------------------------- + + IMPLICIT NONE + + INTEGER(KIND=JWIM), INTENT(IN) :: X0, X1, DX + + INTEGER(KIND=JWIM), ALLOCATABLE :: IX(:) + INTEGER(KIND=JWIM) :: N, I + + REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + + ! ---------------------------------------------------------------------------- + ! + + IF (LHOOK) CALL DR_HOOK('IRANGE',0,ZHOOK_HANDLE) + + N = INT(REAL(X1-X0)/REAL(DX))+1 + ALLOCATE(IX(N)) + DO I = 1, N + IX(I) = X0+ (I-1)*DX + END DO + + IF (LHOOK) CALL DR_HOOK('IRANGE',1,ZHOOK_HANDLE) + + END FUNCTION IRANGE + \ No newline at end of file diff --git a/src/ecwam/lfactor.F90 b/src/ecwam/lfactor.F90 new file mode 100644 index 000000000..46b89e27c --- /dev/null +++ b/src/ecwam/lfactor.F90 @@ -0,0 +1,285 @@ +! (C) Copyright 1989- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. + + SUBROUTINE LFACTOR(S, CINV, U10, USTAR, USDIR, ROAIRN, SIG, DSII, & + & LFACT, TAUWX, TAUWY, TAU) + +! ---------------------------------------------------------------------------- +! +! 1. Purpose : +! +! Numerical approximation for the reduction factor LFACTOR(f) to +! reduce energy in the high-frequency part of the resolved part +! of the spectrum to meet the constraint on total stress (TAU). +! The constraint is TAU <= TAU_TOT (TAU_TOT = TAU_WAV + TAU_VIS), +! thus the wind input is reduced to match our constraint. +! +! 2. Method : +! +! 1) If required, extend resolved part of the spectrum to 10Hz using +! an approximation for the spectral slope at the high frequency +! limit: Sin(F) prop. F**(-2) and for E(F) prop. F**(-5). +! 2) Calculate stresses: +! total stress: TAU_TOT = DAIR * USTAR**2 +! viscous stress: TAU_VIS = DAIR * Cv * U10**2 +! viscous stress (x,y-components): +! TAUV_X = TAU_VIS * COS(USDIR) +! TAUV_Y = TAU_VIS * SIN(USDIR) +! wave supported stress (x,y-components): /10Hz +! TAUW_X,Y = GRAV * DWAT * | [SinX,Y(F)]/C(F) dF +! / +! total stress (input): TAU = SQRT( (TAUW_X + TAUV_X)**2 +! + (TAUW_Y + TAUV_Y)**2 ) +! 3) If TAU does not meet our constraint reduce the wind input +! using reduction factor: +! LFACT(F) = MIN(1,exp((1-U/C(F))*RTAU)) +! Then alter RTAU and repeat 3) until our constraint is matched. +! +! ---------------------------------------------------------------------------- +! +!** INTERFACE. +! ---------- + +! *CALL* *LFACTOR(S, CINV, U10, USTAR, USDIR, ROAIRN, SIG, DSII, & +! & LFACT, TAUWX, TAUWY, TAU) +! *S* - NEG. WIND INPUT ENERGY DENSITY SPECTRUM. +! *CINV* - INVERSE PHASE SPEED CALC. IN INPUT ROUTINE +! *UABS* - 10M WIND SPEED +! *USTAR* - NEW FRICTION VELOCITY IN M/S. +! *USDIR* - WIND DIRECTION +! *ROAIRN* - AIR DENSITY IN KG/M3 +! *SIG* - FREQ (RAD) +! *DSII* - ZPI*DF +! *LFACT* - CORRECTION FACTOR +! *TAUNWX, TAUNWY* - NEGATIVE WAVE NORMAL STRESS COMPONENTS + +! EXTERNALS. +! ---------- +! TAUWINDS +! IRANGE + +! ORIGIN. +! ---------- +! Adapted from Babanin Young Donelan & Banner (BYDB) physics +! as implemented as ST6 in WAVEWATCH-III +! WW3 module: W3SRC6MD +! WW3 subroutine: LFACTOR +! Implementation into ECWAM DECEMBER 2021 by J. Kousal + +! ---------------------------------------------------------------------- + USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU + + USE YOWFRED , ONLY : FR ,TH ,DFIM ,COSTH ,SINTH,& +& FRATIO ,DELTH ,FRIC + USE YOWMPP , ONLY : NINF ,NSUP + USE YOWPARAM , ONLY : NANG ,NFRE + USE YOWPCONS , ONLY : G ,ZPI ,ROWATER ,EPSMIN + USE YOWPHYS , ONLY : BETAMAX ,ZALP ,TAUWSHELTER, XKAPPA, RNU ,RNUM, CDFAC + USE YOWSTAT , ONLY : ISHALLO + USE YOWTABL , ONLY : IAB ,SWELLFT + USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK + +! ---------------------------------------------------------------------- + + IMPLICIT NONE +#include "irange.intfb.h" +#include "tauwinds.intfb.h" + + REAL(KIND=JWRB), DIMENSION(NANG,NFRE), INTENT(IN) :: S + REAL(KIND=JWRB), DIMENSION(NFRE), INTENT(IN) :: CINV, SIG, DSII + REAL(KIND=JWRB), INTENT(IN) :: U10, USTAR, USDIR, ROAIRN + + REAL(KIND=JWRB), DIMENSION(NFRE), INTENT(OUT) :: LFACT + REAL(KIND=JWRB), INTENT(OUT) :: TAUWX, TAUWY, TAU + + REAL(KIND=JWRB), PARAMETER :: FRQMAX = 10.0_JWRB ! Upper freq. limit to extrap. to + REAL(KIND=JWRB), PARAMETER :: SIN6WS = 32.0_JWRB ! ST6 PARAM + INTEGER(KIND=JWIM), PARAMETER :: ITERMAX = 80 ! Max. no. iterations + ! to find numerical LFACT soln + + REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: ECOS2, ESIN2 + REAL, ALLOCATABLE :: IK10Hz(:), LF10Hz(:), SIG10Hz(:), CINV10Hz(:) + REAL, ALLOCATABLE :: SDENS10Hz(:), SDENSX10Hz(:), SDENSY10Hz(:) + REAL, ALLOCATABLE :: DSII10Hz(:), UCINV10Hz(:) + + REAL(KIND=JWRB) :: TAU_TOT, TAU_VIS, TAU_WAV + REAL(KIND=JWRB) :: TAUVX, TAUVY, TAUX, TAUY + REAL(KIND=JWRB) :: TAU_NND, TAU_INIT(2) + REAL(KIND=JWRB) :: UPROXY, RTAU, DRTAU, ERR + LOGICAL :: OVERSHOT + CHARACTER(LEN=23) :: IDTIME + + INTEGER(KIND=JWIM) :: IK, ITH, NK10Hz, M, SIGN_NEW, SIGN_OLD + INTEGER(KIND=JWIM) :: NK, NTH, NSPEC !num. of freqs, dirs, spec. bins + INTEGER(KIND=JWIM), DIMENSION(NANG) :: ITHN + INTEGER(KIND=JWIM), DIMENSION(NFRE) :: IKN + + REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ---------------------------------------------------------------------- + + IF (LHOOK) CALL DR_HOOK('LFACTOR',0,ZHOOK_HANDLE) + + NTH = NANG ! NUMBER OF DIRS , SAME AS KL + NK = NFRE ! NUMBER OF FREQS, SAME AS ML + NSPEC = NK * NTH ! NUMBER OF SPECTRAL BINS + +!/ 0) --- Find the number of frequencies required to extend arrays +!/ up to f=10Hz and allocate arrays --------------------------- / +!/ ALOG is the same as LOG + NK10Hz = CEILING(ALOG(FRQMAX/(SIG(1)/ZPI))/ALOG(FRATIO))+1 + NK10Hz = MAX(NK,NK10Hz) +! + ALLOCATE(IK10Hz(NK10Hz)) + IK10Hz = REAL( IRANGE(1,NK10Hz,1) ) +! + ALLOCATE(SIG10Hz(NK10Hz)) + ALLOCATE(CINV10Hz(NK10Hz)) + ALLOCATE(DSII10Hz(NK10Hz)) + ALLOCATE(LF10Hz(NK10Hz)) + ALLOCATE(SDENS10Hz(NK10Hz)) + ALLOCATE(SDENSX10Hz(NK10Hz)) + ALLOCATE(SDENSY10Hz(NK10Hz)) + ALLOCATE(UCINV10Hz(NK10Hz)) +! + ITHN = IRANGE(1,NTH,1) ! Index vector 1:NTH + DO IK = 1, NK + ECOS2 (ITHN+(IK-1)*NTH) = COSTH + ESIN2 (ITHN+(IK-1)*NTH) = SINTH + END DO + + +! +!/ 1) --- Either extrapolate arrays up to 10Hz or use discrete spectral +! grid per se. Limit the constraint to the positive part of the +! wind input only. ---------------------------------------------- / + IF (NK .LT. NK10Hz) THEN + SDENS10Hz(1:NK) = SUM(S,1) * DELTH + SDENSX10Hz(1:NK) = SUM(MAX(0.0_JWRB,S)*& + & RESHAPE(ECOS2,(/NTH,NK/)),1) * DELTH + SDENSY10Hz(1:NK) = SUM(MAX(0.0_JWRB,S)*& + & RESHAPE(ESIN2,(/NTH,NK/)),1) * DELTH + SIG10Hz = SIG(1)*FRATIO**(IK10Hz-1.0_JWRB) + CINV10Hz(1:NK) = CINV + CINV10Hz(NK+1:NK10Hz) = SIG10Hz(NK+1:NK10Hz)*0.101978_JWRB ! 1/c=σ/g + DSII10Hz = 0.5_JWRB * SIG10Hz * (FRATIO-1.0_JWRB/FRATIO) +! The first and last frequency bin: + DSII10Hz(1) = 0.5_JWRB * SIG10Hz(1) * (FRATIO-1.0_JWRB) + DSII10Hz(NK10Hz) = 0.5_JWRB * SIG10Hz(NK10Hz) * (FRATIO-1.0_JWRB) / FRATIO +! +! --- Spectral slope for S_IN(F) is proportional to F**(-2) ------ / + SDENS10Hz(NK+1:NK10Hz) = SDENS10Hz(NK) * (SIG10Hz(NK)/SIG10Hz(NK+1:NK10Hz))**2 + SDENSX10Hz(NK+1:NK10Hz) = SDENSX10Hz(NK) * (SIG10Hz(NK)/SIG10Hz(NK+1:NK10Hz))**2 + SDENSY10hz(NK+1:NK10Hz) = SDENSY10Hz(NK) * (SIG10Hz(NK)/SIG10Hz(NK+1:NK10Hz))**2 + ELSE + SIG10Hz = SIG + CINV10Hz = CINV + DSII10Hz = DSII + SDENS10Hz(1:NK) = SUM(S,1) * DELTH + SDENSX10Hz(1:NK) = SUM(MAX(0.0_JWRB,S)*RESHAPE(ECOS2,(/NTH,NK/)),1) * DELTH + SDENSY10Hz(1:NK) = SUM(MAX(0.0_JWRB,S)*RESHAPE(ESIN2,(/NTH,NK/)),1) * DELTH + END IF +! +!/ 2) --- Stress calculation ----------------------------------------- / +! --- The total stress ------------------------------------------- / + TAU_TOT = USTAR**2 * ROAIRN +! +! --- The viscous stress and check that it does not exceed +! the total stress. ------------------------------------------ / + TAU_VIS = MAX(0.0_JWRB, -5.0E-5_JWRB*U10 + 1.1E-3_JWRB) * U10**2 * ROAIRN +! TAU_VIS = MIN(0.9 * TAU_TOT, TAU_VIS) + TAU_VIS = MIN(0.95_JWRB * TAU_TOT, TAU_VIS) +! + TAUVX = TAU_VIS * COS(USDIR) + TAUVY = TAU_VIS * SIN(USDIR) +! +! --- The wave supported stress. --------------------------------- / + TAUWX = TAUWINDS(SDENSX10Hz,CINV10Hz,DSII10Hz) ! normal stress (x-component) + TAUWY = TAUWINDS(SDENSY10Hz,CINV10Hz,DSII10Hz) ! normal stress (y-component) + TAU_NND = TAUWINDS(SDENS10Hz, CINV10Hz,DSII10Hz) ! normal stress (non-directional) + TAU_WAV = SQRT(TAUWX**2 + TAUWY**2) ! normal stress (magnitude) + TAU_INIT = (/TAUWX,TAUWY/) ! unadjusted normal stress components +! + TAUX = TAUVX + TAUWX ! total stress (x-component) + TAUY = TAUVY + TAUWY ! total stress (y-component) + TAU = SQRT(TAUX**2 + TAUY**2) ! total stress (magnitude) + ERR = (TAU-TAU_TOT)/TAU_TOT ! initial error +! +!/ 3) --- Find reduced Sin(f) = L(f)*Sin(f) to satisfy our constraint +!/ TAU <= TAU_TOT --------------------------------------------- / + !CALL STME21 ( TIME , IDTIME ) + LF10Hz = 1.0_JWRB + IK = 0 +! + IF (TAU .GT. TAU_TOT) THEN + OVERSHOT = .FALSE. + RTAU = ERR / 90.0_JWRB + DRTAU = 2.0_JWRB + SIGN_NEW = INT(SIGN(1.0_JWRB,ERR)) + + UPROXY = FRIC * CDFAC * USTAR + UCINV10Hz = 1.0_JWRB - (UPROXY * CINV10Hz) +! +!/T6 WRITE (NDST,270) IDTIME, U10 +!/T6 WRITE (NDST,271) + DO IK=1,ITERMAX + LF10Hz = MIN(1.0_JWRB, EXP(UCINV10Hz * RTAU) ) +! + TAU_NND = TAUWINDS(SDENS10Hz *LF10Hz,CINV10Hz,DSII10Hz) + TAUWX = TAUWINDS(SDENSX10Hz*LF10Hz,CINV10Hz,DSII10Hz) + TAUWY = TAUWINDS(SDENSY10Hz*LF10Hz,CINV10Hz,DSII10Hz) + TAU_WAV = SQRT(TAUWX**2 + TAUWY**2) +! + TAUX = TAUVX + TAUWX + TAUY = TAUVY + TAUWY + TAU = SQRT(TAUX**2 + TAUY**2) + ERR = (TAU-TAU_TOT) / TAU_TOT +! + SIGN_OLD = SIGN_NEW + SIGN_NEW = INT(SIGN(1.0_JWRB, ERR)) +!/T6 WRITE (NDST,272) IK, RTAU, DRTAU, TAU, TAU_TOT, ERR, & +!/T6 TAUWX, TAUWY, TAUVX, TAUVY, TAU_NND +! +! --- Slow down DRTAU when overshot. -------------------------- / + IF (SIGN_NEW .NE. SIGN_OLD) OVERSHOT = .TRUE. + IF (OVERSHOT) DRTAU = MAX(0.5_JWRB*(1.0_JWRB+DRTAU),1.00010_JWRB) +! + RTAU = RTAU * (DRTAU**SIGN_NEW) +! + IF (ABS(ERR) .LT. 1.54E-4_JWRB) EXIT + END DO +! +! IF (IK .GE. ITERMAX) WRITE (NDST,280) IDTIME(1:19), U10, TAU, & +! TAU_TOT, ERR, TAUWX, TAUWY, TAUVX, TAUVY,TAU_NND + END IF +! + LFACT(1:NK) = LF10Hz(1:NK) +! +!/T6 WRITE (NDST,273) 'Sin ', IDTIME(1:19), SDENS10Hz*TPI +!/T6 WRITE (NDST,273) 'SinR', IDTIME(1:19), SDENS10Hz*LF10Hz*TPI +!/T6 WRITE (NDST,274) 'Sin ', SUM(SDENS10Hz(1:NK)*DSII) +!/T6 WRITE (NDST,274) 'SinR ', SUM(SDENS10Hz(1:NK)*LF10Hz(1:NK)*DSII) +!/T6 WRITE (NDST,274) 'SinR/C', TAUWINDS(SDENS10Hz(1:NK)*LFACT,CINV,DSII) +! +!/T6 270 FORMAT (' TEST W3SIN6 : LFACTOR SUBROUTINE CALCULATING FOR ', & +!/T6 A,' U10=',F5.1 ) +!/T6 271 FORMAT (' TEST W3SIN6 : IK RTAU DRTAU TAU TAU_TOT' & +!/T6 ' ERR TAUW_X TAUW_Y TAUV_X TAUV_Y TAU1D' ) +!/T6 272 FORMAT (' TEST W3SIN6 : ',I2,2F9.5,2F8.5,E10.2,4F7.4,F7.3 ) +!/T6 273 FORMAT (' TEST W3SIN6 : ',A,'(',A,'):', 70E11.3 ) +! 274 FORMAT (' TEST W3SIN6 : Total ',A,' =', E13.5 ) +! 280 FORMAT (' WARNING LFACTOR (TIME,U10,TAU,TAU_TOT,ERR,TAUW_XY,' & +! 'TAUV_XY,TAU_SCALAR): ',A,F6.1,2F7.4,E10.3,4F7.4,F7.3 ) +! + DEALLOCATE(IK10Hz,SIG10Hz,CINV10Hz,DSII10Hz,LF10Hz) + DEALLOCATE(SDENS10Hz,SDENSX10Hz,SDENSY10Hz,UCINV10Hz) + + + IF (LHOOK) CALL DR_HOOK('LFACTOR',1,ZHOOK_HANDLE) + + END SUBROUTINE LFACTOR diff --git a/src/ecwam/sdissip.F90 b/src/ecwam/sdissip.F90 index d1ad3d5a4..41e698303 100644 --- a/src/ecwam/sdissip.F90 +++ b/src/ecwam/sdissip.F90 @@ -58,6 +58,8 @@ SUBROUTINE SDISSIP (KIJS, KIJL, FL1, FLD, SL, & #include "sdissip_ard.intfb.h" #include "sdissip_jan.intfb.h" +#include "sdissip_bydbr.intfb.h" +#include "swldissip_bydbr.intfb.h" INTEGER(KIND=JWIM), INTENT(IN) :: KIJS, KIJL REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(IN) :: FL1 @@ -85,7 +87,15 @@ SUBROUTINE SDISSIP (KIJS, KIJL, FL1, FLD, SL, & CALL SDISSIP_ARD (KIJS, KIJL, FL1 ,FLD, SL, & & WAVNUM, CGROUP, XK2CG, & & UFRIC, COSWDIF, RAORW) - END SELECT + CASE(2) + !$loki inline + CALL SDISSIP_BYDBR (KIJS, KIJL, FL1 ,FLD, SL, & + & WAVNUM, CGROUP, XK2CG, & + & UFRIC, COSWDIF, RAORW) + CALL SWLDISSIP_BYDBR(KIJS, KIJL, FL1 ,FLD, SL, & + & WAVNUM, CGROUP, XK2CG, & + & UFRIC, COSWDIF, RAORW) + END SELECT IF (LHOOK) CALL DR_HOOK('SDISSIP',1,ZHOOK_HANDLE) diff --git a/src/ecwam/sdissip_bydbr.F90 b/src/ecwam/sdissip_bydbr.F90 new file mode 100644 index 000000000..2781ea033 --- /dev/null +++ b/src/ecwam/sdissip_bydbr.F90 @@ -0,0 +1,271 @@ +! (C) Copyright 1989- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! + + SUBROUTINE SDISSIP_BYDBR (KIJS, KIJL, FL1, FLD, SL, & + & WAVNUM, CGROUP, XK2CG, & + & UFRIC, COSWDIF, RAORW) +! ---------------------------------------------------------------------- + +!**** *SDISSIP_BYDBR* - COMPUTATION OF DISSIPATION SOURCE FUNCTION. + +! LOTFI AOUF METEO FRANCE 2013 +! FABRICE ARDHUIN IFREMER 2013 + + +!* PURPOSE. +! -------- +! Observation-based source term for dissipation after Babanin et al. +! (2010) following the implementation by Rogers et al. (2012). The +! dissipation function Sds accommodates an inherent breaking term T1 +! and an additional cumulative term T2 at all frequencies above the +! peak. The forced dissipation term T2 is an integral that grows +! toward higher frequencies and dominates at smaller scales +! (Babanin et al. 2010). +! +!** INTERFACE. +! ---------- + +! *CALL* *SDISSIP_BYDBR (KIJS, KIJL, FL1, FLD,SL,* +! WAVNUM, CGROUP, XK2CG, +! UFRIC, COSWDIF, RAORW)* +! *KIJS* - INDEX OF FIRST GRIDPOINT +! *KIJL* - INDEX OF LAST GRIDPOINT +! *FL1* - SPECTRUM. +! *FLD* - DIAGONAL MATRIX OF FUNCTIONAL DERIVATIVE +! *SL* - TOTAL SOURCE FUNCTION ARRAY +! *WAVNUM* - WAVE NUMBER +! *CGROUP* - GROUP SPEED +! *XK2CG* - (WAVE NUMBER)**2 * GROUP SPEED +! *UFRIC* - FRICTION VELOCITY IN M/S. +! *RAORW* - RATIO AIR DENSITY TO WATER DENSITY +! *COSWDIF*- COS(TH(K)-WDWAVE(IJ)) + + +! METHOD. +! ------- + +! SEE REFERENCES. + +! EXTERNALS. +! ---------- + +! IRANGE + +! REFERENCE. +! ---------- + +! Babanin et al. 2010: JPO 40(4), 667-683 +! Rogers et al. 2012: JTECH 29(9) 1329-1346 + +! ORIGIN. +! ---------- +! Adapted from Babanin Young Donelan & Banner (BYDB) physics +! as implemented as ST6 in WAVEWATCH-III +! WW3 module: W3SRC6MD +! WW3 subroutine: W3SDS6 +! Implementation into ECWAM DECEMBER 2021 by J. Kousal + + +! ---------------------------------------------------------------------- + USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU + + USE YOWFRED , ONLY : FR , TH ,ZPIFR ,FRATIO ,DELTH, DFIM + USE YOWPCONS , ONLY : G ,ZPI + USE YOWPARAM , ONLY : NANG ,NFRE + USE YOWPHYS , ONLY : SDSBR ,ISDSDTH ,ISB ,IPSAT , & +& SSDSC2 , SSDSC4, SSDSC6, MICHE, SSDSC3, SSDSBRF1, & +& BRKPBCOEF ,SSDSC5, NSDSNTH, & +& INDICESSAT, SATWEIGHTS + + USE YOMHOOK , ONLY : LHOOK ,DR_HOOK, JPHOOK + +! ---------------------------------------------------------------------- + + IMPLICIT NONE +#include "irange.intfb.h" + + INTEGER(KIND=JWIM), INTENT(IN) :: KIJS, KIJL + + REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(IN) :: FL1 + REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(INOUT) :: FLD, SL + REAL(KIND=JWRB), DIMENSION(KIJL,NFRE), INTENT(IN) :: WAVNUM, CGROUP, XK2CG + REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: UFRIC, RAORW + REAL(KIND=JWRB), DIMENSION(KIJL, NANG), INTENT(IN) :: COSWDIF + + INTEGER(KIND=JWIM) :: IJ, K, M, I, J, M2, K2, NANGD + INTEGER(KIND=JWIM) :: NSPEC !num. of freqs, dirs, spec. bins + INTEGER(KIND=JWIM), DIMENSION(NANG) :: ITHN + INTEGER(KIND=JWIM), DIMENSION(NFRE) :: IKN + + REAL(KIND=JWRB), PARAMETER :: SDS6A1 = 4.75E-6_JWRB ! ST6 PARAM + REAL(KIND=JWRB), PARAMETER :: SDS6A2 = 7.00E-5_JWRB ! ST6 PARAM + INTEGER(KIND=JWIM), PARAMETER :: SDS6P1 = 4 ! ST6 PARAM + INTEGER(KIND=JWIM), PARAMETER :: SDS6P2 = 4 ! ST6 PARAM + LOGICAL, PARAMETER :: SDS6ET = .TRUE. ! ST6 PARAM + + REAL(KIND=JWRB), DIMENSION(NFRE) :: FREQ ! frequencies [Hz] + REAL(KIND=JWRB), DIMENSION(NFRE) :: SIG ! frequencies [RAD] + REAL(KIND=JWRB), DIMENSION(NFRE) :: DFII ! frequency bandwiths [Hz] + REAL(KIND=JWRB), DIMENSION(NFRE) :: ANAR ! directional narrowness + REAL(KIND=JWRB), DIMENSION(NFRE) :: EDENS ! spectral density E(f) + REAL(KIND=JWRB), DIMENSION(NFRE) :: ETDENS ! threshold spec. density ET(f) + REAL(KIND=JWRB), DIMENSION(NFRE) :: EXDENS ! excess spectral density EX(f) + REAL(KIND=JWRB), DIMENSION(NFRE) :: NEXDENS! normalised excess spec.dens. + REAL(KIND=JWRB), DIMENSION(NFRE) :: T1 ! inherent breaking term + REAL(KIND=JWRB), DIMENSION(NFRE) :: T2 ! forced dissipation term + REAL(KIND=JWRB), DIMENSION(NFRE) :: T12 ! =T1+T2 or combined dissipation + REAL(KIND=JWRB), DIMENSION(NFRE) :: ADF ! temporary variable + REAL(KIND=JWRB), DIMENSION(NFRE) :: DF ! FREQUENCY INTERVALS + REAL(KIND=JWRB) :: BNT ! empirical constant for wave breaking probability + REAL(KIND=JWRB) :: XFAC, EDENSMAX ! temporary variableis + + REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: S, D, A + REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: SIG2, CG2 + REAL(KIND=JWRB), DIMENSION(NANG,NFRE) :: DDS + + + REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: XK, CGG_WAM + REAL(KIND=JWRB), DIMENSION(NFRE) :: SIGP2 + + + REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ---------------------------------------------------------------------- + + IF (LHOOK) CALL DR_HOOK('SDISSIP_BYDBR',0,ZHOOK_HANDLE) + + NSPEC = NANG * NFRE ! NUMBER OF SPECTRAL BINS + + DO M = 1,NFRE + SIG(M) = ZPI*FR(M) + SIGP2(M) = SIG(M)**2 + END DO + +! ! INVERSE OF PHASE VELOCITIES AND WAVE NUMBER. +! IF (ISHALLO.EQ.1) THEN ! -> DEEP WATER +! DO M=1,NFRE +! DO IJ=IJS,IJL +! XK(IJ,M) = SIGP2(M)/G ! INVERSE PHASE VEL. +! CGG_WAM(IJ,M)=G/(2.0_JWRB*SIG(M)) ! GROUP VEL. +! ENDDO +! ENDDO +! ELSE ! -> SHALLOW WATER +! DO M=1,NFRE +! DO IJ=IJS,IJL +! XK(IJ,M) = TFAK(INDEP(IJ),M) ! WAVENUMBER +! CGG_WAM(IJ,M)= TCGOND(INDEP(IJ),M) ! GROUP VEL. +! ENDDO +! ENDDO +! ENDIF + +! TODO: confirm that I'm using exactly the same things here (I've now adopted them throughout the BYDBR code) +! - confirm CGG_WAM=CGROUP +! - confirm XK=WAVNUM + + +! COMPUTE FREQUENCY INTERVALLS (borrowed from Wam_others/f4spec.F) + DO M = 1,NFRE + DF(M) = FR(M)*( FRATIO - 1.0_JWRB ) + ENDDO + + IKN = IRANGE(1,NSPEC,NANG) ! Index vector for elements of 1 ... NFRE +! ! such that e.g. SIG(1:NFRE) = SIG2(IKN). + DO K = 1, NANG ! Apply to all directions + SIG2 (IKN+(K-1)) = SIG + END DO + + + ! LOOP OVER LOCATIONS + DO IJ = KIJS,KIJL + + DO K = 1, NANG ! Apply to all directions + CG2 (IKN+(K-1)) = CGROUP(IJ,:) + END DO + + A = RESHAPE( FL1(IJ,:,:) , (/NSPEC/)) * CG2 / ( ZPI * SIG2 )! ACTION DENSITY SPECTRUM + ! WAM E(f,theta) to WW3 A(k,theta) conversion factor: CG2 / ( ZPI *SIG2 ) + +!/ 0) --- Initialize essential parameters ---------------------------- / + IKN = IRANGE(1,NSPEC,NANG) ! Index vector for elements of 1, +! ! 2,..., NFRE such that for example +! ! SIG(1:NFRE) = SIG2(IKN). + FREQ = FR(1:NFRE) + ANAR = 1.0_JWRB + BNT = 0.035_JWRB**2 + T1 = 0.0_JWRB + T2 = 0.0_JWRB + NEXDENS = 0.0_JWRB +! +!/ 1) --- Calculate threshold spectral density, spectral density, and +!/ the level of exceedence EXDENS(f) -------------------------- / +! ETDENS = ( ZPI * BNT ) / ( ANAR * CGG(IJ,:) * WN(IJ,:)**3 ) + ETDENS = ( ZPI * BNT ) / ( ANAR * CGROUP(IJ,:) * WAVNUM(IJ,:)**3 ) + !EDENS = SUM(FL1(IJ,:,:),1) * ZPI * SIG * DELTH / CGG(IJ,:) !E(f) + EDENS = SUM(FL1(IJ,:,:),1) * DELTH !E(f) + EXDENS = MAX(0.0_JWRB,EDENS-ETDENS) +! +!/ --- normalise by a generic spectral density -------------------- / + IF (SDS6ET) THEN ! ww3_grid.inp: &SDS6 SDSET = T or F + NEXDENS = EXDENS / ETDENS ! normalise by threshold spectral density + ELSE ! normalise by spectral density + EDENSMAX = MAXVAL(EDENS)*1.0E-5_JWRB + IF (ALL(EDENS .GT. EDENSMAX)) THEN + NEXDENS = EXDENS / EDENS + ELSE + DO M = 1,NFRE + IF (EDENS(M) .GT. EDENSMAX) NEXDENS(M) = EXDENS(M) / EDENS(M) + END DO + END IF + END IF +! +!/ 2) --- Calculate inherent breaking component T1 ------------------- / + T1 = SDS6A1 * ANAR * FREQ * (NEXDENS**SDS6P1) +! +!/ 3) --- Calculate T2, the dissipation of waves induced by +!/ the breaking of longer waves T2 ---------------------------- / + ADF = ANAR * (NEXDENS**SDS6P2) + XFAC = (1.0_JWRB-1.0_JWRB/FRATIO)/(FRATIO-1.0_JWRB/FRATIO) + DO M = 1,NFRE + DFII(M) = DF(M) ! bug fix (spotted by Heinz): brought init into loc loop +! IF (M .GT. 1) DFII(M) = DFII(M) * XFAC + IF (M .GT. 1 .AND. M .LT. NFRE) DFII(M) = DFII(M) * XFAC + T2(M) = SDS6A2 * SUM( ADF(1:M)*DFII(1:M) ) + END DO + +!/ 4) --- Sum up dissipation terms and apply to all directions ------- / + T12 = -1.0_JWRB * ( MAX(0.0_JWRB,T1)+MAX(0.0_JWRB,T2) ) + DO K = 1, NANG + D(IKN+(K-1)) = T12 + END DO +! + !S = D * A +! +!/ 5) --- Diagnostic output (switch !/T6) ---------------------------- / +!/T6 CALL STME21 ( TIME , IDTIME ) +!/T6 WRITE (NDST,270) 'T1*E',IDTIME(1:19),(T1*EDENS) +!/T6 WRITE (NDST,270) 'T2*E',IDTIME(1:19),(T2*EDENS) +!/T6 WRITE (NDST,271) SUM(SUM(RESHAPE(S,(/ NANG,NFRE /)),1)*DDEN/CG) +! +!/T6 270 FORMAT (' TEST W3SDS6 : ',A,'(',A,')',':',70E11.3) +!/T6 271 FORMAT (' TEST W3SDS6 : Total SDS =',E13.5) + + DDS = RESHAPE(D,(/NANG,NFRE/)) + DO M = 1,NFRE + DO K = 1, NANG + SL(IJ,K,M) = SL(IJ,K,M) + DDS(K,M)*FL1(IJ,K,M) + FLD(IJ,K,M) = FLD(IJ,K,M) + DDS(K,M) + END DO + END DO + + END DO + ! END LOOP OVER LOC + + IF (LHOOK) CALL DR_HOOK('SDISSIP_BYDBR',1,ZHOOK_HANDLE) + + END SUBROUTINE SDISSIP_BYDBR diff --git a/src/ecwam/setwavphys.F90 b/src/ecwam/setwavphys.F90 index 02c1028ce..873bc486e 100644 --- a/src/ecwam/setwavphys.F90 +++ b/src/ecwam/setwavphys.F90 @@ -26,7 +26,7 @@ SUBROUTINE SETWAVPHYS & DELTA_THETA_RN, RN1_RN, DTHRN_A, DTHRN_U, & & ANG_GC_A, ANG_GC_B, ANG_GC_C, & & SWELLF4, SWELLF7, SWELLF7M1, Z0TUBMAX, Z0RAT, & - & SSDSC5 + & SSDSC5, CDFAC USE YOWSTAT , ONLY : IPHYS USE YOWTEST , ONLY : IU06 @@ -201,6 +201,33 @@ SUBROUTINE SETWAVPHYS ASWKM = 0.0981_JWRB BSWKM = 0.425_JWRB + ELSE IF (IPHYS.EQ.2) THEN + +!!! EMPIRICAL CONSTANCE FOR SPECTRAL UPDATE FOLLOWING DATA ASSIMILATION +! TODO: THESE WILL REQUIRE RECALIBRATION IF USING W. DATA ASSIMILATION + EGRCRV = 1065.0_JWRB + AGRCRV = 0.0655E+6_JWRB + BGRCRV = 10.906_JWRB + AFCRV = 2.453E-4_JWRB + BFCRV = -3.1236_JWRB + ESH = 1711.0_JWRB + ASH = 8.0E-4_JWRB + BSH = 0.96_JWRB + ASWKM=0.0981_JWRB + BSWKM=0.425_JWRB + + + ! Not ALL necessarily used in BYDB physics (TODO: change any others?) + ALPHA = 0.0065_JWRB + BETAMAX = 1.40_JWRB + ZALP = 0.008_JWRB + ALPHAPMAX = 0.031_JWRB ! cap on spectral steepness as in ARD +! ALPHAPMAX = 1.0_JWRB ! i.e. no cap on max spectral steepness + TAUWSHELTER=0.25_JWRB + TAILFACTOR=2.5_JWRB + TAILFACTOR_PM=3.0_JWRB + CDFAC=1.0_JWRB + ELSE WRITE (IU06,*) '*************************************' WRITE (IU06,*) '* *' diff --git a/src/ecwam/sinflx.F90 b/src/ecwam/sinflx.F90 index 9b0316193..02b5131b3 100644 --- a/src/ecwam/sinflx.F90 +++ b/src/ecwam/sinflx.F90 @@ -162,7 +162,7 @@ SUBROUTINE SINFLX (ICALL, NCALL, KIJS, KIJL, & & WDWAVE, WSWAVE, UFRIC, Z0M, & & COSWDIF, SINWDIF2, & & RAORW, WSTAR, RNFAC, & -& FLD, SL, SPOS, XLLWS) +& CHRNCK, FLD, SL, SPOS, XLLWS) ! MEAN FREQUENCY CHARACTERISTIC FOR WIND SEA @@ -181,7 +181,6 @@ SUBROUTINE SINFLX (ICALL, NCALL, KIJS, KIJL, & & WDWAVE, UFRIC, Z0M, AIRD, RNFAC, & & COSWDIF, SINWDIF2, & & TAUW, TAUWDIR, PHIWA, LLPHIWA) - ! ---------------------------------------------------------------------- IF (LHOOK) CALL DR_HOOK('SINFLX',1,ZHOOK_HANDLE) diff --git a/src/ecwam/sinput.F90 b/src/ecwam/sinput.F90 index 7c5a337bc..3aa901d4e 100644 --- a/src/ecwam/sinput.F90 +++ b/src/ecwam/sinput.F90 @@ -12,7 +12,7 @@ SUBROUTINE SINPUT (NGST, LLSNEG, KIJS, KIJL, FL1, & & WDWAVE, WSWAVE, UFRIC, Z0M, & & COSWDIF, SINWDIF2, & & RAORW, WSTAR, RNFAC, & - & FLD, SL, SPOS, XLLWS) + & CHRNCK, FLD, SL, SPOS, XLLWS) ! ---------------------------------------------------------------------- !**** *SINPUT* - COMPUTATION OF INPUT SOURCE FUNCTION. @@ -45,6 +45,7 @@ SUBROUTINE SINPUT (NGST, LLSNEG, KIJS, KIJL, FL1, & ! *RAORW* - RATIO AIR DENSITY TO WATER DENSITY. ! *WSTAR* - FREE CONVECTION VELOCITY SCALE (M/S). ! *RNFAC* - WIND DEPENDENT FACTOR USED IN THE GROWTH RENORMALISATION. +! *CHRNCK*- CHARNOCK COEFFICIENT ! *FLD* - DIAGONAL MATRIX OF FUNCTIONAL DERIVATIVE. ! *SL* - TOTAL SOURCE FUNCTION ARRAY. ! *SPOS* - POSITIVE SOURCE FUNCTION ARRAY. @@ -86,10 +87,12 @@ SUBROUTINE SINPUT (NGST, LLSNEG, KIJS, KIJL, FL1, & REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(IN) :: FL1 REAL(KIND=JWRB), DIMENSION(KIJL,NFRE), INTENT(IN) :: WAVNUM, CINV, XK2CG - REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: WDWAVE, WSWAVE, UFRIC, Z0M + REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: WDWAVE, WSWAVE + REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: Z0M, UFRIC REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: RAORW, WSTAR, RNFAC REAL(KIND=JWRB), DIMENSION(KIJL, NANG), INTENT(IN) :: COSWDIF, SINWDIF2 + REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: CHRNCK REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(OUT) :: FLD, SL, SPOS REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(OUT) :: XLLWS @@ -117,7 +120,15 @@ SUBROUTINE SINPUT (NGST, LLSNEG, KIJS, KIJL, FL1, & & COSWDIF, SINWDIF2, & & RAORW, WSTAR, RNFAC, & & FLD, SL, SPOS, XLLWS) - END SELECT + CASE(2) + !$loki inline + CALL SINPUT_BYDBR(NGST, LLSNEG, KIJS, KIJL, FL1, & + & WAVNUM, CINV, XK2CG, & + & WDWAVE, WSWAVE, UFRIC, Z0M, & + & COSWDIF, SINWDIF2, & + & RAORW, WSTAR, RNFAC, & + & CHRNCK, FLD, SL, SPOS, XLLWS) + END SELECT IF (LHOOK) CALL DR_HOOK('SINPUT',1,ZHOOK_HANDLE) diff --git a/src/ecwam/sinput_bydbr.F90 b/src/ecwam/sinput_bydbr.F90 new file mode 100644 index 000000000..31af21f52 --- /dev/null +++ b/src/ecwam/sinput_bydbr.F90 @@ -0,0 +1,539 @@ +! (C) Copyright 1989- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! + +SUBROUTINE SINPUT_BYDBR (NGST, LLSNEG, KIJS, KIJL, FL1, & + & WAVNUM, CINV, XK2CG, & + & WDWAVE, WSWAVE, UFRIC, Z0M, & + & COSWDIF, SINWDIF2, & + & RAORW, WSTAR, RNFAC, & + & CHRNCK, FLD, SL, SPOS, XLLWS) +! ---------------------------------------------------------------------- + +!**** *SINPUT_BYDBR* - COMPUTATION OF INPUT SOURCE FUNCTION. + + +!* PURPOSE. +! --------- + +! Observation-based source term for wind input after Donelan, Babanin, +! Young and Banner (Donelan et al ,2006) following the implementation +! by Rogers et al. (2012). +! +!** INTERFACE. +! ---------- + +! *CALL* *SINPUT_BYDBR (NGST, LLSNEG, KIJS, KIJL, FL1, +! & WAVNUM, CINV, XK2CG, +! & WSWAVE, WDWAVE, UFRIC, Z0M, +! & COSWDIF, SINWDIF2, +! & RAORW, WSTAR, RNFAC, +! & FLD, SL, SPOS, XLLWS) +! *NGST* - IF = 1 THEN NO GUSTINESS PARAMETERISATION +! - IF = 2 THEN GUSTINESS PARAMETERISATION +! *LLSNEG- IF TRUE THEN THE NEGATIVE SINPUT (SWELL DAMPING) WILL BE COMPUTED +! *KIJS* - INDEX OF FIRST GRIDPOINT. +! *KIJL* - INDEX OF LAST GRIDPOINT. +! *FL1* - SPECTRUM. +! *WAVNUM* - WAVE NUMBER. +! *CINV* - INVERSE PHASE VELOCITY. +! *XK2CG* - (WAVNUM)**2 * GROUP SPPED. +! *WDWAVE* - WIND DIRECTION IN RADIANS IN OCEANOGRAPHIC +! NOTATION (POINTING ANGLE OF WIND VECTOR, +! CLOCKWISE FROM NORTH). +! *UFRIC* - NEW FRICTION VELOCITY IN M/S. +! *Z0M* - ROUGHNESS LENGTH IN M. +! *COSWDIF* - COS(TH(K)-WDWAVE(IJ)) +! *SINWDIF2* - SIN(TH(K)-WDWAVE(IJ))**2 +! *RAORW* - RATIO AIR DENSITY TO WATER DENSITY. +! *WSTAR* - FREE CONVECTION VELOCITY SCALE (M/S). +! *RNFAC* - WIND DEPENDENT FACTOR USED IN THE GROWTH RENORMALISATION. +! *CHRNCK*- CHARNOCK COEFFICIENT +! *FLD* - DIAGONAL MATRIX OF FUNCTIONAL DERIVATIVE. +! *SL* - TOTAL SOURCE FUNCTION ARRAY. +! *SPOS* - POSITIVE SOURCE FUNCTION ARRAY. +! *XLLWS* - = 1 WHERE SINPUT IS POSITIVE + +! METHOD. +! ------- + +! SEE REFERENCE. + +! EXTERNALS. +! ---------- +! TAU_WAVE_ATMOS +! LFACTOR +! IRANGE + +! ORIGIN. +! ---------- +! Adapted from Babanin Young Donelan & Banner (BYDB) physics +! as implemented as ST6 in WAVEWATCH-III +! WW3 module: W3SRC6MD +! WW3 subroutine: W3SIN6 +! Implementation into ECWAM DECEMBER 2021 by J. Kousal + + +! ---------------------------------------------------------------------- + USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU + + USE YOWCOUP , ONLY : LLCAPCHNK,LLNORMAGAM + USE YOWFRED , ONLY : FR ,TH ,DFIM ,COSTH ,SINTH, ZPIFR, DELTH, FRATIO, FRIC + USE YOWPARAM , ONLY : NANG ,NFRE + USE YOWPCONS , ONLY : G ,GM1 ,EPSMIN, EPSUS, ZPI, ROWATER + USE YOWPHYS , ONLY : ZALP ,TAUWSHELTER, XKAPPA, BETAMAXOXKAPPA2, & + & RNU ,RNUM, & + & SWELLF ,SWELLF2 ,SWELLF3 ,SWELLF4 , SWELLF5, & + & SWELLF6 ,SWELLF7 ,SWELLF7M1, Z0RAT ,Z0TUBMAX , & + & ABMIN ,ABMAX, CDFAC + USE YOWTEST , ONLY : IU06 + USE YOWTABL , ONLY : IAB ,SWELLFT + + USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK + +! ---------------------------------------------------------------------- + + IMPLICIT NONE + +#include "wsigstar.intfb.h" +! #include "tau_wave_atmos.intfb.h" +#include "lfactor.intfb.h" +#include "irange.intfb.h" +! #include "calcphiwa.intfb.h" + + INTEGER(KIND=JWIM), INTENT(IN) :: NGST + LOGICAL, INTENT(IN) :: LLSNEG + INTEGER(KIND=JWIM), INTENT(IN) :: KIJS, KIJL + REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(IN) :: FL1 + REAL(KIND=JWRB), DIMENSION(KIJL,NFRE), INTENT(IN) :: WAVNUM, CINV, XK2CG + REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: WDWAVE, WSWAVE + REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: Z0M, UFRIC + REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: RAORW, WSTAR, RNFAC + REAL(KIND=JWRB), DIMENSION(KIJL,NANG), INTENT(IN) :: COSWDIF, SINWDIF2 + REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: CHRNCK + REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(OUT) :: FLD, SL, SPOS + REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(OUT) :: XLLWS + + INTEGER(KIND=JWIM) :: IJ, K, M, IND, IGST + INTEGER(KIND=JWIM) :: NSPEC !num. of freqs, dirs, spec. bins + INTEGER(KIND=JWIM), DIMENSION(NANG) :: ITHN + INTEGER(KIND=JWIM), DIMENSION(NFRE) :: IKN + + REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: CG2, ECOS2, ESIN2, DSII2 + REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: WN2, SIG2 + REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: SQRTBN2, CINV2, A + REAL(KIND=JWRB), DIMENSION(NFRE) :: DSII, SIG, CINV1, DF + REAL(KIND=JWRB), DIMENSION(NFRE) :: ADENSIG, KMAX, ANAR, SQRTBN + REAL(KIND=JWRB), DIMENSION(NANG,NFRE) :: KK + ! REAL(KIND=JWRB), DIMENSION(NANG,NFRE) :: SPOSDENSIG, SNEGDENSIG + REAL(KIND=JWRB), DIMENSION(NANG*NFRE,NGST) :: W1, W2, S, D + REAL(KIND=JWRB), DIMENSION(NFRE,NGST) :: LFACT + REAL(KIND=JWRB), DIMENSION(NANG,NFRE,NGST) :: SDENSIG, DINPOS, DINTOT + + + REAL(KIND=JWRB), PARAMETER :: SIN6A0 = 9.0E-2_JWRB ! ST6 PARAM + REAL(KIND=JWRB), DIMENSION(NGST) :: TAUWX, TAUWY ! Component of the wave-supported stress + REAL(KIND=JWRB), DIMENSION(NGST) :: TAUNWX, TAUNWY ! Component of the neg. wave-supported stress + REAL(KIND=JWRB) :: COSU, SINU + REAL(KIND=JWRB), DIMENSION(NGST) :: UPROXY + + REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: XK, CGG_WAM, CM + REAL(KIND=JWRB), DIMENSION(NFRE) :: SIGP2, SIGM1 + + ! For USTAR, Z0, CHNK + REAL(KIND=JWRB), DIMENSION(KIJL,NGST) :: TAU + REAL(KIND=JWRB), PARAMETER :: ZRN=1.65E-6_JWRB ! effective kinematic viscosity (0.11*1.5e-5) + REAL(KIND=JWRB), PARAMETER :: RKAP = 0.4_JWRB + REAL(KIND=JWRB) :: ZNLEV, Z0, KUOUST, USTM1, USTM2 + REAL(KIND=JWRB), PARAMETER :: XEPS=0.00001_JWRB + REAL(KIND=JWRB), PARAMETER :: USTMIN=0.000001_JWRB + REAL(KIND=JWRB), PARAMETER :: PCHARMAX=0.1_JWRB + REAL(KIND=JWRB), PARAMETER :: Z0FG=0.01_JWRB + INTEGER(KIND=JWIM) :: ITER + REAL(KIND=JWRB) :: XZNLEV, PCHAROG, XKUTOP, XOLOGZ0 + REAL(KIND=JWRB) :: UST, USTOLD, Z0CH, Z0VIS, Z0TOT, FF, DELF + REAL(KIND=JWRB) :: CHARNOCK_MIN,CHNKMIN ! For Capping + INTEGER(KIND=JWIM), PARAMETER :: NITER=15 + REAL(KIND=JWRB), PARAMETER :: ALPHAMAX=0.1_JWRB + REAL(KIND=JWRB), PARAMETER :: AMAX=0.02_JWRB + REAL(KIND=JWRB), PARAMETER :: BMAX=0.01_JWRB + REAL(KIND=JWRB) :: ALPHAOGMAXU10 + + REAL(KIND=JWRB), DIMENSION(KIJL) :: ROAIRN, CHNKOG + + ! For GUSTINESS + REAL(KIND=JWRB) :: AVG_GST + REAL(KIND=JWRB), DIMENSION(KIJL) :: SIG_N, TAUWGST_AVG, TAUNWGST_AVG, USTARGST_AVG + REAL(KIND=JWRB), DIMENSION(KIJL,NGST) :: TAUWGST, TAUNWGST, UABSGST, USTARGST, Z0GST + REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE) :: SLGST_AVG, SPOSGST_AVG, FLGST_AVG + REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE,NGST) :: SLGST, SPOSGST, FLGST + + ! ! For PHIWA calculation + ! REAL(KIND=JWRB),DIMENSION(KIJL,NFRE) :: RHOWGDFTH + ! REAL(KIND=JWRB), DIMENSION(KIJL) :: SUMT + + REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ---------------------------------------------------------------------- + +IF (LHOOK) CALL DR_HOOK('SINPUT_BYDBR',0,ZHOOK_HANDLE) + +NSPEC = NANG * NFRE ! NUMBER OF SPECTRAL BINS + +! Wind height + ZNLEV = 10._JWRB + +! COMPUTE FREQUENCY INTERVALLS (borrowed from Wam_others/f4spec.F) + DO M = 1,NFRE + DF(M) = FR(M)*( FRATIO - 1.0_JWRB ) + ENDDO + + DO M = 1,NFRE + SIG(M) = ZPI*FR(M) + DSII(M) = ZPI*DF(M) + SIGM1(M) = 1.0_JWRB/SIG(M) + SIGP2(M) = SIG(M)**2 + END DO + + !TODO: clean up stuff in/out of IJ loops (sdissip_bydb + swldissip +sinput_bydb) + + +! ! INVERSE OF PHASE VELOCITIES AND WAVE NUMBER. +! IF (ISHALLO.EQ.1) THEN ! -> DEEP WATER +! DO M=1,NFRE +! DO IJ=IJS,IJL +! XK(IJ,M) = SIGP2(M)/G ! INVERSE PHASE VEL. +! CGG_WAM(IJ,M)=G/(2.0_JWRB*SIG(M)) ! GROUP VEL. +! ENDDO +! ENDDO +! ELSE ! -> SHALLOW WATER +! DO M=1,NFRE +! DO IJ=IJS,IJL +! XK(IJ,M) = TFAK(INDEP(IJ),M) ! WAVENUMBER +! CGG_WAM(IJ,M)= TCGOND(INDEP(IJ),M) ! GROUP VEL. +! ENDDO +! ENDDO +! ENDIF + +! TODO: confirm that I'm using exactly the same things here (I've now adopted them throughout the BYDBR code) +! - confirm CGG_WAM=CGROUP +! - confirm XK=WAVNUM + + DO M=1,NFRE + DO IJ=KIJS,KIJL + CM(IJ,M) = WAVNUM(IJ,M)*SIGM1(M) + ENDDO + ENDDO + + + ITHN = IRANGE(1,NANG,1) ! Index vector 1:NANG + DO M = 1, NFRE + ECOS2 (ITHN+(M-1)*NANG) = COSTH + ESIN2 (ITHN+(M-1)*NANG) = SINTH + END DO +! + IKN = IRANGE(1,NSPEC,NANG) ! Index vector for elements of 1 ... NFRE +! ! such that e.g. SIG(1:NFRE) = SIG2(IKN). + + DO K = 1, NANG ! Apply to all directions + DSII2 (IKN+(K-1)) = DSII + SIG2 (IKN+(K-1)) = SIG + END DO + +! ESTIMATE THE STANDARD DEVIATION OF GUSTINESS. + CALL WSIGSTAR (KIJS, KIJL, WSWAVE, UFRIC, Z0M, WSTAR, SIG_N) + AVG_GST = 1.0_JWRB/NGST + + DO IJ=KIJS,KIJL + USTARGST(IJ,1)= UFRIC(IJ)*(1.0_JWRB+SIG_N(IJ)) + USTARGST(IJ,2)= UFRIC(IJ)*(1.0_JWRB-SIG_N(IJ)) + CHNKOG(IJ) = CHRNCK(IJ)*GM1 + ROAIRN(IJ) = RAORW(IJ)*ROWATER + END DO + + ! Define Z0GST associated with USTARGST (as in airsea_iter) +! DO IGST=1,NGST +! DO IJ=KIJS,KIJL +! XKUTOP = RKAP*UABS(IJ) +! UST = USTARGST(IJ,IGST) +! PCHAROG = MIN(ALPHAOG(IJ),PCHARMAX/G) +! ! iteratively solve Z0 and USTAR +! DO ITER=1,NITER +! USTOLD = MAX(UST,USTMIN) +! Z0CH = PCHAROG*UST**2 +! Z0VIS = ZRN/UST +! Z0TOT = Z0CH+Z0VIS +! XZNLEV = ZNLEV/(ZNLEV+Z0TOT) +! XOLOGZ0 = 1.0_JWRB/LOG(1.0_JWRB+ZNLEV/Z0TOT) +! FF = UST-XKUTOP*XOLOGZ0 +! DELF = 1.0_JWRB-XKUTOP*XOLOGZ0**2*XZNLEV* & +! & (2.0_JWRB*Z0CH-Z0VIS)/(UST*Z0TOT) +! IF(DELF /= 0.0_JWRB) UST = UST-FF/DELF +! IF(ABS(UST-USTOLD)<=UST*XEPS .AND. ABS(FF)<=XEPS) EXIT +! ENDDO ! iter loop ENDDO + + ! Update Z0, US (gust) +! IF(ITER > NITER) THEN +!! failed to iterate +! Z0GST(IJ,IGST) = Z0FG +! USTARGST(IJ,IGST) = XKUTOP/LOG(1.0+ZNLEV/Z0GST(IJ,IGST)) +! ELSE +! USTARGST(IJ,IGST) = MAX(UST,USTMIN) +! Z0GST(IJ,IGST) = Z0TOT +! ENDIF +! ENDDO ! IJ loop ENDDO +! ENDDO ! NGST loop ENDDO + + ! Define Z0GST associated with USTARGST (as in airsea_iter) + DO IGST=1,NGST + DO IJ=KIJS,KIJL + UST = USTARGST(IJ,IGST) + PCHAROG = MIN(CHNKOG(IJ),PCHARMAX/G) + Z0CH = PCHAROG*UST**2 + Z0VIS = ZRN/UST + Z0GST(IJ,IGST) = Z0CH+Z0VIS + ENDDO ! IJ loop ENDDO + ENDDO ! NGST loop ENDDO + + ! Define UABSGST associated with USTARGST and Z0GST + ! U10 = (u*/kappa) log (1 + Z/Z0), z=10 + DO IGST=1,NGST + DO IJ=KIJS,KIJL + UABSGST(IJ,IGST) = USTARGST(IJ,IGST)*LOG(1.0_JWRB + ZNLEV/Z0GST(IJ,IGST))/XKAPPA + END DO + END DO + +!/ --- Main loop over LOC ----------------------------------- / + + + ! LOOP OVER LOCATIONS + DO IJ = KIJS,KIJL + + DO K = 1, NANG ! Apply to all directions + WN2 (IKN+(K-1)) = XK(IJ,:) ! using WAM native WN,CG + CG2 (IKN+(K-1)) = CGG_WAM(IJ,:) + END DO + + CINV2 = WN2 / SIG2 ! inverse phase speed + +!/ 0) --- set up a basic variables ----------------------------------- / + + COSU = COS(WDWAVE(IJ)) + SINU = SIN(WDWAVE(IJ)) +! + DO IGST=1,NGST + TAUNWX(IGST) = 0.0_JWRB + TAUNWY(IGST) = 0.0_JWRB + TAUWX(IGST) = 0.0_JWRB + TAUWY(IGST) = 0.0_JWRB + TAU(IJ,IGST) = 0.0_JWRB + ENDDO + +! +!/ --- scale friction velocity to wind speed (10m) in +!/ the boundary layer ----------------------------------------- / +!/ Donelan et al. (2006) used U10 or U_{λ/2} in their S_{in} +!/ parameterization. To avoid some disadvantages of using U10 or +!/ U_{λ/2}, Rogers et al. (2012) used the following engineering +!/ conversion: +!/ UPROXY = SIN6WS * UST +!/ +!/ SIN6WS = FRIC = 28.0 following Komen et al. (1984) +!/ SIN6WS = 32.0 suggested by E. Rogers (2014) +! + DO IGST=1,NGST + UPROXY(IGST) = FRIC * CDFAC * USTARGST(IJ,IGST) ! Scale wind speed by FRIC and CDFAC + ENDDO +! + ! To reshape from 1D to 2D: + ! K = RESHAPE( A , (/ NANG, NFRE /)) + ! To reshape from 2D to 1D: + ! A = RESHAPE( F(IJ,:,:) , (/NSPEC/) ) + A = RESHAPE( FL1(IJ,:,:) , (/NSPEC/)) * CG2 / ( ZPI * SIG2 )! ACTION DENSITY SPECTRUM +! +!/ 1) --- calculate 1d action density spectrum (A(sigma)) and +!/ zero-out values less than 1.0E-32 to avoid NaNs when +!/ computing directional narrowness in step 4). --------------- / + KK = RESHAPE(A,(/ NANG, NFRE /)) + + ADENSIG = SUM(KK,1) * SIG * DELTH ! Integrate over directions. +! +!/ 2) --- calculate normalised directional spectrum K(theta,sigma) --- / + KMAX = MAXVAL(KK,1) + DO M = 1,NFRE + IF (KMAX(M).LT.1.0E-34_JWRB) THEN + KK(1:NANG,M) = 1.0_JWRB + ELSE + KK(1:NANG,M) = KK(1:NANG,M)/KMAX(M) + END IF + END DO +! +!/ 3) --- calculate normalised spectral saturation BN(M) ------------ / + ANAR = 1.0_JWRB/( SUM(KK,1) * DELTH ) ! directional narrowness +! +! SQRTBN = SQRT( ANAR * ADENSIG * WN(IJ,:)**3 ) + SQRTBN = SQRT( ANAR * ADENSIG * XK(IJ,:)**3 ) + + DO K = 1, NANG + SQRTBN2(IKN+(K-1)) = SQRTBN ! Calculate SQRTBN for + END DO ! the entire spectrum. +! +!/ 4) --- calculate growth rate GAMMA and S for all directions for +!/ following winds (U10/c - 1 is positive; W1) and in 7) for +!/ adverse winds (U10/c -1 is negative, W2). W1 and W2 +!/ complement one another. ------------------------------------ / + DO IGST=1,NGST + W1(:,IGST)= MAX(0.0_JWRB, & + & UPROXY(IGST)*CINV2*(ECOS2*COSU + ESIN2*SINU) - 1.0_JWRB)**2 +! + D(:,IGST) = (RAORW(IJ) ) * SIG2 * & + (2.8_JWRB-(1.0_JWRB+TANH(10.0_JWRB*SQRTBN2*W1(:,IGST)-11.0_JWRB)))*& + & SQRTBN2*W1(:,IGST) +! + S(:,IGST) = D(:,IGST) * A + ENDDO +! +!/ 5) --- calculate reduction factor LFACT using non-directional +! spectral density of the wind input ------------------------- / + CINV1 = CINV2(IKN) + + DO IGST=1,NGST + SDENSIG(:,:,IGST) = RESHAPE(S(:,IGST)*SIG2/CG2,(/ NANG, NFRE /)) + + CALL LFACTOR(SDENSIG(:,:,IGST), CINV1, UABSGST(IJ,IGST), USTARGST(IJ,IGST), WDWAVE(IJ), & +& ROAIRN(IJ), SIG, DSII, LFACT(:,IGST), TAUWX(IGST), TAUWY(IGST), TAU(IJ,IGST)) + ENDDO + +! +!/ 6) --- apply reduction (LFACT) to the entire spectrum ------------- / + DO IGST=1,NGST + IF (SUM(LFACT(:,IGST)) .LT. NFRE) THEN + DO K = 1, NANG + D(IKN+K-1,IGST) = D(IKN+K-1,IGST) * LFACT(:,IGST) + END DO + S(:,IGST) = D(:,IGST) * A + END IF + DINPOS(:,:,IGST) = RESHAPE(D(:,IGST),(/ NANG, NFRE /)) + ENDDO + +! +!/ 7) --- compute negative wind input for adverse winds. negative +!/ growth is typically smaller by a factor of ~2.5 (=.28/.11) +!/ than those for the favourable winds [Donelan, 2006, Eq. (7)]. +!/ the factor is adjustable with NAMELIST parameter in +!/ ww3_grid.inp: '&SIN6 SINA0 = 0.04 /' ----------------------- / + DO IGST=1,NGST + IF (SIN6A0.GT.0.0_JWRB) THEN + W2(:,IGST) = MIN( 0.0_JWRB,UPROXY(IGST) * CINV2* & + & (ECOS2*COSU + ESIN2*SINU) - 1.0_JWRB )**2 + D(:,IGST) = D(:,IGST) - ( RAORW(IJ) * SIG2 * SIN6A0 * & + (2.8_JWRB-(1.0_JWRB+TANH(10.0_JWRB*SQRTBN2*W2(:,IGST) - 11.0_JWRB)))& + & *SQRTBN2*W2(:,IGST) ) + + DINTOT(:,:,IGST)= RESHAPE(D(:,IGST),(/NANG,NFRE/)) + S(:,IGST) = D(:,IGST) * A + +! ! --- compute negative component of the wave supported stresses +! ! from negative part of the wind input ---------------------- / +! SDENSIG(:,:,IGST) = RESHAPE(S(:,IGST)*SIG2/CG2,(/ NANG, NFRE /)) +! CALL TAU_WAVE_ATMOS(SDENSIG(:,:,IGST), CINV1, SIG, DSII, TAUNWX(IGST), TAUNWY(IGST) ) + ELSE + DINTOT(:,:,IGST)=DINPOS(:,:,IGST) + END IF + ENDDO +! + DO IGST=1,NGST + ! TAUWGST(IJ,IGST) = SQRT(TAUWX(IGST)**2+TAUWY(IGST)**2) / ROAIRN(IJ) ! KINEMATIC TAUW + ! TAUNWGST(IJ,IGST) = SQRT(TAUNWX(IGST)**2+TAUNWY(IGST)**2) / ROAIRN(IJ) ! KINEMATIC TAUNW + USTARGST(IJ,IGST) = SQRT(TAU(IJ,IGST) / ROAIRN(IJ) ) + ENDDO + +! 8) --- Calculate SL, FL and SPOS needed for ecWAM ------------- / + + DO IGST=1,NGST + DO M = 1,NFRE + DO K = 1, NANG + SLGST(IJ,K,M,IGST) = DINTOT(K,M,IGST)*FL1(IJ,K,M) + SPOSGST(IJ,K,M,IGST) = DINPOS(K,M,IGST)*FL1(IJ,K,M) + END DO + END DO + FLGST(IJ,:,:,IGST) = DINTOT(:,:,IGST) + END DO + +! 9) --- Averaging over gust components ------------- / + IGST=1 + ! TAUWGST_AVG(IJ) = TAUWGST(IJ,IGST) + ! TAUNWGST_AVG(IJ) = TAUNWGST(IJ,IGST) + USTARGST_AVG(IJ) = USTARGST(IJ,IGST) + SLGST_AVG(IJ,:,:) = SLGST(IJ,:,:,IGST) + SPOSGST_AVG(IJ,:,:) = SPOSGST(IJ,:,:,IGST) + FLGST_AVG(IJ,:,:) = FLGST(IJ,:,:,IGST) + DO IGST=2,NGST + ! TAUWGST_AVG(IJ) = TAUWGST_AVG(IJ) + TAUWGST(IJ,IGST) + ! TAUNWGST_AVG(IJ) = TAUNWGST_AVG(IJ) + TAUNWGST(IJ,IGST) + USTARGST_AVG(IJ) = USTARGST_AVG(IJ) + USTARGST(IJ,IGST) + SLGST_AVG(IJ,:,:) = SLGST_AVG(IJ,:,:) + SLGST(IJ,:,:,IGST) + SPOSGST_AVG(IJ,:,:) = SPOSGST_AVG(IJ,:,:) + SPOSGST(IJ,:,:,IGST) + FLGST_AVG(IJ,:,:) = FLGST_AVG(IJ,:,:) + FLGST(IJ,:,:,IGST) + ENDDO + ! TAUW(IJ) = AVG_GST*TAUWGST_AVG(IJ) + ! TAUNW(IJ) = AVG_GST*TAUNWGST_AVG(IJ) + UFRIC(IJ) = AVG_GST*USTARGST_AVG(IJ) + SL(IJ,:,:) = AVG_GST*SLGST_AVG(IJ,:,:) + SPOS(IJ,:,:) = AVG_GST*SPOSGST_AVG(IJ,:,:) + FLD(IJ,:,:) = AVG_GST*FLGST_AVG(IJ,:,:) + +! 10) --- Calculate roughness length and charnock ------------- / + + USTM1 = 1.0_JWRB/MAX(UFRIC(IJ),EPSUS) ! Protect the code + USTM2 = 1.0_JWRB/MAX(UFRIC(IJ)**2,EPSUS) ! Protect the code + KUOUST = MIN(50._JWRB,XKAPPA*WSWAVE(IJ)*USTM1) ! Protect the code + Z0 = ZNLEV / ( EXP(KUOUST) - 1.0_JWRB ) + Z0 = MAX(Z0, 0.0000001_JWRB) + Z0M(IJ) = Z0 ! Update z0 + CHNKOG(IJ) = ( Z0 - ZRN*USTM1 ) * USTM2 ! Update charnock (where Z0=Z0CH+Z0VIS from airsea_iter) + ALPHAOGMAXU10 = MIN(ALPHAMAX,AMAX+BMAX*WSWAVE(IJ))*GM1 ! protective code taken from outbeta (incl /G) + CHNKOG(IJ) = MIN(CHNKOG(IJ),ALPHAOGMAXU10) ! protective code taken from outbeta (incl /G) + + IF(LLCAPCHNK) THEN + CHARNOCK_MIN = CHNKMIN(WSWAVE(IJ)) + CHNKOG(IJ) = MAX(CHARNOCK_MIN*GM1,CHNKOG(IJ)) + ELSE + CHNKOG(IJ) = MAX(CHNKOG(IJ), 1E-5_JWRB) + ENDIF + + CHRNCK(IJ) = CHNKOG(IJ)*G + +! 11) --- PHIWA calculation using non-directional +! spectral density of the wind input ---------------------- / + + ! SPOSDENSIG = SPOS(IJ,:,:) + ! SNEGDENSIG = SL(IJ,:,:) - SPOS(IJ,:,:) + ! PHIWA(IJ) = CALCPHIWA(SPOSDENSIG,SNEGDENSIG,DSII) + + END DO + ! END LOOP OVER LOC + ! --------------------- + + ! XLLWS based on SL (mask for neg. input) + DO IJ=KIJS,KIJL + DO M = 1,NFRE + DO K = 1, NANG + IF (SL(IJ,K,M)>0.0_JWRB) THEN + XLLWS(IJ,K,M)=1.0_JWRB + ELSE + XLLWS(IJ,K,M)=0.0_JWRB + END IF + END DO + END DO + END DO + ! --------------------- + +IF (LHOOK) CALL DR_HOOK('SINPUT_BYDBR',1,ZHOOK_HANDLE) + +END SUBROUTINE SINPUT_BYDBR diff --git a/src/ecwam/swldissip_bydbr.F90 b/src/ecwam/swldissip_bydbr.F90 new file mode 100644 index 000000000..915a4252b --- /dev/null +++ b/src/ecwam/swldissip_bydbr.F90 @@ -0,0 +1,250 @@ +! (C) Copyright 1989- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! + + SUBROUTINE SWLDISSIP_BYDBR (KIJS, KIJL, FL1, FLD, SL, & + & WAVNUM, CGROUP, XK2CG, & + & UFRIC, COSWDIF, RAORW) +! ---------------------------------------------------------------------- + +!**** *SWLDISSIP_BYDBR* - COMPUTATION OF DISSIPATION SOURCE FUNCTION. + +! LOTFI AOUF METEO FRANCE 2013 +! FABRICE ARDHUIN IFREMER 2013 + + +!* PURPOSE. +! -------- +! Turbulent dissipation of narrow-banded swell as described in +! Babanin (2011, Section 7.5). +! +!** INTERFACE. +! ---------- + +! *CALL* *SWLDISSIP_BYDBR (KIJS, KIJL, FL1, FLD,SL,* +! WAVNUM, CGROUP, XK2CG, +! UFRIC, COSWDIF, RAORW)* +! *KIJS* - INDEX OF FIRST GRIDPOINT +! *KIJL* - INDEX OF LAST GRIDPOINT +! *FL1* - SPECTRUM. +! *FLD* - DIAGONAL MATRIX OF FUNCTIONAL DERIVATIVE +! *SL* - TOTAL SOURCE FUNCTION ARRAY +! *WAVNUM* - WAVE NUMBER +! *CGROUP* - GROUP SPEED +! *XK2CG* - (WAVE NUMBER)**2 * GROUP SPEED +! *UFRIC* - FRICTION VELOCITY IN M/S. +! *RAORW* - RATIO AIR DENSITY TO WATER DENSITY +! *COSWDIF*- COS(TH(K)-WDWAVE(IJ)) + + +! METHOD. +! ------- + +! SEE REFERENCES. + +! EXTERNALS. +! ---------- + +! IRANGE + +! REFERENCE. +! ---------- + +! Babanin 2011: Cambridge Press, 295-321, 463pp. + +! ORIGIN. +! ---------- +! Adapted from Babanin Young Donelan & Banner (BYDB) physics +! as implemented as ST6 in WAVEWATCH-III +! WW3 module: W3SWLDMD +! WW3 subroutine: W3SWL6 +! Implementation into ECWAM DECEMBER 2021 by J. Kousal + + +! ---------------------------------------------------------------------- + USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU + + USE YOWFRED , ONLY : FR , TH ,ZPIFR ,FRATIO ,DELTH, DFIM + USE YOWPCONS , ONLY : G ,ZPI + USE YOWPARAM , ONLY : NANG ,NFRE + USE YOWPHYS , ONLY : SDSBR ,ISDSDTH ,ISB ,IPSAT , & +& SSDSC2 , SSDSC4, SSDSC6, MICHE, SSDSC3, SSDSBRF1, & +& BRKPBCOEF ,SSDSC5, NSDSNTH, & +& INDICESSAT, SATWEIGHTS + + USE YOMHOOK , ONLY : LHOOK ,DR_HOOK, JPHOOK + +! ---------------------------------------------------------------------- + + IMPLICIT NONE +#include "irange.intfb.h" + + INTEGER(KIND=JWIM), INTENT(IN) :: KIJS, KIJL + + REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(IN) :: FL1 + REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(INOUT) :: FLD, SL + REAL(KIND=JWRB), DIMENSION(KIJL,NFRE), INTENT(IN) :: WAVNUM, CGROUP, XK2CG + REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: UFRIC, RAORW + REAL(KIND=JWRB), DIMENSION(KIJL, NANG), INTENT(IN) :: COSWDIF + + INTEGER(KIND=JWIM) :: IJ, M, I, J, M2, K2, K, NANGD + INTEGER(KIND=JWIM) :: NSPEC !num. of freqs, dirs, spec. bins + INTEGER(KIND=JWIM), DIMENSION(NANG) :: KKD + INTEGER(KIND=JWIM), DIMENSION(NANG) :: ITHN + INTEGER(KIND=JWIM), DIMENSION(NFRE) :: IKN + + REAL(KIND=JWRB), PARAMETER :: SWL6B1 = 0.0041_JWRB ! ST6 PARAM + LOGICAL, PARAMETER :: SWL6CSTB1 = .FALSE. ! ST6 PARAM + + REAL(KIND=JWRB), DIMENSION(NFRE) :: ABAND, KMAX, ANAR, BN, AORB, DDIS + REAL(KIND=JWRB), DIMENSION(NFRE) :: SIG, DDEN + REAL(KIND=JWRB), DIMENSION(NANG,NFRE) :: KK + REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: S, D, A + REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: SIG2, CG2 + REAL(KIND=JWRB) :: B1 + REAL(KIND=JWRB), DIMENSION(NANG,NFRE) :: DSWL + + REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: XK, CGG_WAM + REAL(KIND=JWRB), DIMENSION(NFRE) :: SIGP2 + REAL(KIND=JWRB), DIMENSION(NFRE) :: DF ! FREQUENCY INTERVALS + + REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ---------------------------------------------------------------------- + + IF (LHOOK) CALL DR_HOOK('SWLDISSIP_BYDBR',0,ZHOOK_HANDLE) + + NSPEC = NANG * NFRE ! NUMBER OF SPECTRAL BINS + + DO M = 1,NFRE + SIG(M) = ZPI*FR(M) + SIGP2(M) = SIG(M)**2 + DDEN(M) = ZPI*DFIM(M)*SIG(M) + END DO + +! ! INVERSE OF PHASE VELOCITIES AND WAVE NUMBER. +! IF (ISHALLO.EQ.1) THEN ! -> DEEP WATER +! DO M=1,NFRE +! DO IJ=IJS,IJL +! XK(IJ,M) = SIGP2(M)/G ! INVERSE PHASE VEL. +! CGG_WAM(IJ,M)=G/(2.0_JWRB*SIG(M)) ! GROUP VEL. +! ENDDO +! ENDDO +! ELSE ! -> SHALLOW WATER +! DO M=1,NFRE +! DO IJ=IJS,IJL +! XK(IJ,M) = TFAK(INDEP(IJ),M) ! WAVENUMBER +! CGG_WAM(IJ,M)= TCGOND(INDEP(IJ),M) ! GROUP VEL. +! ENDDO +! ENDDO +! ENDIF + +! TODO: confirm that I'm using exactly the same things here (I've now adopted them throughout the BYDBR code) +! - confirm CGG_WAM=CGROUP +! - confirm XK=WAVNUM + + +! COMPUTE FREQUENCY INTERVALLS (borrowed from Wam_others/f4spec.F) + DO M = 1,NFRE + DF(M) = FR(M)*( FRATIO - 1.0_JWRB ) + ENDDO + + IKN = IRANGE(1,NSPEC,NANG) ! Index vector for elements of 1 ... NFRE +! ! such that e.g. SIG(1:NFRE) = SIG2(IKN). + DO K = 1, NANG ! Apply to all directions + SIG2 (IKN+(K-1)) = SIG + END DO + + + ! LOOP OVER LOCATIONS + DO IJ = KIJS,KIJL + + DO K = 1, NANG ! Apply to all directions + CG2 (IKN+(K-1)) = CGROUP(IJ,:) + END DO + + A = RESHAPE( FL1(IJ,:,:) , (/NSPEC/)) * CG2 / ( ZPI * SIG2 )! ACTION DENSITY SPECTRUM + ! WAM E(f,theta) to WW3 A(k,theta) conversion factor: CG2 / ( ZPI *SIG2 ) + +!/ 0) --- Initialize parameters -------------------------------------- / + IKN = IRANGE(1,NSPEC,NANG) ! Index vector for array access, e.g. + ! in form of WN(1:NFRE) == WN2(IKN). + ABAND = SUM(RESHAPE(A,(/ NANG,NFRE /)),1) ! action density as function of wavenumber + DDIS = 0.0_JWRB + D = 0.0_JWRB + B1 = SWL6B1 ! empirical constant from NAMELIST + +!/ 1) --- Choose calculation of steepness a*k ------------------------ / +!/ Replace the measure of steepness with the spectral +! saturation after Banner et al. (2002) ---------------------- / + KK = RESHAPE(A,(/ NANG,NFRE /)) + KMAX = MAXVAL(KK,1) + DO M = 1,NFRE + IF (KMAX(M).LT.1.0E-34_JWRB) THEN + KK(1:NANG,M) = 1.0_JWRB + ELSE + KK(1:NANG,M) = KK(1:NANG,M)/KMAX(M) + END IF + END DO + ANAR = 1.0_JWRB/( SUM(KK,1) * DELTH ) +! BN = ANAR * ( ABAND * SIG * DELTH ) * WN(IJ,:)**3 + BN = ANAR * ( ABAND * SIG * DELTH ) * XK(IJ,:)**3 + +! + IF (.NOT.SWL6CSTB1) THEN +! +!/ --- A constant value for B1 attenuates swell too strong in the +!/ western central Pacific (i.e. cross swell less than 1.0m). +!/ Workaround is to scale B1 with steepness a*kp, where kp is +!/ the peak wavenumber. SWL6B1 remains a scaling constant, but +!/ with different magnitude. --------------------------------- / + M = MAXLOC(ABAND,1) ! Index for peak +! EMEAN = SUM(ABAND * DDEN / CG) ! Total sea surface variance +! B1 = SWL6B1*(2.0_JWRB*SQRT(SUM(ABAND*DDEN/CGG(IJ,:)))*& +! & WN(IJ,M)) + B1 = SWL6B1*(2.0_JWRB*SQRT(SUM(ABAND*DDEN/CGG_WAM(IJ,:)))*& + & XK(IJ,M)) + +! + END IF +! +!/ 2) --- Calculate the derivative term only (in units of 1/s) ------- / + DO M = 1,NFRE + IF (ABAND(M) .GT. 1.0E-30_JWRB) THEN + DDIS(M) = -(2.0_JWRB/3.0_JWRB) * B1 * SIG(M) * SQRT(BN(M)) + END IF + END DO +! +!/ 3) --- Apply dissipation term of derivative to all directions ----- / + DO K = 1, NANG + D(IKN+(K-1)) = DDIS + END DO +! + !S = D * A +! +! WRITE(*,*) ' B1 =',B1 +! WRITE(*,*) ' DDIS_tot =',SUM(DDIS*ABAND*DDEN/CG) +! WRITE(*,*) ' EDENS_tot=',sum(aband*dden/cg) +! WRITE(*,*) ' EDENS_tot=',sum(aband*sig*dth*dsii/cg) +! WRITE(*,*) ' ' +! WRITE(*,*) ' SWL6_tot =',sum(SUM(RESHAPE(S,(/ NANG,NFRE /)),1)*DDEN/CG) + + DSWL = RESHAPE(D,(/NANG,NFRE/)) + DO M = 1,NFRE + DO K = 1, NANG + SL(IJ,K,M) = SL(IJ,K,M) + DSWL(K,M)*FL1(IJ,K,M) + FLD(IJ,K,M) = FLD(IJ,K,M) + DSWL(K,M) + END DO + END DO + + END DO + ! END LOOP OVER LOC + + IF (LHOOK) CALL DR_HOOK('SWLDISSIP_BYDBR',1,ZHOOK_HANDLE) + + END SUBROUTINE SWLDISSIP_BYDBR diff --git a/src/ecwam/tau_wave_atmos.F90 b/src/ecwam/tau_wave_atmos.F90 new file mode 100644 index 000000000..5cca15467 --- /dev/null +++ b/src/ecwam/tau_wave_atmos.F90 @@ -0,0 +1,162 @@ +! (C) Copyright 1989- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. + + SUBROUTINE TAU_WAVE_ATMOS(S, CINV, SIG, DSII, TAUNWX, TAUNWY ) + +! ---------------------------------------------------------------------- +! +! 1. Purpose : +! +! Calculated the stress for the negative part of the input term, +! that is the stress from the waves to the atmosphere. Relevant +! in the case of opposing winds. +! +! 2. Method : +! 1) If required, extend resolved part of the spectrum to 10Hz using +! an approximation for the spectral slope at the high frequency +! limit: Sin(F) prop. F**(-2) and for E(F) prop. F**(-5). +! 2) Calculate stresses: +! stress components (x,y): /10Hz +! TAUNW_X,Y = GRAV * DWAT * | [SinX,Y(F)]/C(F) dF +! / +! +! ---------------------------------------------------------------------------- +! +!** INTERFACE. +! ---------- + +! *CALL* *TAU_WAVE_ATMOS(S, CINV, SIG, DSII, TAUNWX, TAUNWY ) + +! *S* - NEG. WIND INPUT ENERGY DENSITY SPECTRUM. +! *CINV* - INVERSE PHASE SPEED CALC. IN INPUT ROUTINE +! *SIG* - FREQ (RAD) +! *DSII* - ZPI*DF +! *TAUNWX, TAUNWY* - NEGATIVE WAVE NORMAL STRESS COMPONENTS + +! EXTERNALS. +! ---------- +! TAUWINDS +! IRANGE + +! ORIGIN. +! ---------- +! Adapted from Babanin Young Donelan & Banner (BYDB) physics +! as implemented as ST6 in WAVEWATCH-III +! WW3 module: W3SRC6MD +! WW3 subroutine: TAU_WAVE_ATMOS +! Implementation into ECWAM DECEMBER 2021 by J. Kousal + +! ---------------------------------------------------------------------- + USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU + + USE YOWCOUP , ONLY : BETAMAX ,ZALP ,TAUWSHELTER, XKAPPA, RNU ,RNUM + USE YOWFRED , ONLY : FR ,TH ,DFIM ,COSTH ,SINTH,& + & FRATIO ,DELTH + USE YOWMPP , ONLY : NINF ,NSUP + USE YOWPARAM , ONLY : NANG ,NFRE ,NBLO + USE YOWPCONS , ONLY : G ,ZPI ,ROWATER ,EPSMIN + USE YOWSHAL , ONLY : TFAK ,INDEP + USE YOWSTAT , ONLY : ISHALLO + USE YOWTABL , ONLY : IAB ,SWELLFT + USE YOMHOOK ,ONLY : LHOOK, DR_HOOK + +! ---------------------------------------------------------------------- + + IMPLICIT NONE +#include "irange.intfb.h" +#include "tauwinds.intfb.h" + + REAL(KIND=JWRB), DIMENSION(NANG,NFRE), INTENT(IN) :: S + REAL(KIND=JWRB), DIMENSION(NFRE), INTENT(IN) :: CINV, SIG, DSII + REAL(KIND=JWRB), INTENT(OUT) :: TAUNWX, TAUNWY + + REAL(KIND=JWRB), PARAMETER :: FRQMAX = 10.0_JWRB ! Upper freq. limit to extrapolate to. + + REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: ECOS2, ESIN2 + REAL, ALLOCATABLE :: IK10Hz(:), SIG10Hz(:), CINV10Hz(:) + REAL, ALLOCATABLE :: SDENSX10Hz(:), SDENSY10Hz(:) + REAL, ALLOCATABLE :: DSII10Hz(:), UCINV10Hz(:) + + INTEGER(KIND=JWIM) :: IK, ITH, NK10Hz + INTEGER(KIND=JWIM) :: NK, NTH, NSPEC !num. of freqs, dirs, spec. bins + INTEGER(KIND=JWIM), DIMENSION(NANG) :: ITHN + INTEGER(KIND=JWIM), DIMENSION(NFRE) :: IKN + + REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ---------------------------------------------------------------------- + + IF (LHOOK) CALL DR_HOOK('TAU_WAVE_ATMOS',0,ZHOOK_HANDLE) + + NTH = NANG ! NUMBER OF DIRS , SAME AS KL + NK = NFRE ! NUMBER OF FREQS, SAME AS ML + NSPEC = NK * NTH ! NUMBER OF SPECTRAL BINS + +!/ 0) --- Find the number of frequencies required to extend arrays +!/ up to f=10Hz and allocate arrays --------------------------- / + NK10Hz = CEILING(ALOG(FRQMAX/(SIG(1)/ZPI))/ALOG(FRATIO))+1 + NK10Hz = MAX(NK,NK10Hz) +! + ALLOCATE(IK10Hz(NK10Hz)) + IK10Hz = REAL( IRANGE(1,NK10Hz,1) ) +! + ALLOCATE(SIG10Hz(NK10Hz)) + ALLOCATE(CINV10Hz(NK10Hz)) + ALLOCATE(DSII10Hz(NK10Hz)) + ALLOCATE(SDENSX10Hz(NK10Hz)) + ALLOCATE(SDENSY10Hz(NK10Hz)) + ALLOCATE(UCINV10Hz(NK10Hz)) +! + ITHN = IRANGE(1,NTH,1) ! Index vector 1:NTH + DO IK = 1, NK + ECOS2 (ITHN+(IK-1)*NTH) = COSTH + ESIN2 (ITHN+(IK-1)*NTH) = SINTH + END DO + +! +!/ 1) --- Either extrapolate arrays up to 10Hz or use discrete spectral +! grid per se. Limit the constraint to the positive part of the +! wind input only. ---------------------------------------------- / + IF (NK .LT. NK10Hz) THEN + SDENSX10Hz(1:NK) = SUM(ABS(MIN(0.0_JWRB,S))*& + & RESHAPE(ECOS2,(/NTH,NK/)),1) * DELTH + SDENSY10Hz(1:NK) = SUM(ABS(MIN(0.0_JWRB,S))*& + & RESHAPE(ESIN2,(/NTH,NK/)),1) * DELTH + SIG10Hz = SIG(1)*FRATIO**(IK10Hz-1.0_JWRB) + CINV10Hz(1:NK) = CINV + CINV10Hz(NK+1:NK10Hz) = SIG10Hz(NK+1:NK10Hz)*0.101978_JWRB + DSII10Hz = 0.5_JWRB * SIG10Hz * (FRATIO-1.0_JWRB/FRATIO) +! The first and last frequency bin: + DSII10Hz(1) = 0.5_JWRB * SIG10Hz(1) * (FRATIO-1.0_JWRB) + DSII10Hz(NK10Hz) = 0.5_JWRB * SIG10Hz(NK10Hz) * & + & (FRATIO-1.0_JWRB) / FRATIO +! +! --- Spectral slope for S_IN(F) is proportional to F**(-2) ------ / + SDENSX10Hz(NK+1:NK10Hz) = SDENSX10Hz(NK) * & + & (SIG10Hz(NK)/SIG10Hz(NK+1:NK10Hz))**2 + SDENSY10hz(NK+1:NK10Hz) = SDENSY10Hz(NK) * & + & (SIG10Hz(NK)/SIG10Hz(NK+1:NK10Hz))**2 + ELSE + SIG10Hz = SIG + CINV10Hz = CINV + DSII10Hz = DSII + SDENSX10Hz(1:NK) = SUM(ABS(MIN(0.0_JWRB,S))*& + & RESHAPE(ECOS2,(/NTH,NK/)),1) * DELTH + SDENSY10Hz(1:NK) = SUM(ABS(MIN(0.0_JWRB,S))*& + & RESHAPE(ESIN2,(/NTH,NK/)),1) * DELTH + END IF +! +!/ 2) --- Stress calculation ----------------------------------------- / +! --- The wave supported stress (waves to atmosphere) ------------ / + TAUNWX = TAUWINDS(SDENSX10Hz,CINV10Hz,DSII10Hz) ! x-component + TAUNWY = TAUWINDS(SDENSY10Hz,CINV10Hz,DSII10Hz) ! y-component + + + IF (LHOOK) CALL DR_HOOK('TAU_WAVE_ATMOS',1,ZHOOK_HANDLE) + + END SUBROUTINE TAU_WAVE_ATMOS diff --git a/src/ecwam/tauwinds.F90 b/src/ecwam/tauwinds.F90 new file mode 100644 index 000000000..67db2621a --- /dev/null +++ b/src/ecwam/tauwinds.F90 @@ -0,0 +1,62 @@ +! (C) Copyright 1989- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. + + FUNCTION TAUWINDS(SDENSIG,CINV,DSII) RESULT(TAU_WINDS) + +! ---------------------------------------------------------------------------- +! +! 1. Purpose : +! +! Wind stress (tau) computation from wind-momentum-input +! function which can be obtained from wind-energy-input (Sin). +! +! / FRMAX +! tau = g * rho_water * | Sin(f)/C(f) df +! / + +!---------------------------------------------------------------------- +! +! INTERFACE VARIABLES. +! -------------------- + +! ORIGIN. +! ---------- +! Adapted from Babanin Young Donelan & Banner (BYDB) physics +! as implemented as ST6 in WAVEWATCH-III +! WW3 module: W3SRC6MD +! WW3 subroutine: TAUWINDS +! Implementation into ECWAM DECEMBER 2021 by J. Kousal + +! ---------------------------------------------------------------------------- +! + + USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU + USE YOWPCONS , ONLY : G ,ZPI ,ROWATER + USE YOMHOOK , ONLY : LHOOK ,DR_HOOK, JPHOOK + +!---------------------------------------------------------------------- + + IMPLICIT NONE + + REAL(KIND=JWRB), INTENT(IN) :: SDENSIG(:) ! Sin(sigma) in [m2/rad-Hz] + REAL(KIND=JWRB), INTENT(IN) :: CINV(:) ! inverse phase speed + REAL(KIND=JWRB), INTENT(IN) :: DSII(:) ! freq. bandwidths in [radians] + + REAL(KIND=JWRB) :: TAU_WINDS + REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ---------------------------------------------------------------------------- +! + + IF (LHOOK) CALL DR_HOOK('TAUWINDS',0,ZHOOK_HANDLE) + + TAU_WINDS = G * ROWATER * SUM(SDENSIG*CINV*DSII) + + IF (LHOOK) CALL DR_HOOK('TAUWINDS',1,ZHOOK_HANDLE) + + END FUNCTION TAUWINDS diff --git a/src/ecwam/userin.F90 b/src/ecwam/userin.F90 index fb1494a45..96a8eb933 100644 --- a/src/ecwam/userin.F90 +++ b/src/ecwam/userin.F90 @@ -121,7 +121,7 @@ SUBROUTINE USERIN (IFORCA, LWCUR) & CHNKMIN_U, CDIS ,DELTA_SDIS, CDISVIS, & & TAUWSHELTER, TAILFACTOR, TAILFACTOR_PM, & & DELTA_THETA_RN, DTHRN_A, DTHRN_U, & - & SWELLF4, SWELLF7, SSDSC5 + & SWELLF4, SWELLF7, SSDSC5, CDFAC USE YOWSHAL , ONLY : NDEPTH ,DEPTHA ,DEPTHD ,BATHYMAX USE YOWSTAT , ONLY : CDATEE ,CDATEF ,CDATER ,CDATES , & & IFRELFMAX, DELPRO_LF, IDELPRO, IDELT ,IDELWI , & @@ -783,6 +783,8 @@ SUBROUTINE USERIN (IFORCA, LWCUR) WRITE(IU06,*) ' SWELLF4 = ...... ', SWELLF4 WRITE(IU06,*) ' SWELLF7 = ...... ', SWELLF7 WRITE(IU06,*) ' SSDSC5 = ....... ', SSDSC5 + ELSEIF (IPHYS == 2) THEN + WRITE(IU06,*) ' CDFAC = ...... ', CDFAC ENDIF WRITE(IU06,*) '' WRITE(IU06,*) ' THIS IS ALWAYS A SHALLOW WATER RUN ' diff --git a/src/ecwam/yowcout.F90 b/src/ecwam/yowcout.F90 index 54ad912d7..74141da39 100644 --- a/src/ecwam/yowcout.F90 +++ b/src/ecwam/yowcout.F90 @@ -17,8 +17,8 @@ MODULE YOWCOUT !* ** *COUT* OUTPUT POINTS INDICES AND FLAGS. INTEGER(KIND=JWIM), PARAMETER :: NTRAIN=3 - INTEGER(KIND=JWIM), PARAMETER :: JPPFLAG=75+3*NTRAIN+5 !!!! change also in scripts: wave_setgflag - INTEGER(KIND=JWIM), PARAMETER :: NREAL=16 + INTEGER(KIND=JWIM), PARAMETER :: JPPFLAG=72+3*NTRAIN+5 !!!! change also in scripts: wave_setgflag + INTEGER(KIND=JWIM), PARAMETER :: NREAL=17 INTEGER(KIND=JWIM), PARAMETER :: NIPRMINFO=7 INTEGER(KIND=JWIM), PARAMETER :: NINFOBOUT=5 diff --git a/src/ecwam/yowfred.F90 b/src/ecwam/yowfred.F90 index 70258462a..cdc94c767 100644 --- a/src/ecwam/yowfred.F90 +++ b/src/ecwam/yowfred.F90 @@ -55,7 +55,6 @@ MODULE YOWFRED REAL(KIND=JWRB), PARAMETER :: QPTAIL = 2.0_JWRB/9.0_JWRB REAL(KIND=JWRB), PARAMETER :: COEF4 = 5.0E-07_JWRB - REAL(KIND=JWRB) :: XKMSS_CUTOFF INTEGER(KIND=JWIM) :: NWAV_GC diff --git a/src/ecwam/yowphys.F90 b/src/ecwam/yowphys.F90 index 9bd9136bf..1c7a9e0de 100644 --- a/src/ecwam/yowphys.F90 +++ b/src/ecwam/yowphys.F90 @@ -33,6 +33,9 @@ MODULE YOWPHYS ! *BETAMAX* PARAMETER FOR WIND INPUT. REAL(KIND=JWRB) :: BETAMAX +! *CDFAC* PARAMETER FOR WIND INPUT FOR BYDBR PHYS. + REAL(KIND=JWRB) :: CDFAC + ! *BETAMAXOXKAPPA2* BETAMAX/XKAPPA**2 REAL(KIND=JWRB) :: BETAMAXOXKAPPA2 diff --git a/tests/etopo1_oper_an_fc_O48_cy50r1_bydbr.yml b/tests/etopo1_oper_an_fc_O48_cy50r1_bydbr.yml new file mode 100644 index 000000000..76622ce8e --- /dev/null +++ b/tests/etopo1_oper_an_fc_O48_cy50r1_bydbr.yml @@ -0,0 +1,123 @@ +grid: O48 +directions: 12 +frequencies: 25 +bathymetry: ETOPO1 +iphys: 2 + +advection: + timestep: 900 +physics: + timestep: 900 + +analysis.begin: 2022-12-31 12:00:00 +analysis.end: 2023-01-01 00:00:00 +forecast.begin: 2023-01-01 00:00:00 +forecast.end: 2023-01-01 06:00:00 + +begin: ${analysis.begin} +end: ${forecast.end} + +nproma: 32 +llgcbz0: T +llnormagam: T +lciwa3: T +lciscal: T + +forcings: + file: data/forcings/oper_an_12h_fc_2023010100_36h_O48.grib + + at: + - begin: ${analysis.begin} + end: ${analysis.end} + timestep: 06:00 + - begin: ${forecast.begin} + end: ${forecast.end} + timestep: 01:00 + +output: + fields: + name: + - swh # Significant height of combined wind waves and swell + - mwd # Mean wave direction + - mwp # Mean wave period + - pp1d # Peak wave period + - dwi # 10 metre wind direction + - cdww # Coefficient of drag with waves + - wind # 10 metre wind speed + format: grib # (default : grib) or binary + at: + - timestep: 01:00 + + restart: + format: binary # (default : binary) or grib + at: + - time: ${end} + + +validation: + + double_precision: + + # initial analysis time + - name: swh + time: 2022-12-31 12:00:00 + average: 0.1337362278436861E+01 + relative_tolerance: 1.e-14 + hashes: ['0x3FF565D5FD0CA556'] + + # initial forecast time + - name: swh + time: 2023-01-01 00:00:00 + average: 0.1549542256416082E+01 + relative_tolerance: 1.e-14 + hashes: ['0x3FF8CAECD2313BDF'] + + # 6h into forecast + - name: swh + time: 2023-01-01 06:00:00 + average: 0.1632449648145021E+01 + relative_tolerance: 1.e-14 + hashes: ['0x3FFA1E8385B264A5'] + - name: swh + time: 2023-01-01 06:00:00 + minimum: 0.1905182728883706E-01 + relative_tolerance: 1.e-14 + hashes: ['0x3F9382527C89D368'] + - name: swh + time: 2023-01-01 06:00:00 + maximum: 0.6807117063618366E+01 + relative_tolerance: 1.e-14 + hashes: ['0x401B3A7CE5412342'] + + single_precision: + + # initial analysis time + - name: swh + time: 2022-12-31 12:00:00 + average: 0.1337408304214478E+01 + relative_tolerance: 1.e-6 + hashes: ['0x3FF5660640000000'] + + # initial forecast time + - name: swh + time: 2023-01-01 00:00:00 + average: 0.1549576163291931E+01 + relative_tolerance: 1.e-6 + hashes: ['0x3FF8CB1060000000'] + + # 6h into forecast + - name: swh + time: 2023-01-01 06:00:00 + average: 0.1632413744926453E+01 + relative_tolerance: 1.e-6 + hashes: ['0x3FFA1E5DE0000000'] + - name: swh + time: 2023-01-01 06:00:00 + minimum: 0.1905178464949131E-01 + relative_tolerance: 1.e-6 + hashes: ['0x3F93824FA0000000'] + - name: swh + time: 2023-01-01 06:00:00 + maximum: 0.6807114124298096E+01 + relative_tolerance: 1.e-6 + hashes: ['0x401B3A7C20000000'] From 7f58f0acd7f9a9c0d52fad8b9932c05403e83fbb Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Thu, 5 Jun 2025 16:55:35 +0000 Subject: [PATCH 02/89] bugfix, ecWAM with new bydbr physics now returning reasonable results --- src/ecwam/sinput.F90 | 1 + src/ecwam/sinput_bydbr.F90 | 12 +++++++----- src/ecwam/swldissip_bydbr.F90 | 6 +++--- 3 files changed, 11 insertions(+), 8 deletions(-) diff --git a/src/ecwam/sinput.F90 b/src/ecwam/sinput.F90 index 3aa901d4e..1969a1c0e 100644 --- a/src/ecwam/sinput.F90 +++ b/src/ecwam/sinput.F90 @@ -79,6 +79,7 @@ SUBROUTINE SINPUT (NGST, LLSNEG, KIJS, KIJL, FL1, & IMPLICIT NONE #include "sinput_ard.intfb.h" #include "sinput_jan.intfb.h" +#include "sinput_bydbr.intfb.h" INTEGER(KIND=JWIM), INTENT(IN) :: NGST LOGICAL, INTENT(IN) :: LLSNEG diff --git a/src/ecwam/sinput_bydbr.F90 b/src/ecwam/sinput_bydbr.F90 index 31af21f52..3952ba28b 100644 --- a/src/ecwam/sinput_bydbr.F90 +++ b/src/ecwam/sinput_bydbr.F90 @@ -123,7 +123,8 @@ SUBROUTINE SINPUT_BYDBR (NGST, LLSNEG, KIJS, KIJL, FL1, & INTEGER(KIND=JWIM) :: NSPEC !num. of freqs, dirs, spec. bins INTEGER(KIND=JWIM), DIMENSION(NANG) :: ITHN INTEGER(KIND=JWIM), DIMENSION(NFRE) :: IKN - + + REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: CGROUP REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: CG2, ECOS2, ESIN2, DSII2 REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: WN2, SIG2 REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: SQRTBN2, CINV2, A @@ -226,7 +227,8 @@ SUBROUTINE SINPUT_BYDBR (NGST, LLSNEG, KIJS, KIJL, FL1, & DO M=1,NFRE DO IJ=KIJS,KIJL - CM(IJ,M) = WAVNUM(IJ,M)*SIGM1(M) + CM(IJ,M) = WAVNUM(IJ,M)*SIGM1(M) + CGROUP(IJ,M) = XK2CG(IJ,M)/(WAVNUM(IJ,M)**2) ! TODO: alternatively pass this in from implsch level ENDDO ENDDO @@ -315,8 +317,8 @@ SUBROUTINE SINPUT_BYDBR (NGST, LLSNEG, KIJS, KIJL, FL1, & DO IJ = KIJS,KIJL DO K = 1, NANG ! Apply to all directions - WN2 (IKN+(K-1)) = XK(IJ,:) ! using WAM native WN,CG - CG2 (IKN+(K-1)) = CGG_WAM(IJ,:) + WN2 (IKN+(K-1)) = WAVNUM(IJ,:) ! using WAM native WN,CG + CG2 (IKN+(K-1)) = CGROUP(IJ,:) END DO CINV2 = WN2 / SIG2 ! inverse phase speed @@ -377,7 +379,7 @@ SUBROUTINE SINPUT_BYDBR (NGST, LLSNEG, KIJS, KIJL, FL1, & ANAR = 1.0_JWRB/( SUM(KK,1) * DELTH ) ! directional narrowness ! ! SQRTBN = SQRT( ANAR * ADENSIG * WN(IJ,:)**3 ) - SQRTBN = SQRT( ANAR * ADENSIG * XK(IJ,:)**3 ) + SQRTBN = SQRT( ANAR * ADENSIG * WAVNUM(IJ,:)**3 ) DO K = 1, NANG SQRTBN2(IKN+(K-1)) = SQRTBN ! Calculate SQRTBN for diff --git a/src/ecwam/swldissip_bydbr.F90 b/src/ecwam/swldissip_bydbr.F90 index 915a4252b..322ff5659 100644 --- a/src/ecwam/swldissip_bydbr.F90 +++ b/src/ecwam/swldissip_bydbr.F90 @@ -193,7 +193,7 @@ SUBROUTINE SWLDISSIP_BYDBR (KIJS, KIJL, FL1, FLD, SL, & END DO ANAR = 1.0_JWRB/( SUM(KK,1) * DELTH ) ! BN = ANAR * ( ABAND * SIG * DELTH ) * WN(IJ,:)**3 - BN = ANAR * ( ABAND * SIG * DELTH ) * XK(IJ,:)**3 + BN = ANAR * ( ABAND * SIG * DELTH ) * WAVNUM(IJ,:)**3 ! IF (.NOT.SWL6CSTB1) THEN @@ -207,8 +207,8 @@ SUBROUTINE SWLDISSIP_BYDBR (KIJS, KIJL, FL1, FLD, SL, & ! EMEAN = SUM(ABAND * DDEN / CG) ! Total sea surface variance ! B1 = SWL6B1*(2.0_JWRB*SQRT(SUM(ABAND*DDEN/CGG(IJ,:)))*& ! & WN(IJ,M)) - B1 = SWL6B1*(2.0_JWRB*SQRT(SUM(ABAND*DDEN/CGG_WAM(IJ,:)))*& - & XK(IJ,M)) + B1 = SWL6B1*(2.0_JWRB*SQRT(SUM(ABAND*DDEN/CGROUP(IJ,:)))*& + & WAVNUM(IJ,M)) ! END IF From 49940fd30aa2e4ae557a7edf81efd364eece7690 Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Fri, 6 Jun 2025 11:34:54 +0000 Subject: [PATCH 03/89] small code tidy --- src/ecwam/sdissip_bydbr.F90 | 22 ---------------------- src/ecwam/sinput_bydbr.F90 | 29 +++++------------------------ src/ecwam/swldissip_bydbr.F90 | 22 ---------------------- 3 files changed, 5 insertions(+), 68 deletions(-) diff --git a/src/ecwam/sdissip_bydbr.F90 b/src/ecwam/sdissip_bydbr.F90 index 2781ea033..c5661b1b3 100644 --- a/src/ecwam/sdissip_bydbr.F90 +++ b/src/ecwam/sdissip_bydbr.F90 @@ -147,28 +147,6 @@ SUBROUTINE SDISSIP_BYDBR (KIJS, KIJL, FL1, FLD, SL, & SIGP2(M) = SIG(M)**2 END DO -! ! INVERSE OF PHASE VELOCITIES AND WAVE NUMBER. -! IF (ISHALLO.EQ.1) THEN ! -> DEEP WATER -! DO M=1,NFRE -! DO IJ=IJS,IJL -! XK(IJ,M) = SIGP2(M)/G ! INVERSE PHASE VEL. -! CGG_WAM(IJ,M)=G/(2.0_JWRB*SIG(M)) ! GROUP VEL. -! ENDDO -! ENDDO -! ELSE ! -> SHALLOW WATER -! DO M=1,NFRE -! DO IJ=IJS,IJL -! XK(IJ,M) = TFAK(INDEP(IJ),M) ! WAVENUMBER -! CGG_WAM(IJ,M)= TCGOND(INDEP(IJ),M) ! GROUP VEL. -! ENDDO -! ENDDO -! ENDIF - -! TODO: confirm that I'm using exactly the same things here (I've now adopted them throughout the BYDBR code) -! - confirm CGG_WAM=CGROUP -! - confirm XK=WAVNUM - - ! COMPUTE FREQUENCY INTERVALLS (borrowed from Wam_others/f4spec.F) DO M = 1,NFRE DF(M) = FR(M)*( FRATIO - 1.0_JWRB ) diff --git a/src/ecwam/sinput_bydbr.F90 b/src/ecwam/sinput_bydbr.F90 index 3952ba28b..f76dff3a8 100644 --- a/src/ecwam/sinput_bydbr.F90 +++ b/src/ecwam/sinput_bydbr.F90 @@ -201,34 +201,15 @@ SUBROUTINE SINPUT_BYDBR (NGST, LLSNEG, KIJS, KIJL, FL1, & SIGP2(M) = SIG(M)**2 END DO - !TODO: clean up stuff in/out of IJ loops (sdissip_bydb + swldissip +sinput_bydb) - - -! ! INVERSE OF PHASE VELOCITIES AND WAVE NUMBER. -! IF (ISHALLO.EQ.1) THEN ! -> DEEP WATER -! DO M=1,NFRE -! DO IJ=IJS,IJL -! XK(IJ,M) = SIGP2(M)/G ! INVERSE PHASE VEL. -! CGG_WAM(IJ,M)=G/(2.0_JWRB*SIG(M)) ! GROUP VEL. -! ENDDO -! ENDDO -! ELSE ! -> SHALLOW WATER -! DO M=1,NFRE -! DO IJ=IJS,IJL -! XK(IJ,M) = TFAK(INDEP(IJ),M) ! WAVENUMBER -! CGG_WAM(IJ,M)= TCGOND(INDEP(IJ),M) ! GROUP VEL. -! ENDDO -! ENDDO -! ENDIF - -! TODO: confirm that I'm using exactly the same things here (I've now adopted them throughout the BYDBR code) -! - confirm CGG_WAM=CGROUP -! - confirm XK=WAVNUM + ! TODO: clean up stuff in/out of IJ loops (sdissip_bydb + swldissip +sinput_bydb) + ! TODO: confirm that I'm using exactly the same things here (I've now adopted them throughout the BYDBR code) + ! - confirm CGG_WAM=CGROUP + ! - confirm XK=WAVNUM DO M=1,NFRE DO IJ=KIJS,KIJL CM(IJ,M) = WAVNUM(IJ,M)*SIGM1(M) - CGROUP(IJ,M) = XK2CG(IJ,M)/(WAVNUM(IJ,M)**2) ! TODO: alternatively pass this in from implsch level + CGROUP(IJ,M) = XK2CG(IJ,M)/(WAVNUM(IJ,M)**2) ! TODO: better to pass this in from implsch level? ENDDO ENDDO diff --git a/src/ecwam/swldissip_bydbr.F90 b/src/ecwam/swldissip_bydbr.F90 index 322ff5659..f75110156 100644 --- a/src/ecwam/swldissip_bydbr.F90 +++ b/src/ecwam/swldissip_bydbr.F90 @@ -127,28 +127,6 @@ SUBROUTINE SWLDISSIP_BYDBR (KIJS, KIJL, FL1, FLD, SL, & DDEN(M) = ZPI*DFIM(M)*SIG(M) END DO -! ! INVERSE OF PHASE VELOCITIES AND WAVE NUMBER. -! IF (ISHALLO.EQ.1) THEN ! -> DEEP WATER -! DO M=1,NFRE -! DO IJ=IJS,IJL -! XK(IJ,M) = SIGP2(M)/G ! INVERSE PHASE VEL. -! CGG_WAM(IJ,M)=G/(2.0_JWRB*SIG(M)) ! GROUP VEL. -! ENDDO -! ENDDO -! ELSE ! -> SHALLOW WATER -! DO M=1,NFRE -! DO IJ=IJS,IJL -! XK(IJ,M) = TFAK(INDEP(IJ),M) ! WAVENUMBER -! CGG_WAM(IJ,M)= TCGOND(INDEP(IJ),M) ! GROUP VEL. -! ENDDO -! ENDDO -! ENDIF - -! TODO: confirm that I'm using exactly the same things here (I've now adopted them throughout the BYDBR code) -! - confirm CGG_WAM=CGROUP -! - confirm XK=WAVNUM - - ! COMPUTE FREQUENCY INTERVALLS (borrowed from Wam_others/f4spec.F) DO M = 1,NFRE DF(M) = FR(M)*( FRATIO - 1.0_JWRB ) From 8ee35e4dc7172d0f9531e69a953a0f6c0cc8745f Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Wed, 11 Jun 2025 16:58:16 +0000 Subject: [PATCH 04/89] freq cut off bydbr;formatting;CGROUP thru implsch;test w/o iterations on SINFLX for bydbr;optional LLFACT; comments!!! --- src/ecwam/frcutindex.F90 | 33 ++++----- src/ecwam/frcutindex_bydb.F90 | 119 +++++++++++++++++++++++++++++++ src/ecwam/frcutindex_default.F90 | 97 +++++++++++++++++++++++++ src/ecwam/implsch.F90 | 14 +++- src/ecwam/lfactor.F90 | 45 ++++++------ src/ecwam/sinflx.F90 | 4 +- src/ecwam/sinput.F90 | 9 +-- src/ecwam/sinput_bydbr.F90 | 40 ++++++----- src/ecwam/stresso.F90 | 29 ++++++++ src/ecwam/tau_wave_atmos.F90 | 18 ++--- 10 files changed, 326 insertions(+), 82 deletions(-) create mode 100644 src/ecwam/frcutindex_bydb.F90 create mode 100644 src/ecwam/frcutindex_default.F90 diff --git a/src/ecwam/frcutindex.F90 b/src/ecwam/frcutindex.F90 index 9d99d2376..504d37618 100644 --- a/src/ecwam/frcutindex.F90 +++ b/src/ecwam/frcutindex.F90 @@ -53,12 +53,15 @@ SUBROUTINE FRCUTINDEX (KIJS, KIJL, FM, FMWS, UFRIC, CICOVER, & USE YOWPARAM , ONLY : NFRE USE YOWPCONS , ONLY : G ,EPSMIN USE YOWPHYS , ONLY : TAILFACTOR, TAILFACTOR_PM + USE YOWSTAT , ONLY : IPHYS USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK ! ---------------------------------------------------------------------- IMPLICIT NONE +#include "frcutindex_default.intfb.h" +#include "frcutindex_bydb.intfb.h" INTEGER(KIND=JWIM), INTENT(IN) :: KIJS, KIJL INTEGER(KIND=JWIM), INTENT(OUT) :: MIJ(KIJL) @@ -75,26 +78,14 @@ SUBROUTINE FRCUTINDEX (KIJS, KIJL, FM, FMWS, UFRIC, CICOVER, & IF (LHOOK) CALL DR_HOOK('FRCUTINDEX',0,ZHOOK_HANDLE) -!* COMPUTE LAST FREQUENCY INDEX OF PROGNOSTIC PART OF SPECTRUM. -!* FREQUENCIES LE MAX(TAILFACTOR*MAX(FMNWS,FM),TAILFACTOR_PM*FPM), -!* WHERE FPM IS THE PIERSON-MOSKOWITZ FREQUENCY BASED ON FRICTION -!* VELOCITY. (FPM=G/(FRIC*ZPI*USTAR)) -! ------------------------------------------------------------ - - FPMH = TAILFACTOR/FR(1) - FPPM = TAILFACTOR_PM*G/(FRIC*ZPIFR(1)) - - DO IJ=KIJS,KIJL - IF (CICOVER(IJ) <= CITHRSH_TAIL) THEN - FM2 = MAX(FMWS(IJ),FM(IJ))*FPMH - FPM = FPPM/MAX(UFRIC(IJ),EPSMIN) - FPM4 = MAX(FM2,FPM) - MIJ(IJ) = NINT(LOG10(FPM4)*FLOGSPRDM1)+1 - MIJ(IJ) = MIN(MAX(1,MIJ(IJ)),NFRE) - ELSE - MIJ(IJ) = NFRE - ENDIF - ENDDO + SELECT CASE (IPHYS) + CASE(0,1) + CALL FRCUTINDEX_DEFAULT(KIJS, KIJL, FM, FMWS, UFRIC, CICOVER, & + & MIJ) + CASE(2) + CALL FRCUTINDEX_BYDB (KIJS, KIJL, FM, UFRIC, CICOVER, & + & MIJ) + END SELECT ! SET RHOWGDFTH DO IJ=KIJS,KIJL @@ -106,7 +97,7 @@ SUBROUTINE FRCUTINDEX (KIJS, KIJL, FM, FMWS, UFRIC, CICOVER, & RHOWGDFTH(IJ,M) = 0.0_JWRB ENDDO ENDDO - + IF (LHOOK) CALL DR_HOOK('FRCUTINDEX',1,ZHOOK_HANDLE) END SUBROUTINE FRCUTINDEX diff --git a/src/ecwam/frcutindex_bydb.F90 b/src/ecwam/frcutindex_bydb.F90 new file mode 100644 index 000000000..3a39ef508 --- /dev/null +++ b/src/ecwam/frcutindex_bydb.F90 @@ -0,0 +1,119 @@ + SUBROUTINE FRCUTINDEX_BYDB (KIJS, KIJL, FM, UFRIC, CICOVER, & + & MIJ) + +! ---------------------------------------------------------------------- + +!**** *FRCUTINDEX_BYDB* - RETURNS THE LAST FREQUENCY INDEX OF +! PROGNOSTIC PART OF SPECTRUM. + +!** INTERFACE. +! ---------- + +! *CALL* *FRCUTINDEX_BYDB (KIJS, KIJL, FM, UFRIC, CICOVER,MIJ) +! *KIJS* - INDEX OF FIRST GRIDPOINT +! *KIJL* - INDEX OF LAST GRIDPOINT +! *FM* - MEAN FREQUENCY +! *UFRIC* - FRICTION VELOCITY IN M/S +! *CICOVER*- CICOVER +! *MIJ* - LAST FREQUENCY INDEX for imposing high frequency tail + + + +! METHOD. +! ------- + +!* COMPUTES LAST FREQUENCY INDEX OF PROGNOSTIC PART OF SPECTRUM +! ACCORDING TO BYDB + +! EXTERNALS. +! --------- + +! REFERENCE. +! ---------- + +! ORIGIN. +! ---------- +! Adapted from Babanin Young Donelan & Banner (BYDB) physics +! as implemented as ST6 in WAVEWATCH-III +! WW3 module: W3SRCEMD +! WW3 subroutine: +! Implementation into ECWAM DECEMBER 2021 by J. Kousal + +! ---------------------------------------------------------------------- + + USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU + + USE YOWCOUP , ONLY : TAILFACTOR, TAILFACTOR_PM + USE YOWFRED , ONLY : FR ,DFIM ,FRATIO ,FLOGSPRDM1, & + & DELTH ,RHOWG_DFIM ,FRIC + USE YOWICE , ONLY : CITHRSH_TAIL + USE YOWPARAM , ONLY : NANG ,NFRE + USE YOWPCONS , ONLY : G ,ZPI ,EPSMIN, EPSUS + USE YOMHOOK , ONLY : LHOOK, DR_HOOK + +! ---------------------------------------------------------------------- + + IMPLICIT NONE + + INTEGER(KIND=JWIM), INTENT(IN) :: KIJS, KIJL + INTEGER(KIND=JWIM), INTENT(OUT) :: MIJ(KIJL) + + REAL(KIND=JWRB),DIMENSION(KIJL), INTENT(IN) :: FM, UFRIC + + REAL(KIND=JWRB) :: ZHOOK_HANDLE + + INTEGER(KIND=JWIM) :: IJ, NK, NKH, NKH1, M + REAL(KIND=JWRB), PARAMETER :: SIN6FC = 6.0_JWRB + REAL(KIND=JWRB) :: FXFM, FXPM, FACTI1, FACTI2 ! constants + REAL(KIND=JWRB) :: FHIGH ! Cut-off frequency in integration (rad/s) + REAL(KIND=JWRB) :: SIGNK ! LAST FREQUENCY [RAD] + REAL(KIND=JWRB) :: USTM1 + + +! ---------------------------------------------------------------------- + + IF (LHOOK) CALL DR_HOOK('FRCUTINDEX_BYDB',0,ZHOOK_HANDLE) + + NK = NFRE + FXFM = SIN6FC + FXFM = FXFM * ZPI + FXPM = 4.0_JWRB !TODO: 4.0_JWRB is the factor for the tail (is this right) + FXPM = FXPM * G / 28.0_JWRB !TODO: should this be FRIC? + SIGNK = ZPI*FR(NFRE) + + DO IJ=KIJS,KIJL + IF (CICOVER(IJ) <= CITHRSH_TAIL) THEN + + USTM1 = 1.0_JWRB/MAX(UFRIC(IJ),EPSUS) ! Protect the code + + IF (FXFM .LE. 0) THEN + FHIGH = SIGNK ! LAST FREQ i.e. let tail evolve freely + ELSE + FHIGH = MAX (FXFM * FM(IJ), FXPM * USTM1 ) + ENDIF + + + FACTI1 = 1.0_JWRB / LOG(FRATIO) + FACTI2 = 1.0_JWRB - LOG(ZPI*FR(1)) * FACTI1 + + NKH = MIN ( NK , INT(FACTI2+FACTI1*LOG(MAX(1.0E-7_JWRB,FHIGH))) ) + NKH1 = MIN ( NK , NKH+1 ) + + + IF (FXFM .LE. 0) THEN + FHIGH = SIGNK + ELSE + FHIGH = MIN ( SIGNK, MAX(FXFM * FM(IJ), FXPM * USTM1) ) + ENDIF + NKH = MAX ( 2 , MIN ( NKH1 , & + INT ( FACTI2 + FACTI1*LOG(MAX(1.0E-7_JWRB,FHIGH)) ) ) ) + + MIJ(IJ) = NKH + ELSE + MIJ(IJ) = NFRE + ENDIF + END DO + + IF (LHOOK) CALL DR_HOOK('FRCUTINDEX_BYDB',1,ZHOOK_HANDLE) + + END SUBROUTINE FRCUTINDEX_BYDB diff --git a/src/ecwam/frcutindex_default.F90 b/src/ecwam/frcutindex_default.F90 new file mode 100644 index 000000000..639bad59c --- /dev/null +++ b/src/ecwam/frcutindex_default.F90 @@ -0,0 +1,97 @@ +! (C) Copyright 1989- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! + + SUBROUTINE FRCUTINDEX_DEFAULT (KIJS, KIJL, FM, FMWS, UFRIC, CICOVER, & + & MIJ) + +! ---------------------------------------------------------------------- + +!**** *FRCUTINDEX_DEFAULT* - RETURNS THE LAST FREQUENCY INDEX OF +! PROGNOSTIC PART OF SPECTRUM. + +!** INTERFACE. +! ---------- + +! *CALL* *FRCUTINDEX_DEFAULT (KIJS, KIJL, FM, FMWS, CICOVER, MIJ) +! *KIJS* - INDEX OF FIRST GRIDPOINT +! *KIJL* - INDEX OF LAST GRIDPOINT +! *FM* - MEAN FREQUENCY +! *FMWS* - MEAN FREQUENCY OF WINDSEA +! *UFRIC* - FRICTION VELOCITY IN M/S +! *CICOVER*- CICOVER +! *MIJ* - LAST FREQUENCY INDEX for imposing high frequency tail + + +! METHOD. +! ------- + +!* COMPUTES LAST FREQUENCY INDEX OF PROGNOSTIC PART OF SPECTRUM. +!* FREQUENCIES LE 2.5*MAX(FMWS,FM). + + +!!! be aware that if this is NOT used, for iphys=1, the cumulative dissipation has to be +!!! re-activated (see module yowphys) !!! + + +! ---------------------------------------------------------------------- + + USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU + + USE YOWFRED , ONLY : FR ,DFIM ,FRATIO ,FLOGSPRDM1, & + & ZPIFR, & + & DELTH ,RHOWG_DFIM ,FRIC + USE YOWICE , ONLY : CITHRSH_TAIL + USE YOWPARAM , ONLY : NFRE + USE YOWPCONS , ONLY : G ,EPSMIN + USE YOWPHYS , ONLY : TAILFACTOR, TAILFACTOR_PM + + USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK + +! ---------------------------------------------------------------------- + + IMPLICIT NONE + + INTEGER(KIND=JWIM), INTENT(IN) :: KIJS, KIJL + INTEGER(KIND=JWIM), INTENT(OUT) :: MIJ(KIJL) + REAL(KIND=JWRB),DIMENSION(KIJL), INTENT(IN) :: FM, FMWS, UFRIC, CICOVER + + + INTEGER(KIND=JWIM) :: IJ, M + + REAL(KIND=JWRB) :: FPMH, FPPM, FM2, FPM, FPM4 + REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ---------------------------------------------------------------------- + + IF (LHOOK) CALL DR_HOOK('FRCUTINDEX_DEFAULT',0,ZHOOK_HANDLE) + +!* COMPUTE LAST FREQUENCY INDEX OF PROGNOSTIC PART OF SPECTRUM. +!* FREQUENCIES LE MAX(TAILFACTOR*MAX(FMNWS,FM),TAILFACTOR_PM*FPM), +!* WHERE FPM IS THE PIERSON-MOSKOWITZ FREQUENCY BASED ON FRICTION +!* VELOCITY. (FPM=G/(FRIC*ZPI*USTAR)) +! ------------------------------------------------------------ + + FPMH = TAILFACTOR/FR(1) + FPPM = TAILFACTOR_PM*G/(FRIC*ZPIFR(1)) + + DO IJ=KIJS,KIJL + IF (CICOVER(IJ) <= CITHRSH_TAIL) THEN + FM2 = MAX(FMWS(IJ),FM(IJ))*FPMH + FPM = FPPM/MAX(UFRIC(IJ),EPSMIN) + FPM4 = MAX(FM2,FPM) + MIJ(IJ) = NINT(LOG10(FPM4)*FLOGSPRDM1)+1 + MIJ(IJ) = MIN(MAX(1,MIJ(IJ)),NFRE) + ELSE + MIJ(IJ) = NFRE + ENDIF + ENDDO + + IF (LHOOK) CALL DR_HOOK('FRCUTINDEX_DEFAULT',1,ZHOOK_HANDLE) + + END SUBROUTINE FRCUTINDEX_DEFAULT diff --git a/src/ecwam/implsch.F90 b/src/ecwam/implsch.F90 index e40e9d25e..18a14d410 100644 --- a/src/ecwam/implsch.F90 +++ b/src/ecwam/implsch.F90 @@ -91,7 +91,7 @@ SUBROUTINE IMPLSCH (KIJS, KIJL, FL1, & & ZALPFACX USE YOWPARAM , ONLY : NANG ,NFRE ,LLUNSTR USE YOWPCONS , ONLY : WSEMEAN_MIN, ROWATERM1 - USE YOWSTAT , ONLY : IDELT ,LBIWBK ,XIMP + USE YOWSTAT , ONLY : IDELT ,LBIWBK ,XIMP, IPHYS USE YOWWNDG , ONLY : ICODE ,ICODE_CPL USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK @@ -250,13 +250,21 @@ SUBROUTINE IMPLSCH (KIJS, KIJL, FL1, & ! ------------------------------------------------------- LUPDTUS = .TRUE. - NCALL = 2 + + SELECT CASE (IPHYS) + CASE(0,1) + NCALL = 2 + CASE(2) + ! test without iterating for BYDBR on physics + NCALL = 1 + END SELECT + DO ICALL = 1, NCALL !$loki inline CALL SINFLX (ICALL, NCALL, KIJS, KIJL, & & LUPDTUS, & & FL1, & - & WAVNUM, CINV, XK2CG, & + & WAVNUM,CGROUP, CINV, XK2CG,& & WSWAVE, WDWAVE, AIRD, & & RAORW, WSTAR, CICOVER, & & COSWDIF, SINWDIF2, & diff --git a/src/ecwam/lfactor.F90 b/src/ecwam/lfactor.F90 index 46b89e27c..6b3c414ca 100644 --- a/src/ecwam/lfactor.F90 +++ b/src/ecwam/lfactor.F90 @@ -92,13 +92,12 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, USDIR, ROAIRN, SIG, DSII, & REAL(KIND=JWRB), DIMENSION(NANG,NFRE), INTENT(IN) :: S REAL(KIND=JWRB), DIMENSION(NFRE), INTENT(IN) :: CINV, SIG, DSII - REAL(KIND=JWRB), INTENT(IN) :: U10, USTAR, USDIR, ROAIRN + REAL(KIND=JWRB), INTENT(IN) :: U10, USTAR, USDIR, ROAIRN REAL(KIND=JWRB), DIMENSION(NFRE), INTENT(OUT) :: LFACT REAL(KIND=JWRB), INTENT(OUT) :: TAUWX, TAUWY, TAU REAL(KIND=JWRB), PARAMETER :: FRQMAX = 10.0_JWRB ! Upper freq. limit to extrap. to - REAL(KIND=JWRB), PARAMETER :: SIN6WS = 32.0_JWRB ! ST6 PARAM INTEGER(KIND=JWIM), PARAMETER :: ITERMAX = 80 ! Max. no. iterations ! to find numerical LFACT soln @@ -149,8 +148,8 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, USDIR, ROAIRN, SIG, DSII, & ! ITHN = IRANGE(1,NTH,1) ! Index vector 1:NTH DO IK = 1, NK - ECOS2 (ITHN+(IK-1)*NTH) = COSTH - ESIN2 (ITHN+(IK-1)*NTH) = SINTH + ECOS2 (ITHN+(IK-1)*NTH) = COSTH + ESIN2 (ITHN+(IK-1)*NTH) = SINTH END DO @@ -159,30 +158,28 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, USDIR, ROAIRN, SIG, DSII, & ! grid per se. Limit the constraint to the positive part of the ! wind input only. ---------------------------------------------- / IF (NK .LT. NK10Hz) THEN - SDENS10Hz(1:NK) = SUM(S,1) * DELTH - SDENSX10Hz(1:NK) = SUM(MAX(0.0_JWRB,S)*& - & RESHAPE(ECOS2,(/NTH,NK/)),1) * DELTH - SDENSY10Hz(1:NK) = SUM(MAX(0.0_JWRB,S)*& - & RESHAPE(ESIN2,(/NTH,NK/)),1) * DELTH - SIG10Hz = SIG(1)*FRATIO**(IK10Hz-1.0_JWRB) - CINV10Hz(1:NK) = CINV - CINV10Hz(NK+1:NK10Hz) = SIG10Hz(NK+1:NK10Hz)*0.101978_JWRB ! 1/c=σ/g - DSII10Hz = 0.5_JWRB * SIG10Hz * (FRATIO-1.0_JWRB/FRATIO) + SDENS10Hz(1:NK) = SUM(S,1) * DELTH + SDENSX10Hz(1:NK) = SUM(MAX(0.0_JWRB,S)*RESHAPE(ECOS2,(/NTH,NK/)),1) * DELTH + SDENSY10Hz(1:NK) = SUM(MAX(0.0_JWRB,S)*RESHAPE(ESIN2,(/NTH,NK/)),1) * DELTH + SIG10Hz = SIG(1)*FRATIO**(IK10Hz-1.0_JWRB) + CINV10Hz(1:NK) = CINV + CINV10Hz(NK+1:NK10Hz) = SIG10Hz(NK+1:NK10Hz)*0.101978_JWRB ! 1/c=σ/g + DSII10Hz = 0.5_JWRB * SIG10Hz * (FRATIO-1.0_JWRB/FRATIO) ! The first and last frequency bin: - DSII10Hz(1) = 0.5_JWRB * SIG10Hz(1) * (FRATIO-1.0_JWRB) - DSII10Hz(NK10Hz) = 0.5_JWRB * SIG10Hz(NK10Hz) * (FRATIO-1.0_JWRB) / FRATIO + DSII10Hz(1) = 0.5_JWRB * SIG10Hz(1) * (FRATIO-1.0_JWRB) + DSII10Hz(NK10Hz) = 0.5_JWRB * SIG10Hz(NK10Hz) * (FRATIO-1.0_JWRB) / FRATIO ! ! --- Spectral slope for S_IN(F) is proportional to F**(-2) ------ / - SDENS10Hz(NK+1:NK10Hz) = SDENS10Hz(NK) * (SIG10Hz(NK)/SIG10Hz(NK+1:NK10Hz))**2 - SDENSX10Hz(NK+1:NK10Hz) = SDENSX10Hz(NK) * (SIG10Hz(NK)/SIG10Hz(NK+1:NK10Hz))**2 - SDENSY10hz(NK+1:NK10Hz) = SDENSY10Hz(NK) * (SIG10Hz(NK)/SIG10Hz(NK+1:NK10Hz))**2 + SDENS10Hz(NK+1:NK10Hz) = SDENS10Hz(NK) * (SIG10Hz(NK)/SIG10Hz(NK+1:NK10Hz))**2 + SDENSX10Hz(NK+1:NK10Hz) = SDENSX10Hz(NK) * (SIG10Hz(NK)/SIG10Hz(NK+1:NK10Hz))**2 + SDENSY10hz(NK+1:NK10Hz) = SDENSY10Hz(NK) * (SIG10Hz(NK)/SIG10Hz(NK+1:NK10Hz))**2 ELSE - SIG10Hz = SIG - CINV10Hz = CINV - DSII10Hz = DSII - SDENS10Hz(1:NK) = SUM(S,1) * DELTH - SDENSX10Hz(1:NK) = SUM(MAX(0.0_JWRB,S)*RESHAPE(ECOS2,(/NTH,NK/)),1) * DELTH - SDENSY10Hz(1:NK) = SUM(MAX(0.0_JWRB,S)*RESHAPE(ESIN2,(/NTH,NK/)),1) * DELTH + SIG10Hz = SIG + CINV10Hz = CINV + DSII10Hz = DSII + SDENS10Hz(1:NK) = SUM(S,1) * DELTH + SDENSX10Hz(1:NK) = SUM(MAX(0.0_JWRB,S)*RESHAPE(ECOS2,(/NTH,NK/)),1) * DELTH + SDENSY10Hz(1:NK) = SUM(MAX(0.0_JWRB,S)*RESHAPE(ESIN2,(/NTH,NK/)),1) * DELTH END IF ! !/ 2) --- Stress calculation ----------------------------------------- / diff --git a/src/ecwam/sinflx.F90 b/src/ecwam/sinflx.F90 index 02b5131b3..68408bd25 100644 --- a/src/ecwam/sinflx.F90 +++ b/src/ecwam/sinflx.F90 @@ -10,7 +10,7 @@ SUBROUTINE SINFLX (ICALL, NCALL, KIJS, KIJL, & & LUPDTUS, & & FL1, & - & WAVNUM, CINV, XK2CG, & + & WAVNUM,CGROUP, CINV, XK2CG,& & WSWAVE, WDWAVE, AIRD, & & RAORW, WSTAR, CICOVER, & & COSWDIF, SINWDIF2, & @@ -158,7 +158,7 @@ SUBROUTINE SINFLX (ICALL, NCALL, KIJS, KIJL, & !$loki inline CALL SINPUT (NGST, LLSNEG, KIJS, KIJL, FL1, & -& WAVNUM, CINV, XK2CG, & +& WAVNUM, CGROUP, CINV, XK2CG, & & WDWAVE, WSWAVE, UFRIC, Z0M, & & COSWDIF, SINWDIF2, & & RAORW, WSTAR, RNFAC, & diff --git a/src/ecwam/sinput.F90 b/src/ecwam/sinput.F90 index 1969a1c0e..31a013c9c 100644 --- a/src/ecwam/sinput.F90 +++ b/src/ecwam/sinput.F90 @@ -8,7 +8,7 @@ ! SUBROUTINE SINPUT (NGST, LLSNEG, KIJS, KIJL, FL1, & - & WAVNUM, CINV, XK2CG, & + & WAVNUM, CGROUP, CINV, XK2CG, & & WDWAVE, WSWAVE, UFRIC, Z0M, & & COSWDIF, SINWDIF2, & & RAORW, WSTAR, RNFAC, & @@ -22,7 +22,7 @@ SUBROUTINE SINPUT (NGST, LLSNEG, KIJS, KIJL, FL1, & ! ---------- ! *CALL* *SINPUT (NGST, LLSNEG, KIJS, KIJL, FL1, -! & WAVNUM, CINV, XK2CG, +! & WAVNUM, CGROUP, CINV, XK2CG, ! & WDWAVE, UFRIC, Z0M, ! & COSWDIF, SINWDIF2, ! & RAORW, WSTAR, FLD, SL, SPOS, XLLWS) @@ -32,6 +32,7 @@ SUBROUTINE SINPUT (NGST, LLSNEG, KIJS, KIJL, FL1, & ! *KIJS* - INDEX OF FIRST GRIDPOINT. ! *KIJL* - INDEX OF LAST GRIDPOINT. ! *FL1* - SPECTRUM. +! *CGROUP* - GROUP SPEED ! *WAVNUM* - WAVE NUMBER. ! *CINV* - INVERSE PHASE VELOCITY. ! *XK2CG* - (WAVE NUMBER)**2 * GROUP SPPED. @@ -86,7 +87,7 @@ SUBROUTINE SINPUT (NGST, LLSNEG, KIJS, KIJL, FL1, & INTEGER(KIND=JWIM), INTENT(IN) :: KIJS, KIJL REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(IN) :: FL1 - REAL(KIND=JWRB), DIMENSION(KIJL,NFRE), INTENT(IN) :: WAVNUM, CINV, XK2CG + REAL(KIND=JWRB), DIMENSION(KIJL,NFRE), INTENT(IN) :: WAVNUM, CGROUP, CINV, XK2CG REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: WDWAVE, WSWAVE REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: Z0M, UFRIC @@ -124,7 +125,7 @@ SUBROUTINE SINPUT (NGST, LLSNEG, KIJS, KIJL, FL1, & CASE(2) !$loki inline CALL SINPUT_BYDBR(NGST, LLSNEG, KIJS, KIJL, FL1, & - & WAVNUM, CINV, XK2CG, & + & WAVNUM, CGROUP, CINV, XK2CG, & & WDWAVE, WSWAVE, UFRIC, Z0M, & & COSWDIF, SINWDIF2, & & RAORW, WSTAR, RNFAC, & diff --git a/src/ecwam/sinput_bydbr.F90 b/src/ecwam/sinput_bydbr.F90 index f76dff3a8..e3c1442ab 100644 --- a/src/ecwam/sinput_bydbr.F90 +++ b/src/ecwam/sinput_bydbr.F90 @@ -8,7 +8,7 @@ ! SUBROUTINE SINPUT_BYDBR (NGST, LLSNEG, KIJS, KIJL, FL1, & - & WAVNUM, CINV, XK2CG, & + & WAVNUM, CGROUP, CINV, XK2CG, & & WDWAVE, WSWAVE, UFRIC, Z0M, & & COSWDIF, SINWDIF2, & & RAORW, WSTAR, RNFAC, & @@ -29,7 +29,7 @@ SUBROUTINE SINPUT_BYDBR (NGST, LLSNEG, KIJS, KIJL, FL1, & ! ---------- ! *CALL* *SINPUT_BYDBR (NGST, LLSNEG, KIJS, KIJL, FL1, -! & WAVNUM, CINV, XK2CG, +! & WAVNUM, CGROUP, CINV, XK2CG, ! & WSWAVE, WDWAVE, UFRIC, Z0M, ! & COSWDIF, SINWDIF2, ! & RAORW, WSTAR, RNFAC, @@ -41,6 +41,7 @@ SUBROUTINE SINPUT_BYDBR (NGST, LLSNEG, KIJS, KIJL, FL1, & ! *KIJL* - INDEX OF LAST GRIDPOINT. ! *FL1* - SPECTRUM. ! *WAVNUM* - WAVE NUMBER. +! *CGROUP* - GROUP SPEED ! *CINV* - INVERSE PHASE VELOCITY. ! *XK2CG* - (WAVNUM)**2 * GROUP SPPED. ! *WDWAVE* - WIND DIRECTION IN RADIANS IN OCEANOGRAPHIC @@ -110,7 +111,7 @@ SUBROUTINE SINPUT_BYDBR (NGST, LLSNEG, KIJS, KIJL, FL1, & LOGICAL, INTENT(IN) :: LLSNEG INTEGER(KIND=JWIM), INTENT(IN) :: KIJS, KIJL REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(IN) :: FL1 - REAL(KIND=JWRB), DIMENSION(KIJL,NFRE), INTENT(IN) :: WAVNUM, CINV, XK2CG + REAL(KIND=JWRB), DIMENSION(KIJL,NFRE), INTENT(IN) :: WAVNUM, CGROUP, CINV, XK2CG REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: WDWAVE, WSWAVE REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: Z0M, UFRIC REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: RAORW, WSTAR, RNFAC @@ -119,12 +120,12 @@ SUBROUTINE SINPUT_BYDBR (NGST, LLSNEG, KIJS, KIJL, FL1, & REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(OUT) :: FLD, SL, SPOS REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(OUT) :: XLLWS + LOGICAL :: LLFACT INTEGER(KIND=JWIM) :: IJ, K, M, IND, IGST INTEGER(KIND=JWIM) :: NSPEC !num. of freqs, dirs, spec. bins INTEGER(KIND=JWIM), DIMENSION(NANG) :: ITHN INTEGER(KIND=JWIM), DIMENSION(NFRE) :: IKN - REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: CGROUP REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: CG2, ECOS2, ESIN2, DSII2 REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: WN2, SIG2 REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: SQRTBN2, CINV2, A @@ -209,7 +210,6 @@ SUBROUTINE SINPUT_BYDBR (NGST, LLSNEG, KIJS, KIJL, FL1, & DO M=1,NFRE DO IJ=KIJS,KIJL CM(IJ,M) = WAVNUM(IJ,M)*SIGM1(M) - CGROUP(IJ,M) = XK2CG(IJ,M)/(WAVNUM(IJ,M)**2) ! TODO: better to pass this in from implsch level? ENDDO ENDDO @@ -326,11 +326,13 @@ SUBROUTINE SINPUT_BYDBR (NGST, LLSNEG, KIJS, KIJL, FL1, & !/ conversion: !/ UPROXY = SIN6WS * UST !/ -!/ SIN6WS = FRIC = 28.0 following Komen et al. (1984) -!/ SIN6WS = 32.0 suggested by E. Rogers (2014) +!/ SIN6WS = FRIC = 28.0 following Komen et al. (1984) (developed seas) +!/ SIN6WS = 32.0 suggested by E. Rogers (2014) (young seas) ! DO IGST=1,NGST UPROXY(IGST) = FRIC * CDFAC * USTARGST(IJ,IGST) ! Scale wind speed by FRIC and CDFAC + ! UPROXY(IGST) = WAVEAGE * CDFAC * USTARGST(IJ,IGST) ! TODO: Add in dependency on wave-induced stress + ! (note that this line is also used in LFACTOR, and would also need to be adjusted there) ENDDO ! ! To reshape from 1D to 2D: @@ -394,15 +396,21 @@ SUBROUTINE SINPUT_BYDBR (NGST, LLSNEG, KIJS, KIJL, FL1, & ! !/ 6) --- apply reduction (LFACT) to the entire spectrum ------------- / - DO IGST=1,NGST - IF (SUM(LFACT(:,IGST)) .LT. NFRE) THEN - DO K = 1, NANG - D(IKN+K-1,IGST) = D(IKN+K-1,IGST) * LFACT(:,IGST) - END DO - S(:,IGST) = D(:,IGST) * A - END IF - DINPOS(:,:,IGST) = RESHAPE(D(:,IGST),(/ NANG, NFRE /)) - ENDDO + + LLFACT = .TRUE. + ! TODO: if this shows to make a big difference, then I can make this logical more rigorous + ! (and also implement it to save costs in LFACTOR) + IF (LLFACT) THEN + DO IGST=1,NGST + IF (SUM(LFACT(:,IGST)) .LT. NFRE) THEN + DO K = 1, NANG + D(IKN+K-1,IGST) = D(IKN+K-1,IGST) * LFACT(:,IGST) + END DO + S(:,IGST) = D(:,IGST) * A + END IF + DINPOS(:,:,IGST) = RESHAPE(D(:,IGST),(/ NANG, NFRE /)) + ENDDO + END IF ! !/ 7) --- compute negative wind input for adverse winds. negative diff --git a/src/ecwam/stresso.F90 b/src/ecwam/stresso.F90 index ae9a406e4..8027b16f0 100644 --- a/src/ecwam/stresso.F90 +++ b/src/ecwam/stresso.F90 @@ -143,6 +143,15 @@ SUBROUTINE STRESSO (KIJS, KIJL, MIJ, RHOWGDFTH, & ENDDO ENDIF +! --------------------------------------------------------------------------------- +! --------------------------------------------------------------------------------- +! --------------------------------------------------------------------------------- +! --------------------------------------------------------------------------------- +! --------------------------------------------------------------------------------- +! --------------------------------------------------------------------------------- + ! this is all IPHYS=0,1 + + !* CALCULATE LOW-FREQUENCY CONTRIBUTION TO STRESS AND ENERGY FLUX (positive sinput). ! --------------------------------------------------------------------------------- DO M=1,NFRE @@ -222,6 +231,26 @@ SUBROUTINE STRESSO (KIJS, KIJL, MIJ, RHOWGDFTH, & ENDDO ENDIF + + ! this is the end of the IPHYS=0,1 relevant part +! --------------------------------------------------------------------------------- +! --------------------------------------------------------------------------------- +! --------------------------------------------------------------------------------- +! --------------------------------------------------------------------------------- +! --------------------------------------------------------------------------------- +! --------------------------------------------------------------------------------- + ! this for IPHYS=2 + + ! essentially the same as what is done in LFACTOR + + + ! this is the end of the IPHYS=2 relevant part +! --------------------------------------------------------------------------------- +! --------------------------------------------------------------------------------- +! --------------------------------------------------------------------------------- +! --------------------------------------------------------------------------------- +! --------------------------------------------------------------------------------- +! --------------------------------------------------------------------------------- IF ( LLPHIWA ) THEN DO IJ=KIJS,KIJL PHIWA(IJ) = PHIWA(IJ) + PHIHF(IJ) diff --git a/src/ecwam/tau_wave_atmos.F90 b/src/ecwam/tau_wave_atmos.F90 index 5cca15467..f6e1da8c5 100644 --- a/src/ecwam/tau_wave_atmos.F90 +++ b/src/ecwam/tau_wave_atmos.F90 @@ -123,10 +123,8 @@ SUBROUTINE TAU_WAVE_ATMOS(S, CINV, SIG, DSII, TAUNWX, TAUNWY ) ! grid per se. Limit the constraint to the positive part of the ! wind input only. ---------------------------------------------- / IF (NK .LT. NK10Hz) THEN - SDENSX10Hz(1:NK) = SUM(ABS(MIN(0.0_JWRB,S))*& - & RESHAPE(ECOS2,(/NTH,NK/)),1) * DELTH - SDENSY10Hz(1:NK) = SUM(ABS(MIN(0.0_JWRB,S))*& - & RESHAPE(ESIN2,(/NTH,NK/)),1) * DELTH + SDENSX10Hz(1:NK) = SUM(ABS(MIN(0.0_JWRB,S))*RESHAPE(ECOS2,(/NTH,NK/)),1) * DELTH + SDENSY10Hz(1:NK) = SUM(ABS(MIN(0.0_JWRB,S))*RESHAPE(ESIN2,(/NTH,NK/)),1) * DELTH SIG10Hz = SIG(1)*FRATIO**(IK10Hz-1.0_JWRB) CINV10Hz(1:NK) = CINV CINV10Hz(NK+1:NK10Hz) = SIG10Hz(NK+1:NK10Hz)*0.101978_JWRB @@ -137,18 +135,14 @@ SUBROUTINE TAU_WAVE_ATMOS(S, CINV, SIG, DSII, TAUNWX, TAUNWY ) & (FRATIO-1.0_JWRB) / FRATIO ! ! --- Spectral slope for S_IN(F) is proportional to F**(-2) ------ / - SDENSX10Hz(NK+1:NK10Hz) = SDENSX10Hz(NK) * & - & (SIG10Hz(NK)/SIG10Hz(NK+1:NK10Hz))**2 - SDENSY10hz(NK+1:NK10Hz) = SDENSY10Hz(NK) * & - & (SIG10Hz(NK)/SIG10Hz(NK+1:NK10Hz))**2 + SDENSX10Hz(NK+1:NK10Hz) = SDENSX10Hz(NK) * (SIG10Hz(NK)/SIG10Hz(NK+1:NK10Hz))**2 + SDENSY10hz(NK+1:NK10Hz) = SDENSY10Hz(NK) * (SIG10Hz(NK)/SIG10Hz(NK+1:NK10Hz))**2 ELSE SIG10Hz = SIG CINV10Hz = CINV DSII10Hz = DSII - SDENSX10Hz(1:NK) = SUM(ABS(MIN(0.0_JWRB,S))*& - & RESHAPE(ECOS2,(/NTH,NK/)),1) * DELTH - SDENSY10Hz(1:NK) = SUM(ABS(MIN(0.0_JWRB,S))*& - & RESHAPE(ESIN2,(/NTH,NK/)),1) * DELTH + SDENSX10Hz(1:NK) = SUM(ABS(MIN(0.0_JWRB,S))*RESHAPE(ECOS2,(/NTH,NK/)),1) * DELTH + SDENSY10Hz(1:NK) = SUM(ABS(MIN(0.0_JWRB,S))*RESHAPE(ESIN2,(/NTH,NK/)),1) * DELTH END IF ! !/ 2) --- Stress calculation ----------------------------------------- / From af9a3436edabcf31f2d11fff36982dad0bd9ba8d Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Thu, 14 Aug 2025 15:48:52 +0000 Subject: [PATCH 05/89] add frcutindex_bydb --- .gitignore | 1 + src/ecwam/CMakeLists.txt | 2 ++ src/ecwam/frcutindex_bydb.F90 | 4 ++-- src/ecwam/sinflx.F90 | 1 + src/ecwam/wdfluxes.F90 | 2 +- 5 files changed, 7 insertions(+), 3 deletions(-) diff --git a/.gitignore b/.gitignore index c32398057..312ebb7bf 100755 --- a/.gitignore +++ b/.gitignore @@ -16,5 +16,6 @@ ecbundle *.DS_Store .vscode *.mod +x*.sh __pycache__/ diff --git a/src/ecwam/CMakeLists.txt b/src/ecwam/CMakeLists.txt index f928cbd4b..06b9e1c0a 100644 --- a/src/ecwam/CMakeLists.txt +++ b/src/ecwam/CMakeLists.txt @@ -81,6 +81,8 @@ list( APPEND ecwam_srcs fldinter.F90 fndprt.F90 frcutindex.F90 + frcutindex_default.F90 + frcutindex_bydb.F90 gc_dispersion.h get_preset_wgrib_template.F90 getbobstrct.F90 diff --git a/src/ecwam/frcutindex_bydb.F90 b/src/ecwam/frcutindex_bydb.F90 index 3a39ef508..3b4a55248 100644 --- a/src/ecwam/frcutindex_bydb.F90 +++ b/src/ecwam/frcutindex_bydb.F90 @@ -43,7 +43,7 @@ SUBROUTINE FRCUTINDEX_BYDB (KIJS, KIJL, FM, UFRIC, CICOVER, & USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU - USE YOWCOUP , ONLY : TAILFACTOR, TAILFACTOR_PM + USE YOWPHYS , ONLY : TAILFACTOR, TAILFACTOR_PM USE YOWFRED , ONLY : FR ,DFIM ,FRATIO ,FLOGSPRDM1, & & DELTH ,RHOWG_DFIM ,FRIC USE YOWICE , ONLY : CITHRSH_TAIL @@ -58,7 +58,7 @@ SUBROUTINE FRCUTINDEX_BYDB (KIJS, KIJL, FM, UFRIC, CICOVER, & INTEGER(KIND=JWIM), INTENT(IN) :: KIJS, KIJL INTEGER(KIND=JWIM), INTENT(OUT) :: MIJ(KIJL) - REAL(KIND=JWRB),DIMENSION(KIJL), INTENT(IN) :: FM, UFRIC + REAL(KIND=JWRB),DIMENSION(KIJL), INTENT(IN) :: FM, UFRIC, CICOVER REAL(KIND=JWRB) :: ZHOOK_HANDLE diff --git a/src/ecwam/sinflx.F90 b/src/ecwam/sinflx.F90 index 68408bd25..987a804d8 100644 --- a/src/ecwam/sinflx.F90 +++ b/src/ecwam/sinflx.F90 @@ -55,6 +55,7 @@ SUBROUTINE SINFLX (ICALL, NCALL, KIJS, KIJL, & REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(INOUT) :: FL1 !! WAVE SPECTRUM. REAL(KIND=JWRB), DIMENSION(KIJL,NFRE), INTENT(IN) :: WAVNUM !! WAVE NUMBER. +REAL(KIND=JWRB), DIMENSION(KIJL,NFRE), INTENT(IN) :: CGROUP !! GROUP VELOCITY. REAL(KIND=JWRB), DIMENSION(KIJL,NFRE), INTENT(IN) :: CINV !! INVERSE PHASE VELOCITY. REAL(KIND=JWRB), DIMENSION(KIJL,NFRE), INTENT(IN) :: XK2CG !! (WAVNUM)**2 * GROUP SPPED. REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: WSWAVE !! WIND SPEED IN M/S. diff --git a/src/ecwam/wdfluxes.F90 b/src/ecwam/wdfluxes.F90 index cd0a63eea..e43ed67ea 100644 --- a/src/ecwam/wdfluxes.F90 +++ b/src/ecwam/wdfluxes.F90 @@ -203,7 +203,7 @@ SUBROUTINE WDFLUXES (KIJS, KIJL, & CALL SINFLX (ICALL, NCALL, KIJS, KIJL, & & LUPDTUS, & & FL1, & - & WAVNUM, CINV, XK2CG, & + & WAVNUM, CGROUP, CINV, XK2CG, & & WSWAVE, WDWAVE, AIRD, & & RAORW, WSTAR, CICOVER, & & COSWDIF, SINWDIF2, & From dc75235dabc3181771da7f5ce41979c20eb535d0 Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Thu, 14 Aug 2025 17:45:47 +0000 Subject: [PATCH 06/89] bring SINPUT_BYDBR into SINFLX_BYDBR --- src/ecwam/CMakeLists.txt | 4 + src/ecwam/calcphiwa.F90 | 2 +- src/ecwam/lfactor.F90 | 3 +- src/ecwam/sinflx.F90 | 120 ++----- src/ecwam/sinflx_ard_jan.F90 | 189 +++++++++++ src/ecwam/sinflx_bydbr.F90 | 619 +++++++++++++++++++++++++++++++++++ src/ecwam/sinput_jan.F90 | 4 +- src/ecwam/stresso.F90 | 20 -- src/ecwam/tau_wave_atmos.F90 | 10 +- 9 files changed, 852 insertions(+), 119 deletions(-) create mode 100644 src/ecwam/sinflx_ard_jan.F90 create mode 100644 src/ecwam/sinflx_bydbr.F90 diff --git a/src/ecwam/CMakeLists.txt b/src/ecwam/CMakeLists.txt index 06b9e1c0a..8406308eb 100644 --- a/src/ecwam/CMakeLists.txt +++ b/src/ecwam/CMakeLists.txt @@ -55,6 +55,7 @@ list( APPEND ecwam_srcs alphap_tail.F90 bouinpt.F90 buildstress.F90 + calcphiwa.F90 cal_second_order_spec.F90 cdustarz0.F90 check.F90 @@ -245,6 +246,8 @@ list( APPEND ecwam_srcs setmarstype.F90 setwavphys.F90 sinflx.F90 + sinflx_bydbr.F90 + sinflx_ard_jan.F90 sinput.F90 sinput_ard.F90 sinput_jan.F90 @@ -264,6 +267,7 @@ list( APPEND ecwam_srcs tables_2nd.F90 tabu_swellft.F90 tau_phi_hf.F90 + tau_wave_atmos.F90 taut_z0.F90 tauwinds.F90 topoar.F90 diff --git a/src/ecwam/calcphiwa.F90 b/src/ecwam/calcphiwa.F90 index 5449e63f2..525a61e1e 100644 --- a/src/ecwam/calcphiwa.F90 +++ b/src/ecwam/calcphiwa.F90 @@ -27,7 +27,7 @@ FUNCTION CALCPHIWA(SPOS,SNEG,DSII) RESULT(PHIWA) USE YOWPCONS , ONLY : G ,ROWATER USE YOWFRED , ONLY : DELTH USE YOWPARAM , ONLY : NANG ,NFRE - USE YOMHOOK , ONLY : LHOOK, DR_HOOK + USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK !---------------------------------------------------------------------- diff --git a/src/ecwam/lfactor.F90 b/src/ecwam/lfactor.F90 index 6b3c414ca..0cb7ecec7 100644 --- a/src/ecwam/lfactor.F90 +++ b/src/ecwam/lfactor.F90 @@ -130,8 +130,7 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, USDIR, ROAIRN, SIG, DSII, & !/ 0) --- Find the number of frequencies required to extend arrays !/ up to f=10Hz and allocate arrays --------------------------- / -!/ ALOG is the same as LOG - NK10Hz = CEILING(ALOG(FRQMAX/(SIG(1)/ZPI))/ALOG(FRATIO))+1 + NK10Hz = CEILING(LOG(FRQMAX/(SIG(1)/ZPI))/LOG(FRATIO))+1 NK10Hz = MAX(NK,NK10Hz) ! ALLOCATE(IK10Hz(NK10Hz)) diff --git a/src/ecwam/sinflx.F90 b/src/ecwam/sinflx.F90 index 987a804d8..0840c17f8 100644 --- a/src/ecwam/sinflx.F90 +++ b/src/ecwam/sinflx.F90 @@ -33,6 +33,7 @@ SUBROUTINE SINFLX (ICALL, NCALL, KIJS, KIJL, & USE YOWPARAM , ONLY : NANG ,NFRE USE YOWPHYS , ONLY : DTHRN_A ,DTHRN_U USE YOWWNDG , ONLY : ICODE ,ICODE_CPL + USE YOWSTAT , ONLY : IPHYS USE YOMHOOK , ONLY : LHOOK ,DR_HOOK, JPHOOK @@ -40,12 +41,8 @@ SUBROUTINE SINFLX (ICALL, NCALL, KIJS, KIJL, & IMPLICIT NONE -#include "airsea.intfb.h" -#include "femeanws.intfb.h" -#include "frcutindex.intfb.h" -#include "halphap.intfb.h" -#include "sinput.intfb.h" -#include "stresso.intfb.h" +#include "sinflx_ard_jan.intfb.h" +#include "sinflx_bydbr.intfb.h" INTEGER(KIND=JWIM), INTENT(IN) :: ICALL !! CALL NUMBER. INTEGER(KIND=JWIM), INTENT(IN) :: NCALL !! TOTAL NUMBER OF CALLS. @@ -102,87 +99,36 @@ SUBROUTINE SINFLX (ICALL, NCALL, KIJS, KIJL, & IF (LHOOK) CALL DR_HOOK('SINFLX',0,ZHOOK_HANDLE) -! UPDATE UFRIC AND Z0M -IF (ICALL == 1 ) THEN - IUSFG = 0 - IF (LWCOU) THEN - ICODE_WND = ICODE_CPL - ELSE - ICODE_WND = ICODE - ENDIF -ELSE - IUSFG = 1 - ICODE_WND = 3 -ENDIF - -IF(LLNORMAGAM .AND. LLCAPCHNK ) THEN - RNFAC(KIJS:KIJL) = 1.0_JWRB+DTHRN_A*(1.0_JWRB+TANH(WSWAVE(KIJS:KIJL)-DTHRN_U)) -ELSE - RNFAC(KIJS:KIJL) = 1.0_JWRB -ENDIF - - -IF(LUPDTUS) THEN - ! increase noise level in the tail - IF (ICALL == 1 ) THEN - DO K=1,NANG - FL1(KIJS:KIJL,K,NFRE) = MAX(FL1(KIJS:KIJL,K,NFRE),FLM(KIJS:KIJL,K)) - ENDDO - - IF (LLGCBZ0) THEN - !$loki inline - CALL HALPHAP(KIJS, KIJL, WAVNUM, COSWDIF, FL1, HALP) - ELSE - HALP(KIJS:KIJL) = 0.0_JWRB - ENDIF - - ENDIF - - !$loki inline - CALL AIRSEA (KIJS, KIJL, & -& HALP, WSWAVE, WDWAVE, TAUW, TAUWDIR, RNFAC, & -& UFRIC, Z0M, Z0B, CHRNCK, ICODE_WND, IUSFG) - -ENDIF - -! COMPUTE WIND INPUT -!! FLD AND SL ARE INITIALISED IN SINPUT -IF(ICALL < NCALL ) THEN - NGST = 1 - LLPHIWA = .FALSE. - LLSNEG = .FALSE. -ELSE - NGST = 2 - LLPHIWA = .TRUE. - LLSNEG = .TRUE. -ENDIF - -!$loki inline -CALL SINPUT (NGST, LLSNEG, KIJS, KIJL, FL1, & -& WAVNUM, CGROUP, CINV, XK2CG, & -& WDWAVE, WSWAVE, UFRIC, Z0M, & -& COSWDIF, SINWDIF2, & -& RAORW, WSTAR, RNFAC, & -& CHRNCK, FLD, SL, SPOS, XLLWS) - - -! MEAN FREQUENCY CHARACTERISTIC FOR WIND SEA -!$loki inline -CALL FEMEANWS(KIJS, KIJL, FL1, XLLWS, FMEANWS) - -! COMPUTE LAST FREQUENCY INDEX OF PROGNOSTIC PART OF SPECTRUM. -!$loki inline -CALL FRCUTINDEX(KIJS, KIJL, FMEAN, FMEANWS, UFRIC, CICOVER, MIJ, RHOWGDFTH) - -! UPDATE TAUW -!$loki inline -CALL STRESSO (KIJS, KIJL, MIJ, RHOWGDFTH, & -& FL1, SL, SPOS, & -& CINV, & -& WDWAVE, UFRIC, Z0M, AIRD, RNFAC, & -& COSWDIF, SINWDIF2, & -& TAUW, TAUWDIR, PHIWA, LLPHIWA) -! ---------------------------------------------------------------------- +SELECT CASE (IPHYS) +CASE(0,1) + CALL SINFLX_ARD_JAN (ICALL, NCALL, KIJS, KIJL, & + & LUPDTUS, & + & FL1, & + & WAVNUM,CGROUP, CINV, XK2CG,& + & WSWAVE, WDWAVE, AIRD, & + & RAORW, WSTAR, CICOVER, & + & COSWDIF, SINWDIF2, & + & FMEAN, HALP, FMEANWS, & + & FLM, & + & UFRIC, TAUW, TAUWDIR, & + & Z0M, Z0B, CHRNCK, PHIWA, & + & FLD, SL, SPOS, & + & MIJ, RHOWGDFTH, XLLWS) +CASE(2) + CALL SINFLX_BYDBR (ICALL, NCALL, KIJS, KIJL, & + & LUPDTUS, & + & FL1, & + & WAVNUM,CGROUP, CINV, XK2CG,& + & WSWAVE, WDWAVE, AIRD, & + & RAORW, WSTAR, CICOVER, & + & COSWDIF, SINWDIF2, & + & FMEAN, HALP, FMEANWS, & + & FLM, & + & UFRIC, TAUW, TAUWDIR, & + & Z0M, Z0B, CHRNCK, PHIWA, & + & FLD, SL, SPOS, & + & MIJ, RHOWGDFTH, XLLWS) +END SELECT IF (LHOOK) CALL DR_HOOK('SINFLX',1,ZHOOK_HANDLE) diff --git a/src/ecwam/sinflx_ard_jan.F90 b/src/ecwam/sinflx_ard_jan.F90 new file mode 100644 index 000000000..fe9cb24a3 --- /dev/null +++ b/src/ecwam/sinflx_ard_jan.F90 @@ -0,0 +1,189 @@ +! (C) Copyright 1989- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! + +SUBROUTINE SINFLX_ARD_JAN (ICALL, NCALL, KIJS, KIJL, & + & LUPDTUS, & + & FL1, & + & WAVNUM,CGROUP, CINV, XK2CG,& + & WSWAVE, WDWAVE, AIRD, & + & RAORW, WSTAR, CICOVER, & + & COSWDIF, SINWDIF2, & + & FMEAN, HALP, FMEANWS, & + & FLM, & + & UFRIC, TAUW, TAUWDIR, & + & Z0M, Z0B, CHRNCK, PHIWA, & + & FLD, SL, SPOS, & + & MIJ, RHOWGDFTH, XLLWS) + +! ---------------------------------------------------------------------- + +!**** *SINFLX* - UPDATE STRESS AND COMPUTE WIND INPUT SOURCE TERM. + +! ---------------------------------------------------------------------- + + USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU + + USE YOWCOUP , ONLY : LWCOU ,LLCAPCHNK , LLGCBZ0, LLNORMAGAM + USE YOWPARAM , ONLY : NANG ,NFRE + USE YOWPHYS , ONLY : DTHRN_A ,DTHRN_U + USE YOWWNDG , ONLY : ICODE ,ICODE_CPL + + USE YOMHOOK , ONLY : LHOOK ,DR_HOOK, JPHOOK + +! ---------------------------------------------------------------------- + + IMPLICIT NONE + +#include "airsea.intfb.h" +#include "femeanws.intfb.h" +#include "frcutindex.intfb.h" +#include "halphap.intfb.h" +#include "sinput.intfb.h" +#include "stresso.intfb.h" + +INTEGER(KIND=JWIM), INTENT(IN) :: ICALL !! CALL NUMBER. +INTEGER(KIND=JWIM), INTENT(IN) :: NCALL !! TOTAL NUMBER OF CALLS. +INTEGER(KIND=JWIM), INTENT(IN) :: KIJS, KIJL !! GRID POINT INDEXES. + +LOGICAL, INTENT(IN) :: LUPDTUS !! IF TRUE UFRIC AND Z0M WILL BE UPDATED (CALLING AIRSEA). + +REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(INOUT) :: FL1 !! WAVE SPECTRUM. +REAL(KIND=JWRB), DIMENSION(KIJL,NFRE), INTENT(IN) :: WAVNUM !! WAVE NUMBER. +REAL(KIND=JWRB), DIMENSION(KIJL,NFRE), INTENT(IN) :: CGROUP !! GROUP VELOCITY. +REAL(KIND=JWRB), DIMENSION(KIJL,NFRE), INTENT(IN) :: CINV !! INVERSE PHASE VELOCITY. +REAL(KIND=JWRB), DIMENSION(KIJL,NFRE), INTENT(IN) :: XK2CG !! (WAVNUM)**2 * GROUP SPPED. +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: WSWAVE !! WIND SPEED IN M/S. +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: WDWAVE !! WIND DIRECTION IN RADIANS IN OCEANOGRAPHIC NOTATION. +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: AIRD !! AIR DENSITY (KG/M**3). +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: RAORW !! RATIO AIR DENSITY TO WATER DENSITY. +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: WSTAR !! FREE CONVECTION VELOCITY SCALE (M/S) +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: CICOVER !! SEA ICE COVER. +REAL(KIND=JWRB), DIMENSION(KIJL, NANG), INTENT(IN) :: COSWDIF !! COS(TH(K)-WDWAVE(IJ)) +REAL(KIND=JWRB), DIMENSION(KIJL, NANG), INTENT(IN) :: SINWDIF2 !! SIN(TH(K)-WDWAVE(IJ))**2 +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: FMEAN !! MEAN FREQUENCY. +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: HALP !! 1/2 PHILLIPS PARAMETER +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(OUT) :: FMEANWS !! MEAN FREQUENCY OF THE WINDSEA. +REAL(KIND=JWRB), DIMENSION(KIJL,NANG), INTENT(IN) :: FLM !! SPECTAL DENSITY MINIMUM VALUE +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: UFRIC !! FRICTION VELOCITY IN M/S. +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: TAUW !! WAVE STRESS IN (M/S)**2 +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: TAUWDIR !! WAVE STRESS DIRECTION. +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: Z0M !! ROUGHNESS LENGTH IN M. +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: Z0B !! BACKGROUND ROUGHNESS LENGTH. +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: CHRNCK !! CHARNOCK COEFFICIENT. + +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(OUT) :: PHIWA !! ENERGY FLUX FROM WIND INTO WAVES. +REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(OUT) :: FLD !! DIAGONAL MATRIX OF FUNCTIONAL DERIVATIVE. +REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(OUT) :: SL !! TOTAL SOURCE FUNCTION ARRAY. +REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(OUT) :: SPOS !! POSITIVE SINPUT ONLY. + +INTEGER(KIND=JWIM), INTENT(OUT) :: MIJ(KIJL) !! LAST FREQUENCY INDEX OF THE PROGNOSTIC RANGE. + +REAL(KIND=JWRB), DIMENSION(KIJL,NFRE), INTENT(OUT) :: RHOWGDFTH !! WATER DENSITY * G * DF * DTHETA + +REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(OUT) :: XLLWS !! TOTAL WINDSEA MASK FROM INPUT SOURCE TERM. + + +INTEGER(KIND=JWIM) :: IJ, K +INTEGER(KIND=JWIM) :: IUSFG, ICODE_WND +INTEGER(KIND=JWIM) :: NGST + +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE +REAL(KIND=JWRB), DIMENSION(KIJL) :: RNFAC + +LOGICAL :: LLPHIWA, LLSNEG + +! ---------------------------------------------------------------------- + +IF (LHOOK) CALL DR_HOOK('SINFLX',0,ZHOOK_HANDLE) + +! UPDATE UFRIC AND Z0M +IF (ICALL == 1 ) THEN + IUSFG = 0 + IF (LWCOU) THEN + ICODE_WND = ICODE_CPL + ELSE + ICODE_WND = ICODE + ENDIF +ELSE + IUSFG = 1 + ICODE_WND = 3 +ENDIF + +IF(LLNORMAGAM .AND. LLCAPCHNK ) THEN + RNFAC(KIJS:KIJL) = 1.0_JWRB+DTHRN_A*(1.0_JWRB+TANH(WSWAVE(KIJS:KIJL)-DTHRN_U)) +ELSE + RNFAC(KIJS:KIJL) = 1.0_JWRB +ENDIF + + +IF(LUPDTUS) THEN + ! increase noise level in the tail + IF (ICALL == 1 ) THEN + DO K=1,NANG + FL1(KIJS:KIJL,K,NFRE) = MAX(FL1(KIJS:KIJL,K,NFRE),FLM(KIJS:KIJL,K)) + ENDDO + + IF (LLGCBZ0) THEN + !$loki inline + CALL HALPHAP(KIJS, KIJL, WAVNUM, COSWDIF, FL1, HALP) + ELSE + HALP(KIJS:KIJL) = 0.0_JWRB + ENDIF + + ENDIF + + !$loki inline + CALL AIRSEA (KIJS, KIJL, & +& HALP, WSWAVE, WDWAVE, TAUW, TAUWDIR, RNFAC, & +& UFRIC, Z0M, Z0B, CHRNCK, ICODE_WND, IUSFG) + +ENDIF + +! COMPUTE WIND INPUT +!! FLD AND SL ARE INITIALISED IN SINPUT +IF(ICALL < NCALL ) THEN + NGST = 1 + LLPHIWA = .FALSE. + LLSNEG = .FALSE. +ELSE + NGST = 2 + LLPHIWA = .TRUE. + LLSNEG = .TRUE. +ENDIF + +!$loki inline +CALL SINPUT (NGST, LLSNEG, KIJS, KIJL, FL1, & +& WAVNUM, CGROUP, CINV, XK2CG, & +& WDWAVE, WSWAVE, UFRIC, Z0M, & +& COSWDIF, SINWDIF2, & +& RAORW, WSTAR, RNFAC, & +& CHRNCK, FLD, SL, SPOS, XLLWS) + + +! MEAN FREQUENCY CHARACTERISTIC FOR WIND SEA +!$loki inline +CALL FEMEANWS(KIJS, KIJL, FL1, XLLWS, FMEANWS) + +! COMPUTE LAST FREQUENCY INDEX OF PROGNOSTIC PART OF SPECTRUM. +!$loki inline +CALL FRCUTINDEX(KIJS, KIJL, FMEAN, FMEANWS, UFRIC, CICOVER, MIJ, RHOWGDFTH) + +! UPDATE TAUW +!$loki inline +CALL STRESSO (KIJS, KIJL, MIJ, RHOWGDFTH, & +& FL1, SL, SPOS, & +& CINV, & +& WDWAVE, UFRIC, Z0M, AIRD, RNFAC, & +& COSWDIF, SINWDIF2, & +& TAUW, TAUWDIR, PHIWA, LLPHIWA) +! ---------------------------------------------------------------------- + +IF (LHOOK) CALL DR_HOOK('SINFLX',1,ZHOOK_HANDLE) + +END SUBROUTINE SINFLX_ARD_JAN diff --git a/src/ecwam/sinflx_bydbr.F90 b/src/ecwam/sinflx_bydbr.F90 new file mode 100644 index 000000000..f546fe739 --- /dev/null +++ b/src/ecwam/sinflx_bydbr.F90 @@ -0,0 +1,619 @@ +! (C) Copyright 1989- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! + +SUBROUTINE SINFLX_BYDBR (ICALL, NCALL, KIJS, KIJL, & + & LUPDTUS, & + & FL1, & + & WAVNUM,CGROUP, CINV, XK2CG,& + & WSWAVE, WDWAVE, AIRD, & + & RAORW, WSTAR, CICOVER, & + & COSWDIF, SINWDIF2, & + & FMEAN, HALP, FMEANWS, & + & FLM, & + & UFRIC, TAUW, TAUWDIR, & + & Z0M, Z0B, CHRNCK, PHIWA, & + & FLD, SL, SPOS, & + & MIJ, RHOWGDFTH, XLLWS) + +! ---------------------------------------------------------------------- + +!**** *SINFLX_BYDBR* - COMPUTATION OF INPUT SOURCE FUNCTION AND STRESSES + + +!* PURPOSE. +! --------- + +! Observation-based source term for wind input after Donelan, Babanin, +! Young and Banner (Donelan et al ,2006) following the implementation +! by Rogers et al. (2012). +! +!** INTERFACE. +! ---------- + +! *CALL* *SINFLX_BYDBR (NGST, LLSNEG, KIJS, KIJL, FL1, +! & WAVNUM, CGROUP, CINV, XK2CG, +! & WSWAVE, WDWAVE, UFRIC, Z0M, +! & COSWDIF, SINWDIF2, +! & RAORW, WSTAR, RNFAC, +! & FLD, SL, SPOS, XLLWS) +! *NGST* - IF = 1 THEN NO GUSTINESS PARAMETERISATION +! - IF = 2 THEN GUSTINESS PARAMETERISATION +! *LLSNEG- IF TRUE THEN THE NEGATIVE SINPUT (SWELL DAMPING) WILL BE COMPUTED +! *KIJS* - INDEX OF FIRST GRIDPOINT. +! *KIJL* - INDEX OF LAST GRIDPOINT. +! *FL1* - SPECTRUM. +! *WAVNUM* - WAVE NUMBER. +! *CGROUP* - GROUP SPEED +! *CINV* - INVERSE PHASE VELOCITY. +! *XK2CG* - (WAVNUM)**2 * GROUP SPPED. +! *WDWAVE* - WIND DIRECTION IN RADIANS IN OCEANOGRAPHIC +! NOTATION (POINTING ANGLE OF WIND VECTOR, +! CLOCKWISE FROM NORTH). +! *UFRIC* - NEW FRICTION VELOCITY IN M/S. +! *Z0M* - ROUGHNESS LENGTH IN M. +! *COSWDIF* - COS(TH(K)-WDWAVE(IJ)) +! *SINWDIF2* - SIN(TH(K)-WDWAVE(IJ))**2 +! *RAORW* - RATIO AIR DENSITY TO WATER DENSITY. +! *WSTAR* - FREE CONVECTION VELOCITY SCALE (M/S). +! *RNFAC* - WIND DEPENDENT FACTOR USED IN THE GROWTH RENORMALISATION. +! *CHRNCK*- CHARNOCK COEFFICIENT +! *FLD* - DIAGONAL MATRIX OF FUNCTIONAL DERIVATIVE. +! *SL* - TOTAL SOURCE FUNCTION ARRAY. +! *SPOS* - POSITIVE SOURCE FUNCTION ARRAY. +! *XLLWS* - = 1 WHERE SINPUT IS POSITIVE + +! METHOD. +! ------- + +! SEE REFERENCE. + +! EXTERNALS. +! ---------- +! TAU_WAVE_ATMOS +! LFACTOR +! IRANGE + +! ORIGIN. +! ---------- +! Adapted from Babanin Young Donelan & Banner (BYDB) physics +! as implemented as ST6 in WAVEWATCH-III +! WW3 module: W3SRC6MD +! WW3 subroutine: W3SIN6 +! Implementation into ECWAM DECEMBER 2021 by J. Kousal + + +! ---------------------------------------------------------------------- + + USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU + + USE YOWCOUP , ONLY : LWCOU ,LLCAPCHNK , LLGCBZ0, LLNORMAGAM + + USE YOWWNDG , ONLY : ICODE ,ICODE_CPL + + USE YOWFRED , ONLY : FR ,TH ,DFIM ,COSTH ,SINTH, ZPIFR, DELTH, FRATIO, FRIC + USE YOWPARAM , ONLY : NANG ,NFRE + USE YOWPCONS , ONLY : G ,GM1 ,EPSMIN, EPSUS, ZPI, ROWATER + USE YOWPHYS , ONLY : ZALP ,TAUWSHELTER, XKAPPA, BETAMAXOXKAPPA2, & + & RNU ,RNUM, & + & SWELLF ,SWELLF2 ,SWELLF3 ,SWELLF4 , SWELLF5, & + & SWELLF6 ,SWELLF7 ,SWELLF7M1, Z0RAT ,Z0TUBMAX , & + & ABMIN ,ABMAX, CDFAC, DTHRN_A ,DTHRN_U + USE YOWTEST , ONLY : IU06 + USE YOWTABL , ONLY : IAB ,SWELLFT + + USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK + +! ---------------------------------------------------------------------- + + IMPLICIT NONE + +#include "airsea.intfb.h" +#include "femeanws.intfb.h" +#include "frcutindex.intfb.h" +#include "halphap.intfb.h" +#include "wsigstar.intfb.h" +#include "tau_wave_atmos.intfb.h" +#include "lfactor.intfb.h" +#include "irange.intfb.h" +#include "calcphiwa.intfb.h" + + +INTEGER(KIND=JWIM), INTENT(IN) :: ICALL !! CALL NUMBER. +INTEGER(KIND=JWIM), INTENT(IN) :: NCALL !! TOTAL NUMBER OF CALLS. +INTEGER(KIND=JWIM), INTENT(IN) :: KIJS, KIJL !! GRID POINT INDEXES. + +LOGICAL, INTENT(IN) :: LUPDTUS !! IF TRUE UFRIC AND Z0M WILL BE UPDATED (CALLING AIRSEA). + +REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(INOUT) :: FL1 !! WAVE SPECTRUM. +REAL(KIND=JWRB), DIMENSION(KIJL,NFRE), INTENT(IN) :: WAVNUM !! WAVE NUMBER. +REAL(KIND=JWRB), DIMENSION(KIJL,NFRE), INTENT(IN) :: CGROUP !! GROUP VELOCITY. +REAL(KIND=JWRB), DIMENSION(KIJL,NFRE), INTENT(IN) :: CINV !! INVERSE PHASE VELOCITY. +REAL(KIND=JWRB), DIMENSION(KIJL,NFRE), INTENT(IN) :: XK2CG !! (WAVNUM)**2 * GROUP SPPED. +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: WSWAVE !! WIND SPEED IN M/S. +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: WDWAVE !! WIND DIRECTION IN RADIANS IN OCEANOGRAPHIC NOTATION. +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: AIRD !! AIR DENSITY (KG/M**3). +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: RAORW !! RATIO AIR DENSITY TO WATER DENSITY. +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: WSTAR !! FREE CONVECTION VELOCITY SCALE (M/S) +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: CICOVER !! SEA ICE COVER. +REAL(KIND=JWRB), DIMENSION(KIJL, NANG), INTENT(IN) :: COSWDIF !! COS(TH(K)-WDWAVE(IJ)) +REAL(KIND=JWRB), DIMENSION(KIJL, NANG), INTENT(IN) :: SINWDIF2 !! SIN(TH(K)-WDWAVE(IJ))**2 +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: FMEAN !! MEAN FREQUENCY. +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: HALP !! 1/2 PHILLIPS PARAMETER +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(OUT) :: FMEANWS !! MEAN FREQUENCY OF THE WINDSEA. +REAL(KIND=JWRB), DIMENSION(KIJL,NANG), INTENT(IN) :: FLM !! SPECTAL DENSITY MINIMUM VALUE +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: UFRIC !! FRICTION VELOCITY IN M/S. +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: TAUW !! WAVE STRESS IN (M/S)**2 +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: TAUWDIR !! WAVE STRESS DIRECTION. +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: Z0M !! ROUGHNESS LENGTH IN M. +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: Z0B !! BACKGROUND ROUGHNESS LENGTH. +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: CHRNCK !! CHARNOCK COEFFICIENT. + +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(OUT) :: PHIWA !! ENERGY FLUX FROM WIND INTO WAVES. +REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(OUT) :: FLD !! DIAGONAL MATRIX OF FUNCTIONAL DERIVATIVE. +REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(OUT) :: SL !! TOTAL SOURCE FUNCTION ARRAY. +REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(OUT) :: SPOS !! POSITIVE SINPUT ONLY. + +INTEGER(KIND=JWIM), INTENT(OUT) :: MIJ(KIJL) !! LAST FREQUENCY INDEX OF THE PROGNOSTIC RANGE. + +REAL(KIND=JWRB), DIMENSION(KIJL,NFRE), INTENT(OUT) :: RHOWGDFTH !! WATER DENSITY * G * DF * DTHETA + +REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(OUT) :: XLLWS !! TOTAL WINDSEA MASK FROM INPUT SOURCE TERM. + +INTEGER(KIND=JWIM) :: IUSFG, ICODE_WND +INTEGER(KIND=JWIM), PARAMETER :: NGST=2 + +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE +REAL(KIND=JWRB), DIMENSION(KIJL) :: RNFAC + +LOGICAL :: LLFACT +INTEGER(KIND=JWIM) :: IJ, K, M, IND, IGST +INTEGER(KIND=JWIM) :: NSPEC !num. of freqs, dirs, spec. bins +INTEGER(KIND=JWIM), DIMENSION(NANG) :: ITHN +INTEGER(KIND=JWIM), DIMENSION(NFRE) :: IKN + +REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: CG2, ECOS2, ESIN2, DSII2 +REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: WN2, SIG2 +REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: SQRTBN2, CINV2, A +REAL(KIND=JWRB), DIMENSION(NFRE) :: DSII, SIG, CINV1, DF +REAL(KIND=JWRB), DIMENSION(NFRE) :: ADENSIG, KMAX, ANAR, SQRTBN +REAL(KIND=JWRB), DIMENSION(NANG,NFRE) :: KK +REAL(KIND=JWRB), DIMENSION(NANG,NFRE) :: SPOSDENSIG, SNEGDENSIG +REAL(KIND=JWRB), DIMENSION(NANG*NFRE,NGST) :: W1, W2, S, D +REAL(KIND=JWRB), DIMENSION(NFRE,NGST) :: LFACT +REAL(KIND=JWRB), DIMENSION(NANG,NFRE,NGST) :: SDENSIG, DINPOS, DINTOT + + +REAL(KIND=JWRB), PARAMETER :: SIN6A0 = 9.0E-2_JWRB ! ST6 PARAM +REAL(KIND=JWRB), DIMENSION(NGST) :: TAUWX, TAUWY ! Component of the wave-supported stress +REAL(KIND=JWRB), DIMENSION(NGST) :: TAUNWX, TAUNWY ! Component of the neg. wave-supported stress +REAL(KIND=JWRB) :: COSU, SINU +REAL(KIND=JWRB), DIMENSION(NGST) :: UPROXY + +REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: XK, CGG_WAM, CM +REAL(KIND=JWRB), DIMENSION(NFRE) :: SIGP2, SIGM1 + +! For USTAR, Z0, CHNK +REAL(KIND=JWRB), DIMENSION(KIJL,NGST) :: TAU +REAL(KIND=JWRB), PARAMETER :: ZRN=1.65E-6_JWRB ! effective kinematic viscosity (0.11*1.5e-5) +REAL(KIND=JWRB), PARAMETER :: RKAP = 0.4_JWRB +REAL(KIND=JWRB) :: ZNLEV, Z0, KUOUST, USTM1, USTM2 +REAL(KIND=JWRB), PARAMETER :: XEPS=0.00001_JWRB +REAL(KIND=JWRB), PARAMETER :: USTMIN=0.000001_JWRB +REAL(KIND=JWRB), PARAMETER :: PCHARMAX=0.1_JWRB +REAL(KIND=JWRB), PARAMETER :: Z0FG=0.01_JWRB +INTEGER(KIND=JWIM) :: ITER +REAL(KIND=JWRB) :: XZNLEV, PCHAROG, XKUTOP, XOLOGZ0 +REAL(KIND=JWRB) :: UST, USTOLD, Z0CH, Z0VIS, Z0TOT, FF, DELF +REAL(KIND=JWRB) :: CHARNOCK_MIN,CHNKMIN ! For Capping +INTEGER(KIND=JWIM), PARAMETER :: NITER=15 +REAL(KIND=JWRB), PARAMETER :: ALPHAMAX=0.1_JWRB +REAL(KIND=JWRB), PARAMETER :: AMAX=0.02_JWRB +REAL(KIND=JWRB), PARAMETER :: BMAX=0.01_JWRB +REAL(KIND=JWRB) :: ALPHAOGMAXU10 + +REAL(KIND=JWRB), DIMENSION(KIJL) :: ROAIRN, CHNKOG, TAUNW + +! For GUSTINESS +REAL(KIND=JWRB) :: AVG_GST +REAL(KIND=JWRB), DIMENSION(KIJL) :: SIG_N, TAUWGST_AVG, TAUWDIRGST_AVG, TAUNWGST_AVG, USTARGST_AVG +REAL(KIND=JWRB), DIMENSION(KIJL,NGST) :: TAUWGST, TAUWDIRGST, TAUNWGST, UABSGST, USTARGST, Z0GST +REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE) :: SLGST_AVG, SPOSGST_AVG, FLGST_AVG +REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE,NGST) :: SLGST, SPOSGST, FLGST + +! For PHIWA calculation +! REAL(KIND=JWRB),DIMENSION(KIJL,NFRE) :: RHOWGDFTH +! REAL(KIND=JWRB), DIMENSION(KIJL) :: SUMT + + +! ---------------------------------------------------------------------- + +IF (LHOOK) CALL DR_HOOK('SINFLX',0,ZHOOK_HANDLE) + +! UPDATE UFRIC AND Z0M +IF (ICALL == 1 ) THEN + IUSFG = 0 + IF (LWCOU) THEN + ICODE_WND = ICODE_CPL + ELSE + ICODE_WND = ICODE + ENDIF +ELSE + IUSFG = 1 + ICODE_WND = 3 +ENDIF + +IF(LLNORMAGAM .AND. LLCAPCHNK ) THEN + RNFAC(KIJS:KIJL) = 1.0_JWRB+DTHRN_A*(1.0_JWRB+TANH(WSWAVE(KIJS:KIJL)-DTHRN_U)) +ELSE + RNFAC(KIJS:KIJL) = 1.0_JWRB +ENDIF + + +IF(LUPDTUS) THEN + ! increase noise level in the tail + IF (ICALL == 1 ) THEN + DO K=1,NANG + FL1(KIJS:KIJL,K,NFRE) = MAX(FL1(KIJS:KIJL,K,NFRE),FLM(KIJS:KIJL,K)) + ENDDO + + IF (LLGCBZ0) THEN + !$loki inline + CALL HALPHAP(KIJS, KIJL, WAVNUM, COSWDIF, FL1, HALP) + ELSE + HALP(KIJS:KIJL) = 0.0_JWRB + ENDIF + + ENDIF + + !$loki inline + CALL AIRSEA (KIJS, KIJL, & +& HALP, WSWAVE, WDWAVE, TAUW, TAUWDIR, RNFAC, & +& UFRIC, Z0M, Z0B, CHRNCK, ICODE_WND, IUSFG) + +ENDIF + + +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! input source term!!!! (start) + +NSPEC = NANG * NFRE ! NUMBER OF SPECTRAL BINS + +! Wind height +ZNLEV = 10._JWRB + +! COMPUTE FREQUENCY INTERVALLS (borrowed from Wam_others/f4spec.F) +DO M = 1,NFRE + DF(M) = FR(M)*( FRATIO - 1.0_JWRB ) +ENDDO + +DO M = 1,NFRE + SIG(M) = ZPI*FR(M) + DSII(M) = ZPI*DF(M) + SIGM1(M) = 1.0_JWRB/SIG(M) + SIGP2(M) = SIG(M)**2 +END DO + +! TODO: clean up stuff in/out of IJ loops (sdissip_bydb + swldissip +sinput_bydb) +! TODO: confirm that I'm using exactly the same things here (I've now adopted them throughout the BYDBR code) +! - confirm CGG_WAM=CGROUP +! - confirm XK=WAVNUM + +DO M=1,NFRE + DO IJ=KIJS,KIJL + CM(IJ,M) = WAVNUM(IJ,M)*SIGM1(M) + ENDDO +ENDDO + + +ITHN = IRANGE(1,NANG,1) ! Index vector 1:NANG +DO M = 1, NFRE + ECOS2 (ITHN+(M-1)*NANG) = COSTH + ESIN2 (ITHN+(M-1)*NANG) = SINTH +END DO +! +IKN = IRANGE(1,NSPEC,NANG) ! Index vector for elements of 1 ... NFRE +! ! such that e.g. SIG(1:NFRE) = SIG2(IKN). + +DO K = 1, NANG ! Apply to all directions + DSII2 (IKN+(K-1)) = DSII + SIG2 (IKN+(K-1)) = SIG +END DO + +! ESTIMATE THE STANDARD DEVIATION OF GUSTINESS. +CALL WSIGSTAR (KIJS, KIJL, WSWAVE, UFRIC, Z0M, WSTAR, SIG_N) +AVG_GST = 1.0_JWRB/NGST + +DO IJ=KIJS,KIJL + USTARGST(IJ,1)= UFRIC(IJ)*(1.0_JWRB+SIG_N(IJ)) + USTARGST(IJ,2)= UFRIC(IJ)*(1.0_JWRB-SIG_N(IJ)) + CHNKOG(IJ) = CHRNCK(IJ)*GM1 + ROAIRN(IJ) = RAORW(IJ)*ROWATER +END DO + +! Define Z0GST associated with USTARGST (as in airsea_iter) +DO IGST=1,NGST + DO IJ=KIJS,KIJL + UST = USTARGST(IJ,IGST) + PCHAROG = MIN(CHNKOG(IJ),PCHARMAX/G) + Z0CH = PCHAROG*UST**2 + Z0VIS = ZRN/UST + Z0GST(IJ,IGST) = Z0CH+Z0VIS + ENDDO ! IJ loop ENDDO +ENDDO ! NGST loop ENDDO + +! Define UABSGST associated with USTARGST and Z0GST +! U10 = (u*/kappa) log (1 + Z/Z0), z=10 +DO IGST=1,NGST + DO IJ=KIJS,KIJL + UABSGST(IJ,IGST) = USTARGST(IJ,IGST)*LOG(1.0_JWRB + ZNLEV/Z0GST(IJ,IGST))/XKAPPA + END DO +END DO + +!/ --- Main loop over LOC ----------------------------------- / + + +! LOOP OVER LOCATIONS +DO IJ = KIJS,KIJL + + DO K = 1, NANG ! Apply to all directions + WN2 (IKN+(K-1)) = WAVNUM(IJ,:) ! using WAM native WN,CG + CG2 (IKN+(K-1)) = CGROUP(IJ,:) + END DO + + CINV2 = WN2 / SIG2 ! inverse phase speed + +!/ 0) --- set up a basic variables ----------------------------------- / + + COSU = COS(WDWAVE(IJ)) + SINU = SIN(WDWAVE(IJ)) +! + DO IGST=1,NGST + TAUNWX(IGST) = 0.0_JWRB + TAUNWY(IGST) = 0.0_JWRB + TAUWX(IGST) = 0.0_JWRB + TAUWY(IGST) = 0.0_JWRB + TAU(IJ,IGST) = 0.0_JWRB + ENDDO + +! +!/ --- scale friction velocity to wind speed (10m) in +!/ the boundary layer ----------------------------------------- / +!/ Donelan et al. (2006) used U10 or U_{λ/2} in their S_{in} +!/ parameterization. To avoid some disadvantages of using U10 or +!/ U_{λ/2}, Rogers et al. (2012) used the following engineering +!/ conversion: +!/ UPROXY = SIN6WS * UST +!/ +!/ SIN6WS = FRIC = 28.0 following Komen et al. (1984) (developed seas) +!/ SIN6WS = 32.0 suggested by E. Rogers (2014) (young seas) +! + DO IGST=1,NGST + UPROXY(IGST) = FRIC * CDFAC * USTARGST(IJ,IGST) ! Scale wind speed by FRIC and CDFAC + ! UPROXY(IGST) = WAVEAGE * CDFAC * USTARGST(IJ,IGST) ! TODO: Add in dependency on wave-induced stress + ! (note that this line is also used in LFACTOR, and would also need to be adjusted there) + ENDDO +! + ! To reshape from 1D to 2D: + ! K = RESHAPE( A , (/ NANG, NFRE /)) + ! To reshape from 2D to 1D: + ! A = RESHAPE( F(IJ,:,:) , (/NSPEC/) ) + A = RESHAPE( FL1(IJ,:,:) , (/NSPEC/)) * CG2 / ( ZPI * SIG2 )! ACTION DENSITY SPECTRUM +! +!/ 1) --- calculate 1d action density spectrum (A(sigma)) and +!/ zero-out values less than 1.0E-32 to avoid NaNs when +!/ computing directional narrowness in step 4). --------------- / + KK = RESHAPE(A,(/ NANG, NFRE /)) + + ADENSIG = SUM(KK,1) * SIG * DELTH ! Integrate over directions. +! +!/ 2) --- calculate normalised directional spectrum K(theta,sigma) --- / + KMAX = MAXVAL(KK,1) + DO M = 1,NFRE + IF (KMAX(M).LT.1.0E-34_JWRB) THEN + KK(1:NANG,M) = 1.0_JWRB + ELSE + KK(1:NANG,M) = KK(1:NANG,M)/KMAX(M) + END IF + END DO +! +!/ 3) --- calculate normalised spectral saturation BN(M) ------------ / + ANAR = 1.0_JWRB/( SUM(KK,1) * DELTH ) ! directional narrowness +! +! SQRTBN = SQRT( ANAR * ADENSIG * WN(IJ,:)**3 ) + SQRTBN = SQRT( ANAR * ADENSIG * WAVNUM(IJ,:)**3 ) + + DO K = 1, NANG + SQRTBN2(IKN+(K-1)) = SQRTBN ! Calculate SQRTBN for + END DO ! the entire spectrum. +! +!/ 4) --- calculate growth rate GAMMA and S for all directions for +!/ following winds (U10/c - 1 is positive; W1) and in 7) for +!/ adverse winds (U10/c -1 is negative, W2). W1 and W2 +!/ complement one another. ------------------------------------ / + DO IGST=1,NGST + W1(:,IGST)= MAX(0.0_JWRB, & + & UPROXY(IGST)*CINV2*(ECOS2*COSU + ESIN2*SINU) - 1.0_JWRB)**2 +! + D(:,IGST) = (RAORW(IJ) ) * SIG2 * & + (2.8_JWRB-(1.0_JWRB+TANH(10.0_JWRB*SQRTBN2*W1(:,IGST)-11.0_JWRB)))*& + & SQRTBN2*W1(:,IGST) +! + S(:,IGST) = D(:,IGST) * A + ENDDO +! +!/ 5) --- calculate reduction factor LFACT using non-directional +! spectral density of the wind input ------------------------- / + CINV1 = CINV2(IKN) + + DO IGST=1,NGST + SDENSIG(:,:,IGST) = RESHAPE(S(:,IGST)*SIG2/CG2,(/ NANG, NFRE /)) + + CALL LFACTOR(SDENSIG(:,:,IGST), CINV1, UABSGST(IJ,IGST), USTARGST(IJ,IGST), WDWAVE(IJ), & +& ROAIRN(IJ), SIG, DSII, LFACT(:,IGST), TAUWX(IGST), TAUWY(IGST), TAU(IJ,IGST)) + ENDDO + +! +!/ 6) --- apply reduction (LFACT) to the entire spectrum ------------- / + + LLFACT = .TRUE. + ! TODO: if this shows to make a big difference, then I can make this logical more rigorous + ! (and also implement it to save costs in LFACTOR) + IF (LLFACT) THEN + DO IGST=1,NGST + IF (SUM(LFACT(:,IGST)) .LT. NFRE) THEN + DO K = 1, NANG + D(IKN+K-1,IGST) = D(IKN+K-1,IGST) * LFACT(:,IGST) + END DO + S(:,IGST) = D(:,IGST) * A + END IF + DINPOS(:,:,IGST) = RESHAPE(D(:,IGST),(/ NANG, NFRE /)) + ENDDO + END IF + +! +!/ 7) --- compute negative wind input for adverse winds. negative +!/ growth is typically smaller by a factor of ~2.5 (=.28/.11) +!/ than those for the favourable winds [Donelan, 2006, Eq. (7)]. +!/ the factor is adjustable with NAMELIST parameter in +!/ ww3_grid.inp: '&SIN6 SINA0 = 0.04 /' ----------------------- / + DO IGST=1,NGST + IF (SIN6A0.GT.0.0_JWRB) THEN + W2(:,IGST) = MIN( 0.0_JWRB,UPROXY(IGST) * CINV2* & + & (ECOS2*COSU + ESIN2*SINU) - 1.0_JWRB )**2 + D(:,IGST) = D(:,IGST) - ( RAORW(IJ) * SIG2 * SIN6A0 * & + (2.8_JWRB-(1.0_JWRB+TANH(10.0_JWRB*SQRTBN2*W2(:,IGST) - 11.0_JWRB)))& + & *SQRTBN2*W2(:,IGST) ) + + DINTOT(:,:,IGST)= RESHAPE(D(:,IGST),(/NANG,NFRE/)) + S(:,IGST) = D(:,IGST) * A + +! ! --- compute negative component of the wave supported stresses +! ! from negative part of the wind input ---------------------- / + SDENSIG(:,:,IGST) = RESHAPE(S(:,IGST)*SIG2/CG2,(/ NANG, NFRE /)) + CALL TAU_WAVE_ATMOS(SDENSIG(:,:,IGST), CINV1, SIG, DSII, TAUNWX(IGST), TAUNWY(IGST) ) + ELSE + DINTOT(:,:,IGST)=DINPOS(:,:,IGST) + END IF + ENDDO +! + DO IGST=1,NGST + TAUWGST(IJ,IGST) = SQRT(TAUWX(IGST)**2+TAUWY(IGST)**2) / ROAIRN(IJ) ! KINEMATIC TAUW + TAUWDIRGST(IJ,IGST) = ATAN2(TAUWX(IGST),TAUWY(IGST)) + TAUNWGST(IJ,IGST) = SQRT(TAUNWX(IGST)**2+TAUNWY(IGST)**2) / ROAIRN(IJ) ! KINEMATIC TAUNW + USTARGST(IJ,IGST) = SQRT(TAU(IJ,IGST) / ROAIRN(IJ) ) + ENDDO + +! 8) --- Calculate SL, FL and SPOS needed for ecWAM ------------- / + + DO IGST=1,NGST + DO M = 1,NFRE + DO K = 1, NANG + SLGST(IJ,K,M,IGST) = DINTOT(K,M,IGST)*FL1(IJ,K,M) + SPOSGST(IJ,K,M,IGST) = DINPOS(K,M,IGST)*FL1(IJ,K,M) + END DO + END DO + FLGST(IJ,:,:,IGST) = DINTOT(:,:,IGST) + END DO + +! 9) --- Averaging over gust components ------------- / + IGST=1 + TAUWGST_AVG(IJ) = TAUWGST(IJ,IGST) + TAUWDIRGST_AVG(IJ) = TAUWDIRGST(IJ,IGST) + TAUNWGST_AVG(IJ) = TAUNWGST(IJ,IGST) + USTARGST_AVG(IJ) = USTARGST(IJ,IGST) + SLGST_AVG(IJ,:,:) = SLGST(IJ,:,:,IGST) + SPOSGST_AVG(IJ,:,:) = SPOSGST(IJ,:,:,IGST) + FLGST_AVG(IJ,:,:) = FLGST(IJ,:,:,IGST) + DO IGST=2,NGST + TAUWGST_AVG(IJ) = TAUWGST_AVG(IJ) + TAUWGST(IJ,IGST) + TAUWDIRGST_AVG(IJ) = TAUWDIRGST_AVG(IJ) + TAUWDIRGST(IJ,IGST) + TAUNWGST_AVG(IJ) = TAUNWGST_AVG(IJ) + TAUNWGST(IJ,IGST) + USTARGST_AVG(IJ) = USTARGST_AVG(IJ) + USTARGST(IJ,IGST) + SLGST_AVG(IJ,:,:) = SLGST_AVG(IJ,:,:) + SLGST(IJ,:,:,IGST) + SPOSGST_AVG(IJ,:,:) = SPOSGST_AVG(IJ,:,:) + SPOSGST(IJ,:,:,IGST) + FLGST_AVG(IJ,:,:) = FLGST_AVG(IJ,:,:) + FLGST(IJ,:,:,IGST) + ENDDO + TAUW(IJ) = AVG_GST*TAUWGST_AVG(IJ) + TAUWDIR(IJ) = AVG_GST*TAUWDIRGST_AVG(IJ) + TAUNW(IJ) = AVG_GST*TAUNWGST_AVG(IJ) + UFRIC(IJ) = AVG_GST*USTARGST_AVG(IJ) + SL(IJ,:,:) = AVG_GST*SLGST_AVG(IJ,:,:) + SPOS(IJ,:,:) = AVG_GST*SPOSGST_AVG(IJ,:,:) + FLD(IJ,:,:) = AVG_GST*FLGST_AVG(IJ,:,:) + +! 10) --- Calculate roughness length and charnock ------------- / + + USTM1 = 1.0_JWRB/MAX(UFRIC(IJ),EPSUS) ! Protect the code + USTM2 = 1.0_JWRB/MAX(UFRIC(IJ)**2,EPSUS) ! Protect the code + KUOUST = MIN(50._JWRB,XKAPPA*WSWAVE(IJ)*USTM1) ! Protect the code + Z0 = ZNLEV / ( EXP(KUOUST) - 1.0_JWRB ) + Z0 = MAX(Z0, 0.0000001_JWRB) + Z0M(IJ) = Z0 ! Update z0 + CHNKOG(IJ) = ( Z0 - ZRN*USTM1 ) * USTM2 ! Update charnock (where Z0=Z0CH+Z0VIS from airsea_iter) + ALPHAOGMAXU10 = MIN(ALPHAMAX,AMAX+BMAX*WSWAVE(IJ))*GM1 ! protective code taken from outbeta (incl /G) + CHNKOG(IJ) = MIN(CHNKOG(IJ),ALPHAOGMAXU10) ! protective code taken from outbeta (incl /G) + + IF(LLCAPCHNK) THEN + CHARNOCK_MIN = CHNKMIN(WSWAVE(IJ)) + CHNKOG(IJ) = MAX(CHARNOCK_MIN*GM1,CHNKOG(IJ)) + ELSE + CHNKOG(IJ) = MAX(CHNKOG(IJ), 1E-5_JWRB) + ENDIF + + CHRNCK(IJ) = CHNKOG(IJ)*G + +! 11) --- PHIWA calculation using non-directional +! spectral density of the wind input ---------------------- / + + SPOSDENSIG = SPOS(IJ,:,:) + SNEGDENSIG = SL(IJ,:,:) - SPOS(IJ,:,:) + PHIWA(IJ) = CALCPHIWA(SPOSDENSIG,SNEGDENSIG,DSII) ! TODO: add the HiFreq contribution + +END DO +! END LOOP OVER LOC +! --------------------- + +! XLLWS based on SL (mask for neg. input) +DO IJ=KIJS,KIJL + DO M = 1,NFRE + DO K = 1, NANG + IF (SL(IJ,K,M)>0.0_JWRB) THEN + XLLWS(IJ,K,M)=1.0_JWRB + ELSE + XLLWS(IJ,K,M)=0.0_JWRB + END IF + END DO + END DO +END DO +! --------------------- + +! input source term!!!! (end) +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- + +! MEAN FREQUENCY CHARACTERISTIC FOR WIND SEA +!$loki inline +CALL FEMEANWS(KIJS, KIJL, FL1, XLLWS, FMEANWS) + +! COMPUTE LAST FREQUENCY INDEX OF PROGNOSTIC PART OF SPECTRUM. +!$loki inline +CALL FRCUTINDEX(KIJS, KIJL, FMEAN, FMEANWS, UFRIC, CICOVER, MIJ, RHOWGDFTH) + +! ---------------------------------------------------------------------- + +IF (LHOOK) CALL DR_HOOK('SINFLX',1,ZHOOK_HANDLE) + +END SUBROUTINE SINFLX_BYDBR diff --git a/src/ecwam/sinput_jan.F90 b/src/ecwam/sinput_jan.F90 index e218189a7..b49ab15c1 100644 --- a/src/ecwam/sinput_jan.F90 +++ b/src/ecwam/sinput_jan.F90 @@ -100,8 +100,8 @@ SUBROUTINE SINPUT_JAN (NGST, LLSNEG, KIJS, KIJL, FL1 , & ! MODIFICATIONS ! ------------- -! - REMOVAL OF CALL TO CRAY SPECIFIC FUNCTIONS EXPHF AND ALOGHF -! BY THEIR STANDARD FORTRAN EQUIVALENT EXP and ALOGHF +! - REMOVAL OF CALL TO CRAY SPECIFIC FUNCTIONS EXPHF AND LOGHF +! BY THEIR STANDARD FORTRAN EQUIVALENT EXP and LOGHF ! - MODIFIED TO MAKE INTEGRATION SCHEME FULLY IMPLICIT ! - INTRODUCTION OF VARIABLE AIR DENSITY ! - INTRODUCTION OF WIND GUSTINESS diff --git a/src/ecwam/stresso.F90 b/src/ecwam/stresso.F90 index 8027b16f0..7f02c8e7f 100644 --- a/src/ecwam/stresso.F90 +++ b/src/ecwam/stresso.F90 @@ -231,26 +231,6 @@ SUBROUTINE STRESSO (KIJS, KIJL, MIJ, RHOWGDFTH, & ENDDO ENDIF - - ! this is the end of the IPHYS=0,1 relevant part -! --------------------------------------------------------------------------------- -! --------------------------------------------------------------------------------- -! --------------------------------------------------------------------------------- -! --------------------------------------------------------------------------------- -! --------------------------------------------------------------------------------- -! --------------------------------------------------------------------------------- - ! this for IPHYS=2 - - ! essentially the same as what is done in LFACTOR - - - ! this is the end of the IPHYS=2 relevant part -! --------------------------------------------------------------------------------- -! --------------------------------------------------------------------------------- -! --------------------------------------------------------------------------------- -! --------------------------------------------------------------------------------- -! --------------------------------------------------------------------------------- -! --------------------------------------------------------------------------------- IF ( LLPHIWA ) THEN DO IJ=KIJS,KIJL PHIWA(IJ) = PHIWA(IJ) + PHIHF(IJ) diff --git a/src/ecwam/tau_wave_atmos.F90 b/src/ecwam/tau_wave_atmos.F90 index f6e1da8c5..bc67a85af 100644 --- a/src/ecwam/tau_wave_atmos.F90 +++ b/src/ecwam/tau_wave_atmos.F90 @@ -54,16 +54,12 @@ SUBROUTINE TAU_WAVE_ATMOS(S, CINV, SIG, DSII, TAUNWX, TAUNWY ) ! ---------------------------------------------------------------------- USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU - USE YOWCOUP , ONLY : BETAMAX ,ZALP ,TAUWSHELTER, XKAPPA, RNU ,RNUM USE YOWFRED , ONLY : FR ,TH ,DFIM ,COSTH ,SINTH,& & FRATIO ,DELTH USE YOWMPP , ONLY : NINF ,NSUP - USE YOWPARAM , ONLY : NANG ,NFRE ,NBLO + USE YOWPARAM , ONLY : NANG ,NFRE USE YOWPCONS , ONLY : G ,ZPI ,ROWATER ,EPSMIN - USE YOWSHAL , ONLY : TFAK ,INDEP - USE YOWSTAT , ONLY : ISHALLO - USE YOWTABL , ONLY : IAB ,SWELLFT - USE YOMHOOK ,ONLY : LHOOK, DR_HOOK + USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK ! ---------------------------------------------------------------------- @@ -99,7 +95,7 @@ SUBROUTINE TAU_WAVE_ATMOS(S, CINV, SIG, DSII, TAUNWX, TAUNWY ) !/ 0) --- Find the number of frequencies required to extend arrays !/ up to f=10Hz and allocate arrays --------------------------- / - NK10Hz = CEILING(ALOG(FRQMAX/(SIG(1)/ZPI))/ALOG(FRATIO))+1 + NK10Hz = CEILING(LOG(FRQMAX/(SIG(1)/ZPI))/LOG(FRATIO))+1 NK10Hz = MAX(NK,NK10Hz) ! ALLOCATE(IK10Hz(NK10Hz)) From f9a58935212f67b5a1128c03b5f6416360690a69 Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Fri, 15 Aug 2025 12:39:15 +0000 Subject: [PATCH 07/89] contents of sinput_bydbr.F90 moved within sinflx_bydbr.F90 --- src/ecwam/sinput_bydbr.F90 | 530 ------------------------------------- 1 file changed, 530 deletions(-) delete mode 100644 src/ecwam/sinput_bydbr.F90 diff --git a/src/ecwam/sinput_bydbr.F90 b/src/ecwam/sinput_bydbr.F90 deleted file mode 100644 index e3c1442ab..000000000 --- a/src/ecwam/sinput_bydbr.F90 +++ /dev/null @@ -1,530 +0,0 @@ -! (C) Copyright 1989- ECMWF. -! -! This software is licensed under the terms of the Apache Licence Version 2.0 -! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. -! In applying this licence, ECMWF does not waive the privileges and immunities -! granted to it by virtue of its status as an intergovernmental organisation -! nor does it submit to any jurisdiction. -! - -SUBROUTINE SINPUT_BYDBR (NGST, LLSNEG, KIJS, KIJL, FL1, & - & WAVNUM, CGROUP, CINV, XK2CG, & - & WDWAVE, WSWAVE, UFRIC, Z0M, & - & COSWDIF, SINWDIF2, & - & RAORW, WSTAR, RNFAC, & - & CHRNCK, FLD, SL, SPOS, XLLWS) -! ---------------------------------------------------------------------- - -!**** *SINPUT_BYDBR* - COMPUTATION OF INPUT SOURCE FUNCTION. - - -!* PURPOSE. -! --------- - -! Observation-based source term for wind input after Donelan, Babanin, -! Young and Banner (Donelan et al ,2006) following the implementation -! by Rogers et al. (2012). -! -!** INTERFACE. -! ---------- - -! *CALL* *SINPUT_BYDBR (NGST, LLSNEG, KIJS, KIJL, FL1, -! & WAVNUM, CGROUP, CINV, XK2CG, -! & WSWAVE, WDWAVE, UFRIC, Z0M, -! & COSWDIF, SINWDIF2, -! & RAORW, WSTAR, RNFAC, -! & FLD, SL, SPOS, XLLWS) -! *NGST* - IF = 1 THEN NO GUSTINESS PARAMETERISATION -! - IF = 2 THEN GUSTINESS PARAMETERISATION -! *LLSNEG- IF TRUE THEN THE NEGATIVE SINPUT (SWELL DAMPING) WILL BE COMPUTED -! *KIJS* - INDEX OF FIRST GRIDPOINT. -! *KIJL* - INDEX OF LAST GRIDPOINT. -! *FL1* - SPECTRUM. -! *WAVNUM* - WAVE NUMBER. -! *CGROUP* - GROUP SPEED -! *CINV* - INVERSE PHASE VELOCITY. -! *XK2CG* - (WAVNUM)**2 * GROUP SPPED. -! *WDWAVE* - WIND DIRECTION IN RADIANS IN OCEANOGRAPHIC -! NOTATION (POINTING ANGLE OF WIND VECTOR, -! CLOCKWISE FROM NORTH). -! *UFRIC* - NEW FRICTION VELOCITY IN M/S. -! *Z0M* - ROUGHNESS LENGTH IN M. -! *COSWDIF* - COS(TH(K)-WDWAVE(IJ)) -! *SINWDIF2* - SIN(TH(K)-WDWAVE(IJ))**2 -! *RAORW* - RATIO AIR DENSITY TO WATER DENSITY. -! *WSTAR* - FREE CONVECTION VELOCITY SCALE (M/S). -! *RNFAC* - WIND DEPENDENT FACTOR USED IN THE GROWTH RENORMALISATION. -! *CHRNCK*- CHARNOCK COEFFICIENT -! *FLD* - DIAGONAL MATRIX OF FUNCTIONAL DERIVATIVE. -! *SL* - TOTAL SOURCE FUNCTION ARRAY. -! *SPOS* - POSITIVE SOURCE FUNCTION ARRAY. -! *XLLWS* - = 1 WHERE SINPUT IS POSITIVE - -! METHOD. -! ------- - -! SEE REFERENCE. - -! EXTERNALS. -! ---------- -! TAU_WAVE_ATMOS -! LFACTOR -! IRANGE - -! ORIGIN. -! ---------- -! Adapted from Babanin Young Donelan & Banner (BYDB) physics -! as implemented as ST6 in WAVEWATCH-III -! WW3 module: W3SRC6MD -! WW3 subroutine: W3SIN6 -! Implementation into ECWAM DECEMBER 2021 by J. Kousal - - -! ---------------------------------------------------------------------- - USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU - - USE YOWCOUP , ONLY : LLCAPCHNK,LLNORMAGAM - USE YOWFRED , ONLY : FR ,TH ,DFIM ,COSTH ,SINTH, ZPIFR, DELTH, FRATIO, FRIC - USE YOWPARAM , ONLY : NANG ,NFRE - USE YOWPCONS , ONLY : G ,GM1 ,EPSMIN, EPSUS, ZPI, ROWATER - USE YOWPHYS , ONLY : ZALP ,TAUWSHELTER, XKAPPA, BETAMAXOXKAPPA2, & - & RNU ,RNUM, & - & SWELLF ,SWELLF2 ,SWELLF3 ,SWELLF4 , SWELLF5, & - & SWELLF6 ,SWELLF7 ,SWELLF7M1, Z0RAT ,Z0TUBMAX , & - & ABMIN ,ABMAX, CDFAC - USE YOWTEST , ONLY : IU06 - USE YOWTABL , ONLY : IAB ,SWELLFT - - USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK - -! ---------------------------------------------------------------------- - - IMPLICIT NONE - -#include "wsigstar.intfb.h" -! #include "tau_wave_atmos.intfb.h" -#include "lfactor.intfb.h" -#include "irange.intfb.h" -! #include "calcphiwa.intfb.h" - - INTEGER(KIND=JWIM), INTENT(IN) :: NGST - LOGICAL, INTENT(IN) :: LLSNEG - INTEGER(KIND=JWIM), INTENT(IN) :: KIJS, KIJL - REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(IN) :: FL1 - REAL(KIND=JWRB), DIMENSION(KIJL,NFRE), INTENT(IN) :: WAVNUM, CGROUP, CINV, XK2CG - REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: WDWAVE, WSWAVE - REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: Z0M, UFRIC - REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: RAORW, WSTAR, RNFAC - REAL(KIND=JWRB), DIMENSION(KIJL,NANG), INTENT(IN) :: COSWDIF, SINWDIF2 - REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: CHRNCK - REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(OUT) :: FLD, SL, SPOS - REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(OUT) :: XLLWS - - LOGICAL :: LLFACT - INTEGER(KIND=JWIM) :: IJ, K, M, IND, IGST - INTEGER(KIND=JWIM) :: NSPEC !num. of freqs, dirs, spec. bins - INTEGER(KIND=JWIM), DIMENSION(NANG) :: ITHN - INTEGER(KIND=JWIM), DIMENSION(NFRE) :: IKN - - REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: CG2, ECOS2, ESIN2, DSII2 - REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: WN2, SIG2 - REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: SQRTBN2, CINV2, A - REAL(KIND=JWRB), DIMENSION(NFRE) :: DSII, SIG, CINV1, DF - REAL(KIND=JWRB), DIMENSION(NFRE) :: ADENSIG, KMAX, ANAR, SQRTBN - REAL(KIND=JWRB), DIMENSION(NANG,NFRE) :: KK - ! REAL(KIND=JWRB), DIMENSION(NANG,NFRE) :: SPOSDENSIG, SNEGDENSIG - REAL(KIND=JWRB), DIMENSION(NANG*NFRE,NGST) :: W1, W2, S, D - REAL(KIND=JWRB), DIMENSION(NFRE,NGST) :: LFACT - REAL(KIND=JWRB), DIMENSION(NANG,NFRE,NGST) :: SDENSIG, DINPOS, DINTOT - - - REAL(KIND=JWRB), PARAMETER :: SIN6A0 = 9.0E-2_JWRB ! ST6 PARAM - REAL(KIND=JWRB), DIMENSION(NGST) :: TAUWX, TAUWY ! Component of the wave-supported stress - REAL(KIND=JWRB), DIMENSION(NGST) :: TAUNWX, TAUNWY ! Component of the neg. wave-supported stress - REAL(KIND=JWRB) :: COSU, SINU - REAL(KIND=JWRB), DIMENSION(NGST) :: UPROXY - - REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: XK, CGG_WAM, CM - REAL(KIND=JWRB), DIMENSION(NFRE) :: SIGP2, SIGM1 - - ! For USTAR, Z0, CHNK - REAL(KIND=JWRB), DIMENSION(KIJL,NGST) :: TAU - REAL(KIND=JWRB), PARAMETER :: ZRN=1.65E-6_JWRB ! effective kinematic viscosity (0.11*1.5e-5) - REAL(KIND=JWRB), PARAMETER :: RKAP = 0.4_JWRB - REAL(KIND=JWRB) :: ZNLEV, Z0, KUOUST, USTM1, USTM2 - REAL(KIND=JWRB), PARAMETER :: XEPS=0.00001_JWRB - REAL(KIND=JWRB), PARAMETER :: USTMIN=0.000001_JWRB - REAL(KIND=JWRB), PARAMETER :: PCHARMAX=0.1_JWRB - REAL(KIND=JWRB), PARAMETER :: Z0FG=0.01_JWRB - INTEGER(KIND=JWIM) :: ITER - REAL(KIND=JWRB) :: XZNLEV, PCHAROG, XKUTOP, XOLOGZ0 - REAL(KIND=JWRB) :: UST, USTOLD, Z0CH, Z0VIS, Z0TOT, FF, DELF - REAL(KIND=JWRB) :: CHARNOCK_MIN,CHNKMIN ! For Capping - INTEGER(KIND=JWIM), PARAMETER :: NITER=15 - REAL(KIND=JWRB), PARAMETER :: ALPHAMAX=0.1_JWRB - REAL(KIND=JWRB), PARAMETER :: AMAX=0.02_JWRB - REAL(KIND=JWRB), PARAMETER :: BMAX=0.01_JWRB - REAL(KIND=JWRB) :: ALPHAOGMAXU10 - - REAL(KIND=JWRB), DIMENSION(KIJL) :: ROAIRN, CHNKOG - - ! For GUSTINESS - REAL(KIND=JWRB) :: AVG_GST - REAL(KIND=JWRB), DIMENSION(KIJL) :: SIG_N, TAUWGST_AVG, TAUNWGST_AVG, USTARGST_AVG - REAL(KIND=JWRB), DIMENSION(KIJL,NGST) :: TAUWGST, TAUNWGST, UABSGST, USTARGST, Z0GST - REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE) :: SLGST_AVG, SPOSGST_AVG, FLGST_AVG - REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE,NGST) :: SLGST, SPOSGST, FLGST - - ! ! For PHIWA calculation - ! REAL(KIND=JWRB),DIMENSION(KIJL,NFRE) :: RHOWGDFTH - ! REAL(KIND=JWRB), DIMENSION(KIJL) :: SUMT - - REAL(KIND=JPHOOK) :: ZHOOK_HANDLE - -! ---------------------------------------------------------------------- - -IF (LHOOK) CALL DR_HOOK('SINPUT_BYDBR',0,ZHOOK_HANDLE) - -NSPEC = NANG * NFRE ! NUMBER OF SPECTRAL BINS - -! Wind height - ZNLEV = 10._JWRB - -! COMPUTE FREQUENCY INTERVALLS (borrowed from Wam_others/f4spec.F) - DO M = 1,NFRE - DF(M) = FR(M)*( FRATIO - 1.0_JWRB ) - ENDDO - - DO M = 1,NFRE - SIG(M) = ZPI*FR(M) - DSII(M) = ZPI*DF(M) - SIGM1(M) = 1.0_JWRB/SIG(M) - SIGP2(M) = SIG(M)**2 - END DO - - ! TODO: clean up stuff in/out of IJ loops (sdissip_bydb + swldissip +sinput_bydb) - ! TODO: confirm that I'm using exactly the same things here (I've now adopted them throughout the BYDBR code) - ! - confirm CGG_WAM=CGROUP - ! - confirm XK=WAVNUM - - DO M=1,NFRE - DO IJ=KIJS,KIJL - CM(IJ,M) = WAVNUM(IJ,M)*SIGM1(M) - ENDDO - ENDDO - - - ITHN = IRANGE(1,NANG,1) ! Index vector 1:NANG - DO M = 1, NFRE - ECOS2 (ITHN+(M-1)*NANG) = COSTH - ESIN2 (ITHN+(M-1)*NANG) = SINTH - END DO -! - IKN = IRANGE(1,NSPEC,NANG) ! Index vector for elements of 1 ... NFRE -! ! such that e.g. SIG(1:NFRE) = SIG2(IKN). - - DO K = 1, NANG ! Apply to all directions - DSII2 (IKN+(K-1)) = DSII - SIG2 (IKN+(K-1)) = SIG - END DO - -! ESTIMATE THE STANDARD DEVIATION OF GUSTINESS. - CALL WSIGSTAR (KIJS, KIJL, WSWAVE, UFRIC, Z0M, WSTAR, SIG_N) - AVG_GST = 1.0_JWRB/NGST - - DO IJ=KIJS,KIJL - USTARGST(IJ,1)= UFRIC(IJ)*(1.0_JWRB+SIG_N(IJ)) - USTARGST(IJ,2)= UFRIC(IJ)*(1.0_JWRB-SIG_N(IJ)) - CHNKOG(IJ) = CHRNCK(IJ)*GM1 - ROAIRN(IJ) = RAORW(IJ)*ROWATER - END DO - - ! Define Z0GST associated with USTARGST (as in airsea_iter) -! DO IGST=1,NGST -! DO IJ=KIJS,KIJL -! XKUTOP = RKAP*UABS(IJ) -! UST = USTARGST(IJ,IGST) -! PCHAROG = MIN(ALPHAOG(IJ),PCHARMAX/G) -! ! iteratively solve Z0 and USTAR -! DO ITER=1,NITER -! USTOLD = MAX(UST,USTMIN) -! Z0CH = PCHAROG*UST**2 -! Z0VIS = ZRN/UST -! Z0TOT = Z0CH+Z0VIS -! XZNLEV = ZNLEV/(ZNLEV+Z0TOT) -! XOLOGZ0 = 1.0_JWRB/LOG(1.0_JWRB+ZNLEV/Z0TOT) -! FF = UST-XKUTOP*XOLOGZ0 -! DELF = 1.0_JWRB-XKUTOP*XOLOGZ0**2*XZNLEV* & -! & (2.0_JWRB*Z0CH-Z0VIS)/(UST*Z0TOT) -! IF(DELF /= 0.0_JWRB) UST = UST-FF/DELF -! IF(ABS(UST-USTOLD)<=UST*XEPS .AND. ABS(FF)<=XEPS) EXIT -! ENDDO ! iter loop ENDDO - - ! Update Z0, US (gust) -! IF(ITER > NITER) THEN -!! failed to iterate -! Z0GST(IJ,IGST) = Z0FG -! USTARGST(IJ,IGST) = XKUTOP/LOG(1.0+ZNLEV/Z0GST(IJ,IGST)) -! ELSE -! USTARGST(IJ,IGST) = MAX(UST,USTMIN) -! Z0GST(IJ,IGST) = Z0TOT -! ENDIF -! ENDDO ! IJ loop ENDDO -! ENDDO ! NGST loop ENDDO - - ! Define Z0GST associated with USTARGST (as in airsea_iter) - DO IGST=1,NGST - DO IJ=KIJS,KIJL - UST = USTARGST(IJ,IGST) - PCHAROG = MIN(CHNKOG(IJ),PCHARMAX/G) - Z0CH = PCHAROG*UST**2 - Z0VIS = ZRN/UST - Z0GST(IJ,IGST) = Z0CH+Z0VIS - ENDDO ! IJ loop ENDDO - ENDDO ! NGST loop ENDDO - - ! Define UABSGST associated with USTARGST and Z0GST - ! U10 = (u*/kappa) log (1 + Z/Z0), z=10 - DO IGST=1,NGST - DO IJ=KIJS,KIJL - UABSGST(IJ,IGST) = USTARGST(IJ,IGST)*LOG(1.0_JWRB + ZNLEV/Z0GST(IJ,IGST))/XKAPPA - END DO - END DO - -!/ --- Main loop over LOC ----------------------------------- / - - - ! LOOP OVER LOCATIONS - DO IJ = KIJS,KIJL - - DO K = 1, NANG ! Apply to all directions - WN2 (IKN+(K-1)) = WAVNUM(IJ,:) ! using WAM native WN,CG - CG2 (IKN+(K-1)) = CGROUP(IJ,:) - END DO - - CINV2 = WN2 / SIG2 ! inverse phase speed - -!/ 0) --- set up a basic variables ----------------------------------- / - - COSU = COS(WDWAVE(IJ)) - SINU = SIN(WDWAVE(IJ)) -! - DO IGST=1,NGST - TAUNWX(IGST) = 0.0_JWRB - TAUNWY(IGST) = 0.0_JWRB - TAUWX(IGST) = 0.0_JWRB - TAUWY(IGST) = 0.0_JWRB - TAU(IJ,IGST) = 0.0_JWRB - ENDDO - -! -!/ --- scale friction velocity to wind speed (10m) in -!/ the boundary layer ----------------------------------------- / -!/ Donelan et al. (2006) used U10 or U_{λ/2} in their S_{in} -!/ parameterization. To avoid some disadvantages of using U10 or -!/ U_{λ/2}, Rogers et al. (2012) used the following engineering -!/ conversion: -!/ UPROXY = SIN6WS * UST -!/ -!/ SIN6WS = FRIC = 28.0 following Komen et al. (1984) (developed seas) -!/ SIN6WS = 32.0 suggested by E. Rogers (2014) (young seas) -! - DO IGST=1,NGST - UPROXY(IGST) = FRIC * CDFAC * USTARGST(IJ,IGST) ! Scale wind speed by FRIC and CDFAC - ! UPROXY(IGST) = WAVEAGE * CDFAC * USTARGST(IJ,IGST) ! TODO: Add in dependency on wave-induced stress - ! (note that this line is also used in LFACTOR, and would also need to be adjusted there) - ENDDO -! - ! To reshape from 1D to 2D: - ! K = RESHAPE( A , (/ NANG, NFRE /)) - ! To reshape from 2D to 1D: - ! A = RESHAPE( F(IJ,:,:) , (/NSPEC/) ) - A = RESHAPE( FL1(IJ,:,:) , (/NSPEC/)) * CG2 / ( ZPI * SIG2 )! ACTION DENSITY SPECTRUM -! -!/ 1) --- calculate 1d action density spectrum (A(sigma)) and -!/ zero-out values less than 1.0E-32 to avoid NaNs when -!/ computing directional narrowness in step 4). --------------- / - KK = RESHAPE(A,(/ NANG, NFRE /)) - - ADENSIG = SUM(KK,1) * SIG * DELTH ! Integrate over directions. -! -!/ 2) --- calculate normalised directional spectrum K(theta,sigma) --- / - KMAX = MAXVAL(KK,1) - DO M = 1,NFRE - IF (KMAX(M).LT.1.0E-34_JWRB) THEN - KK(1:NANG,M) = 1.0_JWRB - ELSE - KK(1:NANG,M) = KK(1:NANG,M)/KMAX(M) - END IF - END DO -! -!/ 3) --- calculate normalised spectral saturation BN(M) ------------ / - ANAR = 1.0_JWRB/( SUM(KK,1) * DELTH ) ! directional narrowness -! -! SQRTBN = SQRT( ANAR * ADENSIG * WN(IJ,:)**3 ) - SQRTBN = SQRT( ANAR * ADENSIG * WAVNUM(IJ,:)**3 ) - - DO K = 1, NANG - SQRTBN2(IKN+(K-1)) = SQRTBN ! Calculate SQRTBN for - END DO ! the entire spectrum. -! -!/ 4) --- calculate growth rate GAMMA and S for all directions for -!/ following winds (U10/c - 1 is positive; W1) and in 7) for -!/ adverse winds (U10/c -1 is negative, W2). W1 and W2 -!/ complement one another. ------------------------------------ / - DO IGST=1,NGST - W1(:,IGST)= MAX(0.0_JWRB, & - & UPROXY(IGST)*CINV2*(ECOS2*COSU + ESIN2*SINU) - 1.0_JWRB)**2 -! - D(:,IGST) = (RAORW(IJ) ) * SIG2 * & - (2.8_JWRB-(1.0_JWRB+TANH(10.0_JWRB*SQRTBN2*W1(:,IGST)-11.0_JWRB)))*& - & SQRTBN2*W1(:,IGST) -! - S(:,IGST) = D(:,IGST) * A - ENDDO -! -!/ 5) --- calculate reduction factor LFACT using non-directional -! spectral density of the wind input ------------------------- / - CINV1 = CINV2(IKN) - - DO IGST=1,NGST - SDENSIG(:,:,IGST) = RESHAPE(S(:,IGST)*SIG2/CG2,(/ NANG, NFRE /)) - - CALL LFACTOR(SDENSIG(:,:,IGST), CINV1, UABSGST(IJ,IGST), USTARGST(IJ,IGST), WDWAVE(IJ), & -& ROAIRN(IJ), SIG, DSII, LFACT(:,IGST), TAUWX(IGST), TAUWY(IGST), TAU(IJ,IGST)) - ENDDO - -! -!/ 6) --- apply reduction (LFACT) to the entire spectrum ------------- / - - LLFACT = .TRUE. - ! TODO: if this shows to make a big difference, then I can make this logical more rigorous - ! (and also implement it to save costs in LFACTOR) - IF (LLFACT) THEN - DO IGST=1,NGST - IF (SUM(LFACT(:,IGST)) .LT. NFRE) THEN - DO K = 1, NANG - D(IKN+K-1,IGST) = D(IKN+K-1,IGST) * LFACT(:,IGST) - END DO - S(:,IGST) = D(:,IGST) * A - END IF - DINPOS(:,:,IGST) = RESHAPE(D(:,IGST),(/ NANG, NFRE /)) - ENDDO - END IF - -! -!/ 7) --- compute negative wind input for adverse winds. negative -!/ growth is typically smaller by a factor of ~2.5 (=.28/.11) -!/ than those for the favourable winds [Donelan, 2006, Eq. (7)]. -!/ the factor is adjustable with NAMELIST parameter in -!/ ww3_grid.inp: '&SIN6 SINA0 = 0.04 /' ----------------------- / - DO IGST=1,NGST - IF (SIN6A0.GT.0.0_JWRB) THEN - W2(:,IGST) = MIN( 0.0_JWRB,UPROXY(IGST) * CINV2* & - & (ECOS2*COSU + ESIN2*SINU) - 1.0_JWRB )**2 - D(:,IGST) = D(:,IGST) - ( RAORW(IJ) * SIG2 * SIN6A0 * & - (2.8_JWRB-(1.0_JWRB+TANH(10.0_JWRB*SQRTBN2*W2(:,IGST) - 11.0_JWRB)))& - & *SQRTBN2*W2(:,IGST) ) - - DINTOT(:,:,IGST)= RESHAPE(D(:,IGST),(/NANG,NFRE/)) - S(:,IGST) = D(:,IGST) * A - -! ! --- compute negative component of the wave supported stresses -! ! from negative part of the wind input ---------------------- / -! SDENSIG(:,:,IGST) = RESHAPE(S(:,IGST)*SIG2/CG2,(/ NANG, NFRE /)) -! CALL TAU_WAVE_ATMOS(SDENSIG(:,:,IGST), CINV1, SIG, DSII, TAUNWX(IGST), TAUNWY(IGST) ) - ELSE - DINTOT(:,:,IGST)=DINPOS(:,:,IGST) - END IF - ENDDO -! - DO IGST=1,NGST - ! TAUWGST(IJ,IGST) = SQRT(TAUWX(IGST)**2+TAUWY(IGST)**2) / ROAIRN(IJ) ! KINEMATIC TAUW - ! TAUNWGST(IJ,IGST) = SQRT(TAUNWX(IGST)**2+TAUNWY(IGST)**2) / ROAIRN(IJ) ! KINEMATIC TAUNW - USTARGST(IJ,IGST) = SQRT(TAU(IJ,IGST) / ROAIRN(IJ) ) - ENDDO - -! 8) --- Calculate SL, FL and SPOS needed for ecWAM ------------- / - - DO IGST=1,NGST - DO M = 1,NFRE - DO K = 1, NANG - SLGST(IJ,K,M,IGST) = DINTOT(K,M,IGST)*FL1(IJ,K,M) - SPOSGST(IJ,K,M,IGST) = DINPOS(K,M,IGST)*FL1(IJ,K,M) - END DO - END DO - FLGST(IJ,:,:,IGST) = DINTOT(:,:,IGST) - END DO - -! 9) --- Averaging over gust components ------------- / - IGST=1 - ! TAUWGST_AVG(IJ) = TAUWGST(IJ,IGST) - ! TAUNWGST_AVG(IJ) = TAUNWGST(IJ,IGST) - USTARGST_AVG(IJ) = USTARGST(IJ,IGST) - SLGST_AVG(IJ,:,:) = SLGST(IJ,:,:,IGST) - SPOSGST_AVG(IJ,:,:) = SPOSGST(IJ,:,:,IGST) - FLGST_AVG(IJ,:,:) = FLGST(IJ,:,:,IGST) - DO IGST=2,NGST - ! TAUWGST_AVG(IJ) = TAUWGST_AVG(IJ) + TAUWGST(IJ,IGST) - ! TAUNWGST_AVG(IJ) = TAUNWGST_AVG(IJ) + TAUNWGST(IJ,IGST) - USTARGST_AVG(IJ) = USTARGST_AVG(IJ) + USTARGST(IJ,IGST) - SLGST_AVG(IJ,:,:) = SLGST_AVG(IJ,:,:) + SLGST(IJ,:,:,IGST) - SPOSGST_AVG(IJ,:,:) = SPOSGST_AVG(IJ,:,:) + SPOSGST(IJ,:,:,IGST) - FLGST_AVG(IJ,:,:) = FLGST_AVG(IJ,:,:) + FLGST(IJ,:,:,IGST) - ENDDO - ! TAUW(IJ) = AVG_GST*TAUWGST_AVG(IJ) - ! TAUNW(IJ) = AVG_GST*TAUNWGST_AVG(IJ) - UFRIC(IJ) = AVG_GST*USTARGST_AVG(IJ) - SL(IJ,:,:) = AVG_GST*SLGST_AVG(IJ,:,:) - SPOS(IJ,:,:) = AVG_GST*SPOSGST_AVG(IJ,:,:) - FLD(IJ,:,:) = AVG_GST*FLGST_AVG(IJ,:,:) - -! 10) --- Calculate roughness length and charnock ------------- / - - USTM1 = 1.0_JWRB/MAX(UFRIC(IJ),EPSUS) ! Protect the code - USTM2 = 1.0_JWRB/MAX(UFRIC(IJ)**2,EPSUS) ! Protect the code - KUOUST = MIN(50._JWRB,XKAPPA*WSWAVE(IJ)*USTM1) ! Protect the code - Z0 = ZNLEV / ( EXP(KUOUST) - 1.0_JWRB ) - Z0 = MAX(Z0, 0.0000001_JWRB) - Z0M(IJ) = Z0 ! Update z0 - CHNKOG(IJ) = ( Z0 - ZRN*USTM1 ) * USTM2 ! Update charnock (where Z0=Z0CH+Z0VIS from airsea_iter) - ALPHAOGMAXU10 = MIN(ALPHAMAX,AMAX+BMAX*WSWAVE(IJ))*GM1 ! protective code taken from outbeta (incl /G) - CHNKOG(IJ) = MIN(CHNKOG(IJ),ALPHAOGMAXU10) ! protective code taken from outbeta (incl /G) - - IF(LLCAPCHNK) THEN - CHARNOCK_MIN = CHNKMIN(WSWAVE(IJ)) - CHNKOG(IJ) = MAX(CHARNOCK_MIN*GM1,CHNKOG(IJ)) - ELSE - CHNKOG(IJ) = MAX(CHNKOG(IJ), 1E-5_JWRB) - ENDIF - - CHRNCK(IJ) = CHNKOG(IJ)*G - -! 11) --- PHIWA calculation using non-directional -! spectral density of the wind input ---------------------- / - - ! SPOSDENSIG = SPOS(IJ,:,:) - ! SNEGDENSIG = SL(IJ,:,:) - SPOS(IJ,:,:) - ! PHIWA(IJ) = CALCPHIWA(SPOSDENSIG,SNEGDENSIG,DSII) - - END DO - ! END LOOP OVER LOC - ! --------------------- - - ! XLLWS based on SL (mask for neg. input) - DO IJ=KIJS,KIJL - DO M = 1,NFRE - DO K = 1, NANG - IF (SL(IJ,K,M)>0.0_JWRB) THEN - XLLWS(IJ,K,M)=1.0_JWRB - ELSE - XLLWS(IJ,K,M)=0.0_JWRB - END IF - END DO - END DO - END DO - ! --------------------- - -IF (LHOOK) CALL DR_HOOK('SINPUT_BYDBR',1,ZHOOK_HANDLE) - -END SUBROUTINE SINPUT_BYDBR From 5059abd424fbec04d79cd2be04c6716d0dda5d85 Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Tue, 19 Aug 2025 12:57:19 +0000 Subject: [PATCH 08/89] bugfix on CHRNCK --- src/ecwam/airsea.F90 | 4 ++-- src/ecwam/airsea_iter.F90 | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/ecwam/airsea.F90 b/src/ecwam/airsea.F90 index 39a6b9b34..0682e3033 100644 --- a/src/ecwam/airsea.F90 +++ b/src/ecwam/airsea.F90 @@ -75,8 +75,8 @@ SUBROUTINE AIRSEA (KIJS, KIJL, & INTEGER(KIND=JWIM), INTENT(IN) :: KIJS, KIJL, ICODE_WND, IUSFG REAL(KIND=JWRB), DIMENSION(KIJL), INTENT (IN) :: HALP, U10DIR, TAUW, TAUWDIR, RNFAC - REAL(KIND=JWRB), DIMENSION(KIJL), INTENT (INOUT) :: U10, US - REAL(KIND=JWRB), DIMENSION(KIJL), INTENT (OUT) :: Z0, Z0B, CHRNCK + REAL(KIND=JWRB), DIMENSION(KIJL), INTENT (INOUT) :: U10, US, CHRNCK + REAL(KIND=JWRB), DIMENSION(KIJL), INTENT (OUT) :: Z0, Z0B INTEGER(KIND=JWIM) :: IJ, I, J diff --git a/src/ecwam/airsea_iter.F90 b/src/ecwam/airsea_iter.F90 index e57e11ad5..2b1e9e835 100644 --- a/src/ecwam/airsea_iter.F90 +++ b/src/ecwam/airsea_iter.F90 @@ -75,8 +75,8 @@ SUBROUTINE AIRSEA_ITER (KIJS, KIJL, & INTEGER(KIND=JWIM), INTENT(IN) :: KIJS, KIJL, ICODE_WND, IUSFG REAL(KIND=JWRB), DIMENSION(KIJL), INTENT (IN) :: HALP, U10DIR, TAUW, TAUWDIR, RNFAC - REAL(KIND=JWRB), DIMENSION(KIJL), INTENT (INOUT) :: U10, US - REAL(KIND=JWRB), DIMENSION(KIJL), INTENT (OUT) :: Z0, Z0B, CHRNCK + REAL(KIND=JWRB), DIMENSION(KIJL), INTENT (INOUT) :: U10, US, CHRNCK + REAL(KIND=JWRB), DIMENSION(KIJL), INTENT (OUT) :: Z0, Z0B INTEGER(KIND=JWIM) :: IJ, I, J From ceef4ab5e52f0f0ba9b7b10f0bf115e75bfce332 Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Wed, 1 Oct 2025 11:37:08 +0000 Subject: [PATCH 09/89] tidy of moving of sinput_bydbr into sinflx --- src/ecwam/CMakeLists.txt | 1 - src/ecwam/sinflx_bydbr.F90 | 2 +- src/ecwam/sinput.F90 | 11 ++--------- 3 files changed, 3 insertions(+), 11 deletions(-) diff --git a/src/ecwam/CMakeLists.txt b/src/ecwam/CMakeLists.txt index 8406308eb..7e54d1c7f 100644 --- a/src/ecwam/CMakeLists.txt +++ b/src/ecwam/CMakeLists.txt @@ -251,7 +251,6 @@ list( APPEND ecwam_srcs sinput.F90 sinput_ard.F90 sinput_jan.F90 - sinput_bydbr.F90 skewness.F90 snonlin.F90 spectra.F90 diff --git a/src/ecwam/sinflx_bydbr.F90 b/src/ecwam/sinflx_bydbr.F90 index f546fe739..0c4b778b0 100644 --- a/src/ecwam/sinflx_bydbr.F90 +++ b/src/ecwam/sinflx_bydbr.F90 @@ -303,7 +303,7 @@ SUBROUTINE SINFLX_BYDBR (ICALL, NCALL, KIJS, KIJL, & SIGP2(M) = SIG(M)**2 END DO -! TODO: clean up stuff in/out of IJ loops (sdissip_bydb + swldissip +sinput_bydb) +! TODO: clean up stuff in/out of IJ loops (sdissip_bydb + swldissip ) ! TODO: confirm that I'm using exactly the same things here (I've now adopted them throughout the BYDBR code) ! - confirm CGG_WAM=CGROUP ! - confirm XK=WAVNUM diff --git a/src/ecwam/sinput.F90 b/src/ecwam/sinput.F90 index 31a013c9c..087951b5a 100644 --- a/src/ecwam/sinput.F90 +++ b/src/ecwam/sinput.F90 @@ -80,7 +80,6 @@ SUBROUTINE SINPUT (NGST, LLSNEG, KIJS, KIJL, FL1, & IMPLICIT NONE #include "sinput_ard.intfb.h" #include "sinput_jan.intfb.h" -#include "sinput_bydbr.intfb.h" INTEGER(KIND=JWIM), INTENT(IN) :: NGST LOGICAL, INTENT(IN) :: LLSNEG @@ -122,14 +121,8 @@ SUBROUTINE SINPUT (NGST, LLSNEG, KIJS, KIJL, FL1, & & COSWDIF, SINWDIF2, & & RAORW, WSTAR, RNFAC, & & FLD, SL, SPOS, XLLWS) - CASE(2) - !$loki inline - CALL SINPUT_BYDBR(NGST, LLSNEG, KIJS, KIJL, FL1, & - & WAVNUM, CGROUP, CINV, XK2CG, & - & WDWAVE, WSWAVE, UFRIC, Z0M, & - & COSWDIF, SINWDIF2, & - & RAORW, WSTAR, RNFAC, & - & CHRNCK, FLD, SL, SPOS, XLLWS) + ! CASE(2) + ! - not called from SINPUT END SELECT IF (LHOOK) CALL DR_HOOK('SINPUT',1,ZHOOK_HANDLE) From 680711e1659790f3b75cb0372a83390c1e523c19 Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Thu, 2 Oct 2025 10:31:36 +0000 Subject: [PATCH 10/89] output extra ocean parameters --- tests/etopo1_oper_an_fc_O48_cy50r1.yml | 5 +++++ tests/etopo1_oper_an_fc_O48_cy50r1_bydbr.yml | 5 +++++ 2 files changed, 10 insertions(+) diff --git a/tests/etopo1_oper_an_fc_O48_cy50r1.yml b/tests/etopo1_oper_an_fc_O48_cy50r1.yml index 8a1d94e6e..183331a0d 100644 --- a/tests/etopo1_oper_an_fc_O48_cy50r1.yml +++ b/tests/etopo1_oper_an_fc_O48_cy50r1.yml @@ -43,6 +43,11 @@ output: - dwi # 10 metre wind direction - cdww # Coefficient of drag with waves - wind # 10 metre wind speed + - ust # U-component stokes stress + - vst # V-component stokes stress + - '075' # utauo + - '076' # vtauo + - '077' # wphio format: grib # (default : grib) or binary at: - timestep: 01:00 diff --git a/tests/etopo1_oper_an_fc_O48_cy50r1_bydbr.yml b/tests/etopo1_oper_an_fc_O48_cy50r1_bydbr.yml index 76622ce8e..de9145a4b 100644 --- a/tests/etopo1_oper_an_fc_O48_cy50r1_bydbr.yml +++ b/tests/etopo1_oper_an_fc_O48_cy50r1_bydbr.yml @@ -44,6 +44,11 @@ output: - dwi # 10 metre wind direction - cdww # Coefficient of drag with waves - wind # 10 metre wind speed + - ust # U-component stokes stress + - vst # V-component stokes stress + - '075' # utauo + - '076' # vtauo + - '077' # wphio format: grib # (default : grib) or binary at: - timestep: 01:00 From 6c8657a9b24107465f348b163b135540f8f606c1 Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Thu, 9 Oct 2025 10:43:05 +0000 Subject: [PATCH 11/89] bug fix and temporary fix on FRIC=32 --- src/ecwam/airsea_iter.F90 | 2 +- src/ecwam/sinflx_bydbr.F90 | 3 ++- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/src/ecwam/airsea_iter.F90 b/src/ecwam/airsea_iter.F90 index 2b1e9e835..b2be24f57 100644 --- a/src/ecwam/airsea_iter.F90 +++ b/src/ecwam/airsea_iter.F90 @@ -128,7 +128,7 @@ SUBROUTINE AIRSEA_ITER (KIJS, KIJL, & XKUTOP = RKAP*U10(IJ) ! Start with old charnock (and protect the scheme) - PCHAROG = MIN(CHRNCK(IJ),PCHARMAX/G) + PCHAROG = MIN(CHRNCK(IJ),PCHARMAX)/G ! Cd as a linear relation with slope function of Charnock CDLIN= ACDLIN + BCDLIN*SQRT(PCHAROG*G) * U10(IJ) diff --git a/src/ecwam/sinflx_bydbr.F90 b/src/ecwam/sinflx_bydbr.F90 index 0c4b778b0..4e2562710 100644 --- a/src/ecwam/sinflx_bydbr.F90 +++ b/src/ecwam/sinflx_bydbr.F90 @@ -398,7 +398,8 @@ SUBROUTINE SINFLX_BYDBR (ICALL, NCALL, KIJS, KIJL, & !/ SIN6WS = 32.0 suggested by E. Rogers (2014) (young seas) ! DO IGST=1,NGST - UPROXY(IGST) = FRIC * CDFAC * USTARGST(IJ,IGST) ! Scale wind speed by FRIC and CDFAC +! UPROXY(IGST) = FRIC * CDFAC * USTARGST(IJ,IGST) ! Scale wind speed by FRIC and CDFAC + UPROXY(IGST) = 32.0_JWRB * CDFAC * USTARGST(IJ,IGST) ! Scale wind speed by FRIC and CDFAC ! UPROXY(IGST) = WAVEAGE * CDFAC * USTARGST(IJ,IGST) ! TODO: Add in dependency on wave-induced stress ! (note that this line is also used in LFACTOR, and would also need to be adjusted there) ENDDO From 04029f506e23b4456f8d09a1bb028d7d85ed3d88 Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Mon, 13 Oct 2025 17:43:05 +0000 Subject: [PATCH 12/89] implement different flavors of airsea for ZBRY --- src/ecwam/CMakeLists.txt | 2 +- src/ecwam/airsea.F90 | 4 +- src/ecwam/airsea_iter.F90 | 37 +++++-- src/ecwam/airsea_zbry.F90 | 220 +++++++++++++++++++++++++++++++++++++ src/ecwam/mpuserin.F90 | 3 +- src/ecwam/sinflx_bydbr.F90 | 35 +++--- src/ecwam/sinput_ard.F90 | 4 +- src/ecwam/sinput_jan.F90 | 3 +- src/ecwam/wsigstar.F90 | 18 ++- src/ecwam/yowstat.F90 | 1 + 10 files changed, 294 insertions(+), 33 deletions(-) create mode 100644 src/ecwam/airsea_zbry.F90 diff --git a/src/ecwam/CMakeLists.txt b/src/ecwam/CMakeLists.txt index 7e54d1c7f..76a9f92c4 100644 --- a/src/ecwam/CMakeLists.txt +++ b/src/ecwam/CMakeLists.txt @@ -49,7 +49,7 @@ list( APPEND ecwam_srcs adjust.F90 airsea.F90 airsea_jan.F90 - airsea_iter.F90 + airsea_zbry.F90 aki.F90 aki_ice.F90 alphap_tail.F90 diff --git a/src/ecwam/airsea.F90 b/src/ecwam/airsea.F90 index 0682e3033..e8a3dc2d7 100644 --- a/src/ecwam/airsea.F90 +++ b/src/ecwam/airsea.F90 @@ -71,7 +71,7 @@ SUBROUTINE AIRSEA (KIJS, KIJL, & #include "abort1.intfb.h" #include "airsea_jan.intfb.h" -#include "airsea_iter.intfb.h" +#include "airsea_zbry.intfb.h" INTEGER(KIND=JWIM), INTENT(IN) :: KIJS, KIJL, ICODE_WND, IUSFG REAL(KIND=JWRB), DIMENSION(KIJL), INTENT (IN) :: HALP, U10DIR, TAUW, TAUWDIR, RNFAC @@ -94,7 +94,7 @@ SUBROUTINE AIRSEA (KIJS, KIJL, & & HALP, U10, U10DIR, TAUW, TAUWDIR, RNFAC, & & US, Z0, Z0B, CHRNCK, ICODE_WND, IUSFG) CASE(2) - CALL AIRSEA_ITER(KIJS, KIJL, & + CALL AIRSEA_ZBRY(KIJS, KIJL, & & HALP, U10, U10DIR, TAUW, TAUWDIR, RNFAC, & & US, Z0, Z0B, CHRNCK, ICODE_WND, IUSFG) diff --git a/src/ecwam/airsea_iter.F90 b/src/ecwam/airsea_iter.F90 index b2be24f57..0f3e85d64 100644 --- a/src/ecwam/airsea_iter.F90 +++ b/src/ecwam/airsea_iter.F90 @@ -29,7 +29,7 @@ SUBROUTINE AIRSEA_ITER (KIJS, KIJL, & !** INTERFACE. ! ---------- -! *CALL* *AIRSEA_ITER (KIJS, KIJL, FL1, WAVNUM, +! *CALL* *AIRSEA_ZBRY (KIJS, KIJL, FL1, WAVNUM, ! HALP, U10, U10DIR, TAUW, TAUWDIR, RNFAC, ! US, Z0, Z0B, CHRNCK, ICODE_WND, IUSFG)* @@ -59,7 +59,8 @@ SUBROUTINE AIRSEA_ITER (KIJS, KIJL, & USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU USE YOWPARAM, ONLY : NANG ,NFRE - USE YOWPHYS, ONLY : XKAPPA, XNLEV + USE YOWPHYS, ONLY : XKAPPA, XNLEV, CDFAC + USE YOWSTAT, ONLY : IPHYS2_AIRSEA USE YOWPCONS, ONLY : G USE YOWTEST, ONLY : IU06 USE YOWWIND, ONLY : WSPMIN @@ -105,7 +106,7 @@ SUBROUTINE AIRSEA_ITER (KIJS, KIJL, & REAL(KIND=JWRB) :: XI, XJ, DELI1, DELI2, DELJ1, DELJ2, UST2, ARG, SQRTCDM1 REAL(KIND=JWRB) :: XKAPPAD, XLOGLEV - REAL(KIND=JWRB) :: XLEV + REAL(KIND=JWRB) :: XLEV, FLX4A0, CD REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ---------------------------------------------------------------------- @@ -116,10 +117,29 @@ SUBROUTINE AIRSEA_ITER (KIJS, KIJL, & IF (ICODE_WND == 3) THEN - !$loki inline +! Wind height + ZNLEV = 10._JWRB -! Wind height - ZNLEV = 10._JWRB + !$loki inline + SELECT CASE (IPHYS2_AIRSEA) + + ! implementation of Hwang (2011) as in ST6 + CASE(0) + FLX4A0 = CDFAC + DO IJ=KIJS,KIJL + IF (U10(IJ) .GE. 50.33_JWRB) THEN + US(IJ) = 2.026_JWRB * SQRT(FLX4A0) + CD = (US(IJ)/U10(IJ))**2 + ELSE + CD = FLX4A0 * ( 8.058_JWRB + 0.967_JWRB*U10(IJ) - 0.016_JWRB*U10(IJ)**2 ) * 1E-4_JWRB + US(IJ) = U10(IJ) * SQRT(CD) + END IF + ! + Z0(IJ) = ZNLEV * EXP ( -0.4_JWRB / SQRT(CD) ) + ENDDO + + ! implementation of iterative scheme + CASE(1,2) DO IJ=KIJS,KIJL ! -------------------------------------------- @@ -163,9 +183,10 @@ SUBROUTINE AIRSEA_ITER (KIJS, KIJL, & US(IJ) = MAX(UST,USTMIN) ! Z0(IJ) = Z0CH ! Commented out -> Z0=Z0TOT ENDIF - - + + ENDDO + END SELECT ELSEIF (ICODE_WND == 1 .OR. ICODE_WND == 2) THEN diff --git a/src/ecwam/airsea_zbry.F90 b/src/ecwam/airsea_zbry.F90 new file mode 100644 index 000000000..801001d9c --- /dev/null +++ b/src/ecwam/airsea_zbry.F90 @@ -0,0 +1,220 @@ +! (C) Copyright 1989- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! + + SUBROUTINE AIRSEA_ZBRY (KIJS, KIJL, & +& HALP, U10, U10DIR, TAUW, TAUWDIR, RNFAC, & +& US, Z0, Z0B, CHRNCK, ICODE_WND, IUSFG) + +! ---------------------------------------------------------------------- + +!**** *AIRSEA_ZBRY* - DETERMINE TOTAL STRESS IN SURFACE LAYER. + +! P.A.E.M. JANSSEN KNMI AUGUST 1990 +! JEAN BIDLOT ECMWF FEBRUARY 1999 : TAUT is already +! SQRT(TAUT) +! JEAN BIDLOT ECMWF OCTOBER 2004: QUADRATIC STEP FOR +! TAUW + +!* PURPOSE. +! -------- + +! COMPUTE TOTAL STRESS. + +!** INTERFACE. +! ---------- + +! *CALL* *AIRSEA_ZBRY (KIJS, KIJL, FL1, WAVNUM, +! HALP, U10, U10DIR, TAUW, TAUWDIR, RNFAC, +! US, Z0, Z0B, CHRNCK, ICODE_WND, IUSFG)* + +! *KIJS* - INDEX OF FIRST GRIDPOINT. +! *KIJL* - INDEX OF LAST GRIDPOINT. +! *FL1* - SPECTRA +! *WAVNUM* - WAVE NUMBER +! *HALP* - 1/2 PHILLIPS PARAMETER +! *U10* - WINDSPEED U10. +! *U10DIR* - WINDSPEED DIRECTION. +! *TAUW* - WAVE STRESS. +! *TAUWDIR* - WAVE STRESS DIRECTION. +! *RNFAC* - WIND DEPENDENT FACTOR USED IN THE GROWTH RENORMALISATION. +! *US* - OUTPUT OR OUTPUT BLOCK OF FRICTION VELOCITY. +! *Z0* - OUTPUT BLOCK OF ROUGHNESS LENGTH. +! *Z0B* - BACKGROUND ROUGHNESS LENGTH. +! *CHRNCK* - CHARNOCK COEFFICIENT +! *ICODE_WND* SPECIFIES WHICH OF U10 OR US HAS BEEN FILED UPDATED: +! U10: ICODE_WND=3 --> US will be updated +! US: ICODE_WND=1 OR 2 --> U10 will be updated +! *IUSFG* - IF = 1 THEN USE THE FRICTION VELOCITY (US) AS FIRST GUESS in TAUT_Z0 +! 0 DO NOT USE THE FIELD US + + +! ---------------------------------------------------------------------- + + USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU + + USE YOWPARAM, ONLY : NANG ,NFRE + USE YOWPHYS, ONLY : XKAPPA, XNLEV, CDFAC + USE YOWSTAT, ONLY : IPHYS2_AIRSEA + USE YOWPCONS, ONLY : G + USE YOWTEST, ONLY : IU06 + USE YOWWIND, ONLY : WSPMIN + + USE YOMHOOK, ONLY: LHOOK, DR_HOOK, JPHOOK + +! ---------------------------------------------------------------------- + IMPLICIT NONE + +#include "abort1.intfb.h" +#include "taut_z0.intfb.h" +#include "z0wave.intfb.h" + + INTEGER(KIND=JWIM), INTENT(IN) :: KIJS, KIJL, ICODE_WND, IUSFG + REAL(KIND=JWRB), DIMENSION(KIJL), INTENT (IN) :: HALP, U10DIR, TAUW, TAUWDIR, RNFAC + REAL(KIND=JWRB), DIMENSION(KIJL), INTENT (INOUT) :: U10, US, CHRNCK + REAL(KIND=JWRB), DIMENSION(KIJL), INTENT (OUT) :: Z0, Z0B + + INTEGER(KIND=JWIM) :: IJ, I, J + + REAL(KIND=JWRB) :: ZNLEV + REAL(KIND=JWRB), PARAMETER :: RKAP = 0.4_JWRB + REAL(KIND=JWRB), PARAMETER :: ZRN=1.65E-6_JWRB ! effective kinematic viscosity (0.11*1.5e-5) + + ! for the ietrative scheme + INTEGER(KIND=JWIM), PARAMETER :: NITER=15 + +! CD=ACD+BCD*U10 + REAL(KIND=JWRB), PARAMETER :: ACD=0.0008_JWRB + REAL(KIND=JWRB), PARAMETER :: BCD=0.00008_JWRB + +! CD = ACDLIN + BCDLIN*SQRT(PCHAR) * U10 + REAL(KIND=JWRB), PARAMETER :: ACDLIN=0.0008_JWRB + REAL(KIND=JWRB), PARAMETER :: BCDLIN=0.00047_JWRB + REAL(KIND=JWRB), PARAMETER :: XEPS=0.00001_JWRB + REAL(KIND=JWRB), PARAMETER :: USTMIN=0.000001_JWRB + REAL(KIND=JWRB), PARAMETER :: PCHARMAX=0.1_JWRB + REAL(KIND=JWRB), PARAMETER :: Z0FG=0.01_JWRB + + INTEGER(KIND=JWIM) :: ITER + REAL(KIND=JWRB) :: XZNLEV, PCHAROG, XKUTOP, XOLOGZ0 + REAL(KIND=JWRB) :: CDLIN, UST, USTOLD, Z0CH, Z0VIS, F, DELF + + REAL(KIND=JWRB) :: XI, XJ, DELI1, DELI2, DELJ1, DELJ2, UST2, ARG, SQRTCDM1 + REAL(KIND=JWRB) :: XKAPPAD, XLOGLEV + REAL(KIND=JWRB) :: XLEV, FLX4A0, CD + REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ---------------------------------------------------------------------- + IF (LHOOK) CALL DR_HOOK ('AIRSEA_ZBRY', 0, ZHOOK_HANDLE) + +!* 2. DETERMINE TOTAL STRESS AND ROUGHNESS (if needed) +! ---------------------------------- + + IF (ICODE_WND == 3) THEN + +! Wind height + ZNLEV = 10._JWRB + + !$loki inline + SELECT CASE (IPHYS2_AIRSEA) + + ! implementation of Hwang (2011) as in ST6 + CASE(0) + FLX4A0 = CDFAC + DO IJ=KIJS,KIJL + IF (U10(IJ) .GE. 50.33_JWRB) THEN + US(IJ) = 2.026_JWRB * SQRT(FLX4A0) + CD = (US(IJ)/U10(IJ))**2 + ELSE + CD = FLX4A0 * ( 8.058_JWRB + 0.967_JWRB*U10(IJ) - 0.016_JWRB*U10(IJ)**2 ) * 1E-4_JWRB + US(IJ) = U10(IJ) * SQRT(CD) + END IF + ! + Z0(IJ) = ZNLEV * EXP ( -0.4_JWRB / SQRT(CD) ) + ENDDO + + ! implementation of iterative scheme + CASE(1,2) + + DO IJ=KIJS,KIJL + ! -------------------------------------------- + ! Iterative method + + XKUTOP = RKAP*U10(IJ) + + ! Start with old charnock (and protect the scheme) + PCHAROG = MIN(CHRNCK(IJ),PCHARMAX)/G + + ! Cd as a linear relation with slope function of Charnock + CDLIN= ACDLIN + BCDLIN*SQRT(PCHAROG*G) * U10(IJ) + + ! first guess for u* + ! UST = U10(IJ)*SQRT(ACD+BCD*U10(IJ)) ! Use linear approx + ! UST = SQRT(CD)*U10(IJ) ! Use Hersbach approx + UST = SQRT(CDLIN)*U10(IJ) ! Use Hersbach approx + + ! iterate + DO ITER=1,NITER + USTOLD = MAX(UST,USTMIN) + Z0CH = PCHAROG*UST**2 + Z0VIS = ZRN/UST + Z0(IJ) = Z0CH+Z0VIS + XZNLEV = ZNLEV/(ZNLEV+Z0(IJ)) + XOLOGZ0 = 1.0_JWRB/LOG(1.0_JWRB+ZNLEV/Z0(IJ)) + F = UST-XKUTOP*XOLOGZ0 + DELF = 1.0_JWRB-XKUTOP*XOLOGZ0**2*XZNLEV* & + & (2.0_JWRB*Z0CH-Z0VIS)/(UST*Z0(IJ)) + IF(DELF /= 0.0_JWRB) UST = UST-F/DELF + + IF(ABS(UST-USTOLD)<=UST*XEPS .AND. ABS(F)<=XEPS) EXIT + ENDDO + + ! Update Z0, US and then charnock + IF(ITER > NITER) THEN + ! failed to iterate + Z0(IJ) = Z0FG + US(IJ) = XKUTOP/LOG(1.0+ZNLEV/Z0(IJ)) + ELSE + US(IJ) = MAX(UST,USTMIN) + ! Z0(IJ) = Z0CH ! Commented out -> Z0=Z0TOT + ENDIF + + + ENDDO + END SELECT + + ELSEIF (ICODE_WND == 1 .OR. ICODE_WND == 2) THEN + +!* 3. DETERMINE ROUGHNESS LENGTH (if needed). +! --------------------------- + + !$loki inline + CALL Z0WAVE (KIJS, KIJL, US, TAUW, U10, Z0, Z0B, CHRNCK) + +!* 3. DETERMINE U10 (if needed). +! --------------------------- + + XKAPPAD = 1.0_JWRB / XKAPPA + XLOGLEV = LOG (XNLEV) + + DO IJ = KIJS, KIJL + U10 (IJ) = XKAPPAD * US (IJ) * (XLOGLEV - LOG (Z0 (IJ))) + U10 (IJ) = MAX (U10 (IJ), WSPMIN) + ENDDO + + ELSE + WRITE (IU06, * ) ' ++++++++++++++++++++++++++++++++++++++++++' + WRITE (IU06, * ) ' + AIRSEA_ZBRY : INVALID VALUE OF ICODE_WND +' + WRITE (IU06, * ) ' ICODE_WND = ', ICODE_WND + WRITE (IU06, * ) ' ++++++++++++++++++++++++++++++++++++++++++' + CALL ABORT1 + ENDIF + + IF (LHOOK) CALL DR_HOOK ('AIRSEA_ZBRY', 1, ZHOOK_HANDLE) + + END SUBROUTINE AIRSEA_ZBRY diff --git a/src/ecwam/mpuserin.F90 b/src/ecwam/mpuserin.F90 index 5dbab4d04..d96313ba3 100644 --- a/src/ecwam/mpuserin.F90 +++ b/src/ecwam/mpuserin.F90 @@ -98,7 +98,7 @@ SUBROUTINE MPUSERIN & IDELWO ,IDELALT ,IREST ,IDELRES ,IDELINT , & & IDELBC , & & ICASE ,ISHALLO , & - & IPHYS , & + & IPHYS ,IPHYS2_AIRSEA, & & ISNONLIN , & & IDAMPING , & & LBIWBK , & @@ -605,6 +605,7 @@ SUBROUTINE MPUSERIN ICASE = 1 ISHALLO = 0 !! depricated IPHYS = 1 + IPHYS2_AIRSEA = 2 !0=~ST6, 1=iterative, 2=based only on wind! ISNONLIN = 1 IDAMPING = 1 IPROPAGS = 0 diff --git a/src/ecwam/sinflx_bydbr.F90 b/src/ecwam/sinflx_bydbr.F90 index 4e2562710..68fe23605 100644 --- a/src/ecwam/sinflx_bydbr.F90 +++ b/src/ecwam/sinflx_bydbr.F90 @@ -106,6 +106,7 @@ SUBROUTINE SINFLX_BYDBR (ICALL, NCALL, KIJS, KIJL, & & ABMIN ,ABMAX, CDFAC, DTHRN_A ,DTHRN_U USE YOWTEST , ONLY : IU06 USE YOWTABL , ONLY : IAB ,SWELLFT + USE YOWSTAT , ONLY : IPHYS2_AIRSEA USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK @@ -221,11 +222,13 @@ SUBROUTINE SINFLX_BYDBR (ICALL, NCALL, KIJS, KIJL, & ! For GUSTINESS REAL(KIND=JWRB) :: AVG_GST -REAL(KIND=JWRB), DIMENSION(KIJL) :: SIG_N, TAUWGST_AVG, TAUWDIRGST_AVG, TAUNWGST_AVG, USTARGST_AVG +REAL(KIND=JWRB), DIMENSION(KIJL) :: SIG_N, SIG_U10, TAUWGST_AVG, TAUWDIRGST_AVG, TAUNWGST_AVG, USTARGST_AVG REAL(KIND=JWRB), DIMENSION(KIJL,NGST) :: TAUWGST, TAUWDIRGST, TAUNWGST, UABSGST, USTARGST, Z0GST REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE) :: SLGST_AVG, SPOSGST_AVG, FLGST_AVG REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE,NGST) :: SLGST, SPOSGST, FLGST +INTEGER(KIND=JWIM), PARAMETER :: SINFLX_BYDBR_PHYS=0 !0=~ST6, 1=iterative, 2=based only on wind! + ! For PHIWA calculation ! REAL(KIND=JWRB),DIMENSION(KIJL,NFRE) :: RHOWGDFTH ! REAL(KIND=JWRB), DIMENSION(KIJL) :: SUMT @@ -330,17 +333,19 @@ SUBROUTINE SINFLX_BYDBR (ICALL, NCALL, KIJS, KIJL, & END DO ! ESTIMATE THE STANDARD DEVIATION OF GUSTINESS. -CALL WSIGSTAR (KIJS, KIJL, WSWAVE, UFRIC, Z0M, WSTAR, SIG_N) +CALL WSIGSTAR (KIJS, KIJL, WSWAVE, UFRIC, Z0M, WSTAR, SIG_N, SIG_U10) AVG_GST = 1.0_JWRB/NGST DO IJ=KIJS,KIJL USTARGST(IJ,1)= UFRIC(IJ)*(1.0_JWRB+SIG_N(IJ)) USTARGST(IJ,2)= UFRIC(IJ)*(1.0_JWRB-SIG_N(IJ)) + UABSGST(IJ,1)= WSWAVE(IJ)*(1.0_JWRB+SIG_U10(IJ)) + UABSGST(IJ,2)= WSWAVE(IJ)*(1.0_JWRB-SIG_U10(IJ)) CHNKOG(IJ) = CHRNCK(IJ)*GM1 ROAIRN(IJ) = RAORW(IJ)*ROWATER END DO -! Define Z0GST associated with USTARGST (as in airsea_iter) +! Define Z0GST associated with USTARGST (as in airsea_zbry) DO IGST=1,NGST DO IJ=KIJS,KIJL UST = USTARGST(IJ,IGST) @@ -353,11 +358,11 @@ SUBROUTINE SINFLX_BYDBR (ICALL, NCALL, KIJS, KIJL, & ! Define UABSGST associated with USTARGST and Z0GST ! U10 = (u*/kappa) log (1 + Z/Z0), z=10 -DO IGST=1,NGST - DO IJ=KIJS,KIJL - UABSGST(IJ,IGST) = USTARGST(IJ,IGST)*LOG(1.0_JWRB + ZNLEV/Z0GST(IJ,IGST))/XKAPPA - END DO -END DO +! DO IGST=1,NGST +! DO IJ=KIJS,KIJL +! UABSGST(IJ,IGST) = USTARGST(IJ,IGST)*LOG(1.0_JWRB + ZNLEV/Z0GST(IJ,IGST))/XKAPPA +! END DO +! END DO !/ --- Main loop over LOC ----------------------------------- / @@ -398,10 +403,14 @@ SUBROUTINE SINFLX_BYDBR (ICALL, NCALL, KIJS, KIJL, & !/ SIN6WS = 32.0 suggested by E. Rogers (2014) (young seas) ! DO IGST=1,NGST -! UPROXY(IGST) = FRIC * CDFAC * USTARGST(IJ,IGST) ! Scale wind speed by FRIC and CDFAC - UPROXY(IGST) = 32.0_JWRB * CDFAC * USTARGST(IJ,IGST) ! Scale wind speed by FRIC and CDFAC - ! UPROXY(IGST) = WAVEAGE * CDFAC * USTARGST(IJ,IGST) ! TODO: Add in dependency on wave-induced stress - ! (note that this line is also used in LFACTOR, and would also need to be adjusted there) + SELECT CASE (IPHYS2_AIRSEA) + CASE(0) + UPROXY(IGST) = 32.0_JWRB * CDFAC * USTARGST(IJ,IGST) ! original, suggested by E. Rogers (2014) (young seas) + CASE(1) + UPROXY(IGST) = FRIC * CDFAC * USTARGST(IJ,IGST) ! following Komen et al. (1984) (developed seas) (FRIC=28) + CASE(2) + UPROXY(IGST) = UABSGST(IJ,IGST) * CDFAC ! because FRIC=1/sqrt(CD), then this turns to purely a wind dependence (USTARGST cancels out) + END SELECT ENDDO ! ! To reshape from 1D to 2D: @@ -560,7 +569,7 @@ SUBROUTINE SINFLX_BYDBR (ICALL, NCALL, KIJS, KIJL, & Z0 = ZNLEV / ( EXP(KUOUST) - 1.0_JWRB ) Z0 = MAX(Z0, 0.0000001_JWRB) Z0M(IJ) = Z0 ! Update z0 - CHNKOG(IJ) = ( Z0 - ZRN*USTM1 ) * USTM2 ! Update charnock (where Z0=Z0CH+Z0VIS from airsea_iter) + CHNKOG(IJ) = ( Z0 - ZRN*USTM1 ) * USTM2 ! Update charnock (where Z0=Z0CH+Z0VIS from airsea_zbry) ALPHAOGMAXU10 = MIN(ALPHAMAX,AMAX+BMAX*WSWAVE(IJ))*GM1 ! protective code taken from outbeta (incl /G) CHNKOG(IJ) = MIN(CHNKOG(IJ),ALPHAOGMAXU10) ! protective code taken from outbeta (incl /G) diff --git a/src/ecwam/sinput_ard.F90 b/src/ecwam/sinput_ard.F90 index f3e0f2295..bfb5798c1 100644 --- a/src/ecwam/sinput_ard.F90 +++ b/src/ecwam/sinput_ard.F90 @@ -131,7 +131,7 @@ SUBROUTINE SINPUT_ARD (NGST, LLSNEG, KIJS, KIJL, FL1, & REAL(KIND=JWRB), DIMENSION(KIJL) :: Z0VIS, Z0NOZ, FWW REAL(KIND=JWRB), DIMENSION(KIJL) :: PVISC, PTURB REAL(KIND=JWRB), DIMENSION(KIJL) :: ZCN - REAL(KIND=JWRB), DIMENSION(KIJL) :: SIG_N, UORBT, AORB, TEMP, RE, RE_C, ZORB + REAL(KIND=JWRB), DIMENSION(KIJL) :: SIG_N, SIG_U10, UORBT, AORB, TEMP, RE, RE_C, ZORB REAL(KIND=JWRB), DIMENSION(KIJL) :: CNSN, SUMF, SUMFSIN2 REAL(KIND=JWRB), DIMENSION(KIJL) :: CSTRNFAC REAL(KIND=JWRB), DIMENSION(KIJL) :: FLP_AVG, SLP_AVG @@ -165,7 +165,7 @@ SUBROUTINE SINPUT_ARD (NGST, LLSNEG, KIJS, KIJL, FL1, & ! ESTIMATE THE STANDARD DEVIATION OF GUSTINESS. IF (NGST > 1)THEN !$loki inline - CALL WSIGSTAR (KIJS, KIJL, WSWAVE, UFRIC, Z0M, WSTAR, SIG_N) + CALL WSIGSTAR (KIJS, KIJL, WSWAVE, UFRIC, Z0M, WSTAR, SIG_N, SIG_U10) ENDIF diff --git a/src/ecwam/sinput_jan.F90 b/src/ecwam/sinput_jan.F90 index b49ab15c1..944c8cbc0 100644 --- a/src/ecwam/sinput_jan.F90 +++ b/src/ecwam/sinput_jan.F90 @@ -156,6 +156,7 @@ SUBROUTINE SINPUT_JAN (NGST, LLSNEG, KIJS, KIJL, FL1 , & REAL(KIND=JWRB), DIMENSION(2) :: WSIN REAL(KIND=JWRB), DIMENSION(KIJL) :: ZTANHKD REAL(KIND=JWRB), DIMENSION(KIJL) :: SIG_N + REAL(KIND=JWRB), DIMENSION(KIJL) :: SIG_U10 REAL(KIND=JWRB), DIMENSION(KIJL) :: CNSN REAL(KIND=JWRB), DIMENSION(KIJL) :: SUMF, SUMFSIN2 REAL(KIND=JWRB), DIMENSION(KIJL) :: CSTRNFAC @@ -184,7 +185,7 @@ SUBROUTINE SINPUT_JAN (NGST, LLSNEG, KIJS, KIJL, FL1 , & ! ESTIMATE THE STANDARD DEVIATION OF GUSTINESS. IF (NGST > 1)THEN !$loki inline - CALL WSIGSTAR (KIJS, KIJL, WSWAVE, UFRIC, Z0M, WSTAR, SIG_N) + CALL WSIGSTAR (KIJS, KIJL, WSWAVE, UFRIC, Z0M, WSTAR, SIG_N, SIG_U10) ENDIF !* 1. PRECALCULATED ANGULAR DEPENDENCE. diff --git a/src/ecwam/wsigstar.F90 b/src/ecwam/wsigstar.F90 index fca1c9efa..7466f84c6 100644 --- a/src/ecwam/wsigstar.F90 +++ b/src/ecwam/wsigstar.F90 @@ -7,7 +7,7 @@ ! nor does it submit to any jurisdiction. ! - SUBROUTINE WSIGSTAR (KIJS, KIJL, WSWAVE, UFRIC, Z0M, WSTAR, SIG_N) + SUBROUTINE WSIGSTAR (KIJS, KIJL, WSWAVE, UFRIC, Z0M, WSTAR, SIG_N, SIG_U10) ! ---------------------------------------------------------------------- !**** *WSIGSTAR* - COMPUTATION OF THE RELATIVE STANDARD DEVIATION OF USTAR. @@ -21,14 +21,15 @@ SUBROUTINE WSIGSTAR (KIJS, KIJL, WSWAVE, UFRIC, Z0M, WSTAR, SIG_N) !** INTERFACE. ! ---------- -! *CALL* *WSIGSTAR (KIJS, KIJL, WSWAVE, UFRIC, Z0M, WSTAR, SIG_N) +! *CALL* *WSIGSTAR (KIJS, KIJL, WSWAVE, UFRIC, Z0M, WSTAR, SIG_N, SIG_U10) ! *KIJS* - INDEX OF FIRST GRIDPOINT. ! *KIJL* - INDEX OF LAST GRIDPOINT. ! *WSWAVE* - 10M WIND SPEED (m/s). ! *UFRIC* - NEW FRICTION VELOCITY IN M/S. ! *Z0M* - ROUGHNESS LENGTH IN M. ! *WSTAR* - FREE CONVECTION VELOCITY SCALE (M/S). -! *SIG_N* - ESTINATED RELATIVE STANDARD DEVIATION OF USTAR. +! *SIG_N* - ESTIMATED RELATIVE STANDARD DEVIATION OF USTAR. +! *SIG_U10* - ESTIMATED RELATIVE STANDARD DEVIATION OF U10. ! METHOD. ! ------- @@ -61,13 +62,14 @@ SUBROUTINE WSIGSTAR (KIJS, KIJL, WSWAVE, UFRIC, Z0M, WSTAR, SIG_N) INTEGER(KIND=JWIM), INTENT(IN) :: KIJS, KIJL REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: WSWAVE, UFRIC, Z0M, WSTAR - REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(OUT) :: SIG_N + REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(OUT) :: SIG_N, SIG_U10 INTEGER(KIND=JWIM) :: IJ REAL(KIND=JWRB), PARAMETER :: BG_GUST = 0.0_JWRB ! NO BACKGROUND GUSTINESS (S0 12. IS NOT USED) REAL(KIND=JWRB), PARAMETER :: ONETHIRD = 1.0_JWRB/3.0_JWRB - REAL(KIND=JWRB), PARAMETER :: SIG_NMAX = 0.9_JWRB ! MAX OF RELATIVE STANDARD DEVIATION OF USTAR + REAL(KIND=JWRB), PARAMETER :: SIG_NMAX = 0.9_JWRB ! MAX OF RELATIVE STANDARD DEVIATION OF USTAR + REAL(KIND=JWRB), PARAMETER :: SIG_U10MAX = 0.9_JWRB ! MAX OF RELATIVE STANDARD DEVIATION OF U10 REAL(KIND=JWRB), PARAMETER :: C1 = 1.03E-3_JWRB REAL(KIND=JWRB), PARAMETER :: C2 = 0.04E-3_JWRB @@ -100,6 +102,9 @@ SUBROUTINE WSIGSTAR (KIJS, KIJL, WSWAVE, UFRIC, Z0M, WSTAR, SIG_N) SIG_CONV = 1.0_JWRB + 0.5_JWRB*WSWAVE(IJ)/C_D * DC_DDU SIG_N(IJ) = MIN(SIG_NMAX, SIG_CONV * U10M1*(BG_GUST*UFRIC(IJ)**3 + & & 0.5_JWRB*XKAPPA*WSTAR(IJ)**3)**ONETHIRD ) + SIG_U10(IJ) = MIN(SIG_U10MAX, (BG_GUST*UFRIC(IJ)**3 + & + & 0.5_JWRB*(XKAPPA*WSTAR(IJ))**3)**ONETHIRD ) + ENDDO ELSE @@ -124,6 +129,9 @@ SUBROUTINE WSIGSTAR (KIJS, KIJL, WSWAVE, UFRIC, Z0M, WSTAR, SIG_N) SIG_CONV = 1.0_JWRB + 0.5_JWRB*U10/C_D*DC_DDU SIG_N(IJ) = MIN(SIG_NMAX, SIG_CONV * U10M1*(BG_GUST*UFRIC(IJ)**3 + & & 0.5_JWRB*XKAPPA*WSTAR(IJ)**3)**ONETHIRD ) + SIG_U10(IJ) = MIN(SIG_U10MAX, (BG_GUST*UFRIC(IJ)**3 + & + & 0.5_JWRB*(XKAPPA*WSTAR(IJ))**3)**ONETHIRD ) + ENDDO ENDIF diff --git a/src/ecwam/yowstat.F90 b/src/ecwam/yowstat.F90 index 2ec2f12d9..dc48eba90 100644 --- a/src/ecwam/yowstat.F90 +++ b/src/ecwam/yowstat.F90 @@ -54,6 +54,7 @@ MODULE YOWSTAT INTEGER(KIND=JWIM) :: ISHALLO INTEGER(KIND=JWIM) :: ISNONLIN INTEGER(KIND=JWIM) :: IPHYS + INTEGER(KIND=JWIM) :: IPHYS2_AIRSEA INTEGER(KIND=JWIM) :: IREFRA INTEGER(KIND=JWIM) :: IPROPAGS=-1 INTEGER(KIND=JWIM) :: IDAMPING From 54bc68e955573aaa69227b9a9d4e25c39e29e59a Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Mon, 13 Oct 2025 17:44:04 +0000 Subject: [PATCH 13/89] airsea_iter.F90 replaced by airsea_zbry.F90 --- src/ecwam/airsea_iter.F90 | 220 -------------------------------------- 1 file changed, 220 deletions(-) delete mode 100644 src/ecwam/airsea_iter.F90 diff --git a/src/ecwam/airsea_iter.F90 b/src/ecwam/airsea_iter.F90 deleted file mode 100644 index 0f3e85d64..000000000 --- a/src/ecwam/airsea_iter.F90 +++ /dev/null @@ -1,220 +0,0 @@ -! (C) Copyright 1989- ECMWF. -! -! This software is licensed under the terms of the Apache Licence Version 2.0 -! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. -! In applying this licence, ECMWF does not waive the privileges and immunities -! granted to it by virtue of its status as an intergovernmental organisation -! nor does it submit to any jurisdiction. -! - - SUBROUTINE AIRSEA_ITER (KIJS, KIJL, & -& HALP, U10, U10DIR, TAUW, TAUWDIR, RNFAC, & -& US, Z0, Z0B, CHRNCK, ICODE_WND, IUSFG) - -! ---------------------------------------------------------------------- - -!**** *AIRSEA_ITER* - DETERMINE TOTAL STRESS IN SURFACE LAYER. - -! P.A.E.M. JANSSEN KNMI AUGUST 1990 -! JEAN BIDLOT ECMWF FEBRUARY 1999 : TAUT is already -! SQRT(TAUT) -! JEAN BIDLOT ECMWF OCTOBER 2004: QUADRATIC STEP FOR -! TAUW - -!* PURPOSE. -! -------- - -! COMPUTE TOTAL STRESS. - -!** INTERFACE. -! ---------- - -! *CALL* *AIRSEA_ZBRY (KIJS, KIJL, FL1, WAVNUM, -! HALP, U10, U10DIR, TAUW, TAUWDIR, RNFAC, -! US, Z0, Z0B, CHRNCK, ICODE_WND, IUSFG)* - -! *KIJS* - INDEX OF FIRST GRIDPOINT. -! *KIJL* - INDEX OF LAST GRIDPOINT. -! *FL1* - SPECTRA -! *WAVNUM* - WAVE NUMBER -! *HALP* - 1/2 PHILLIPS PARAMETER -! *U10* - WINDSPEED U10. -! *U10DIR* - WINDSPEED DIRECTION. -! *TAUW* - WAVE STRESS. -! *TAUWDIR* - WAVE STRESS DIRECTION. -! *RNFAC* - WIND DEPENDENT FACTOR USED IN THE GROWTH RENORMALISATION. -! *US* - OUTPUT OR OUTPUT BLOCK OF FRICTION VELOCITY. -! *Z0* - OUTPUT BLOCK OF ROUGHNESS LENGTH. -! *Z0B* - BACKGROUND ROUGHNESS LENGTH. -! *CHRNCK* - CHARNOCK COEFFICIENT -! *ICODE_WND* SPECIFIES WHICH OF U10 OR US HAS BEEN FILED UPDATED: -! U10: ICODE_WND=3 --> US will be updated -! US: ICODE_WND=1 OR 2 --> U10 will be updated -! *IUSFG* - IF = 1 THEN USE THE FRICTION VELOCITY (US) AS FIRST GUESS in TAUT_Z0 -! 0 DO NOT USE THE FIELD US - - -! ---------------------------------------------------------------------- - - USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU - - USE YOWPARAM, ONLY : NANG ,NFRE - USE YOWPHYS, ONLY : XKAPPA, XNLEV, CDFAC - USE YOWSTAT, ONLY : IPHYS2_AIRSEA - USE YOWPCONS, ONLY : G - USE YOWTEST, ONLY : IU06 - USE YOWWIND, ONLY : WSPMIN - - USE YOMHOOK, ONLY: LHOOK, DR_HOOK, JPHOOK - -! ---------------------------------------------------------------------- - IMPLICIT NONE - -#include "abort1.intfb.h" -#include "taut_z0.intfb.h" -#include "z0wave.intfb.h" - - INTEGER(KIND=JWIM), INTENT(IN) :: KIJS, KIJL, ICODE_WND, IUSFG - REAL(KIND=JWRB), DIMENSION(KIJL), INTENT (IN) :: HALP, U10DIR, TAUW, TAUWDIR, RNFAC - REAL(KIND=JWRB), DIMENSION(KIJL), INTENT (INOUT) :: U10, US, CHRNCK - REAL(KIND=JWRB), DIMENSION(KIJL), INTENT (OUT) :: Z0, Z0B - - INTEGER(KIND=JWIM) :: IJ, I, J - - REAL(KIND=JWRB) :: ZNLEV - REAL(KIND=JWRB), PARAMETER :: RKAP = 0.4_JWRB - REAL(KIND=JWRB), PARAMETER :: ZRN=1.65E-6_JWRB ! effective kinematic viscosity (0.11*1.5e-5) - - ! for the ietrative scheme - INTEGER(KIND=JWIM), PARAMETER :: NITER=15 - -! CD=ACD+BCD*U10 - REAL(KIND=JWRB), PARAMETER :: ACD=0.0008_JWRB - REAL(KIND=JWRB), PARAMETER :: BCD=0.00008_JWRB - -! CD = ACDLIN + BCDLIN*SQRT(PCHAR) * U10 - REAL(KIND=JWRB), PARAMETER :: ACDLIN=0.0008_JWRB - REAL(KIND=JWRB), PARAMETER :: BCDLIN=0.00047_JWRB - REAL(KIND=JWRB), PARAMETER :: XEPS=0.00001_JWRB - REAL(KIND=JWRB), PARAMETER :: USTMIN=0.000001_JWRB - REAL(KIND=JWRB), PARAMETER :: PCHARMAX=0.1_JWRB - REAL(KIND=JWRB), PARAMETER :: Z0FG=0.01_JWRB - - INTEGER(KIND=JWIM) :: ITER - REAL(KIND=JWRB) :: XZNLEV, PCHAROG, XKUTOP, XOLOGZ0 - REAL(KIND=JWRB) :: CDLIN, UST, USTOLD, Z0CH, Z0VIS, F, DELF - - REAL(KIND=JWRB) :: XI, XJ, DELI1, DELI2, DELJ1, DELJ2, UST2, ARG, SQRTCDM1 - REAL(KIND=JWRB) :: XKAPPAD, XLOGLEV - REAL(KIND=JWRB) :: XLEV, FLX4A0, CD - REAL(KIND=JPHOOK) :: ZHOOK_HANDLE - -! ---------------------------------------------------------------------- - IF (LHOOK) CALL DR_HOOK ('AIRSEA_ITER', 0, ZHOOK_HANDLE) - -!* 2. DETERMINE TOTAL STRESS AND ROUGHNESS (if needed) -! ---------------------------------- - - IF (ICODE_WND == 3) THEN - -! Wind height - ZNLEV = 10._JWRB - - !$loki inline - SELECT CASE (IPHYS2_AIRSEA) - - ! implementation of Hwang (2011) as in ST6 - CASE(0) - FLX4A0 = CDFAC - DO IJ=KIJS,KIJL - IF (U10(IJ) .GE. 50.33_JWRB) THEN - US(IJ) = 2.026_JWRB * SQRT(FLX4A0) - CD = (US(IJ)/U10(IJ))**2 - ELSE - CD = FLX4A0 * ( 8.058_JWRB + 0.967_JWRB*U10(IJ) - 0.016_JWRB*U10(IJ)**2 ) * 1E-4_JWRB - US(IJ) = U10(IJ) * SQRT(CD) - END IF - ! - Z0(IJ) = ZNLEV * EXP ( -0.4_JWRB / SQRT(CD) ) - ENDDO - - ! implementation of iterative scheme - CASE(1,2) - - DO IJ=KIJS,KIJL - ! -------------------------------------------- - ! Iterative method - - XKUTOP = RKAP*U10(IJ) - - ! Start with old charnock (and protect the scheme) - PCHAROG = MIN(CHRNCK(IJ),PCHARMAX)/G - - ! Cd as a linear relation with slope function of Charnock - CDLIN= ACDLIN + BCDLIN*SQRT(PCHAROG*G) * U10(IJ) - - ! first guess for u* - ! UST = U10(IJ)*SQRT(ACD+BCD*U10(IJ)) ! Use linear approx - ! UST = SQRT(CD)*U10(IJ) ! Use Hersbach approx - UST = SQRT(CDLIN)*U10(IJ) ! Use Hersbach approx - - ! iterate - DO ITER=1,NITER - USTOLD = MAX(UST,USTMIN) - Z0CH = PCHAROG*UST**2 - Z0VIS = ZRN/UST - Z0(IJ) = Z0CH+Z0VIS - XZNLEV = ZNLEV/(ZNLEV+Z0(IJ)) - XOLOGZ0 = 1.0_JWRB/LOG(1.0_JWRB+ZNLEV/Z0(IJ)) - F = UST-XKUTOP*XOLOGZ0 - DELF = 1.0_JWRB-XKUTOP*XOLOGZ0**2*XZNLEV* & - & (2.0_JWRB*Z0CH-Z0VIS)/(UST*Z0(IJ)) - IF(DELF /= 0.0_JWRB) UST = UST-F/DELF - - IF(ABS(UST-USTOLD)<=UST*XEPS .AND. ABS(F)<=XEPS) EXIT - ENDDO - - ! Update Z0, US and then charnock - IF(ITER > NITER) THEN - ! failed to iterate - Z0(IJ) = Z0FG - US(IJ) = XKUTOP/LOG(1.0+ZNLEV/Z0(IJ)) - ELSE - US(IJ) = MAX(UST,USTMIN) - ! Z0(IJ) = Z0CH ! Commented out -> Z0=Z0TOT - ENDIF - - - ENDDO - END SELECT - - ELSEIF (ICODE_WND == 1 .OR. ICODE_WND == 2) THEN - -!* 3. DETERMINE ROUGHNESS LENGTH (if needed). -! --------------------------- - - !$loki inline - CALL Z0WAVE (KIJS, KIJL, US, TAUW, U10, Z0, Z0B, CHRNCK) - -!* 3. DETERMINE U10 (if needed). -! --------------------------- - - XKAPPAD = 1.0_JWRB / XKAPPA - XLOGLEV = LOG (XNLEV) - - DO IJ = KIJS, KIJL - U10 (IJ) = XKAPPAD * US (IJ) * (XLOGLEV - LOG (Z0 (IJ))) - U10 (IJ) = MAX (U10 (IJ), WSPMIN) - ENDDO - - ELSE - WRITE (IU06, * ) ' ++++++++++++++++++++++++++++++++++++++++++' - WRITE (IU06, * ) ' + AIRSEA_ITER : INVALID VALUE OF ICODE_WND +' - WRITE (IU06, * ) ' ICODE_WND = ', ICODE_WND - WRITE (IU06, * ) ' ++++++++++++++++++++++++++++++++++++++++++' - CALL ABORT1 - ENDIF - - IF (LHOOK) CALL DR_HOOK ('AIRSEA_ITER', 1, ZHOOK_HANDLE) - - END SUBROUTINE AIRSEA_ITER From 42d2b3fb91619d507e8b7dabe43f16e80732a286 Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Tue, 14 Oct 2025 09:42:55 +0000 Subject: [PATCH 14/89] remove unnecessary line --- src/ecwam/sinflx_bydbr.F90 | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/ecwam/sinflx_bydbr.F90 b/src/ecwam/sinflx_bydbr.F90 index 68fe23605..6a62065c8 100644 --- a/src/ecwam/sinflx_bydbr.F90 +++ b/src/ecwam/sinflx_bydbr.F90 @@ -227,8 +227,6 @@ SUBROUTINE SINFLX_BYDBR (ICALL, NCALL, KIJS, KIJL, & REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE) :: SLGST_AVG, SPOSGST_AVG, FLGST_AVG REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE,NGST) :: SLGST, SPOSGST, FLGST -INTEGER(KIND=JWIM), PARAMETER :: SINFLX_BYDBR_PHYS=0 !0=~ST6, 1=iterative, 2=based only on wind! - ! For PHIWA calculation ! REAL(KIND=JWRB),DIMENSION(KIJL,NFRE) :: RHOWGDFTH ! REAL(KIND=JWRB), DIMENSION(KIJL) :: SUMT From ebccf9cf50b13fee81fb719125965f5725b2411e Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Tue, 14 Oct 2025 10:01:14 +0000 Subject: [PATCH 15/89] renaming bydbr to zbry --- src/ecwam/frcutindex.F90 | 4 +- src/ecwam/frcutindex_zbry.F90 | 119 +++++++ src/ecwam/implsch.F90 | 2 +- src/ecwam/irange.F90 | 2 +- src/ecwam/lfactor.F90 | 2 +- src/ecwam/sdissip.F90 | 8 +- src/ecwam/sdissip_zbry.F90 | 249 ++++++++++++++ src/ecwam/setwavphys.F90 | 2 +- src/ecwam/sinflx.F90 | 4 +- src/ecwam/sinflx_zbry.F90 | 627 ++++++++++++++++++++++++++++++++++ src/ecwam/swldissip_zbry.F90 | 228 +++++++++++++ src/ecwam/tau_wave_atmos.F90 | 2 +- src/ecwam/tauwinds.F90 | 2 +- src/ecwam/yowphys.F90 | 2 +- 14 files changed, 1238 insertions(+), 15 deletions(-) create mode 100644 src/ecwam/frcutindex_zbry.F90 create mode 100644 src/ecwam/sdissip_zbry.F90 create mode 100644 src/ecwam/sinflx_zbry.F90 create mode 100644 src/ecwam/swldissip_zbry.F90 diff --git a/src/ecwam/frcutindex.F90 b/src/ecwam/frcutindex.F90 index 504d37618..cc4b5749e 100644 --- a/src/ecwam/frcutindex.F90 +++ b/src/ecwam/frcutindex.F90 @@ -61,7 +61,7 @@ SUBROUTINE FRCUTINDEX (KIJS, KIJL, FM, FMWS, UFRIC, CICOVER, & IMPLICIT NONE #include "frcutindex_default.intfb.h" -#include "frcutindex_bydb.intfb.h" +#include "frcutindex_zbry.intfb.h" INTEGER(KIND=JWIM), INTENT(IN) :: KIJS, KIJL INTEGER(KIND=JWIM), INTENT(OUT) :: MIJ(KIJL) @@ -83,7 +83,7 @@ SUBROUTINE FRCUTINDEX (KIJS, KIJL, FM, FMWS, UFRIC, CICOVER, & CALL FRCUTINDEX_DEFAULT(KIJS, KIJL, FM, FMWS, UFRIC, CICOVER, & & MIJ) CASE(2) - CALL FRCUTINDEX_BYDB (KIJS, KIJL, FM, UFRIC, CICOVER, & + CALL FRCUTINDEX_ZBRY (KIJS, KIJL, FM, UFRIC, CICOVER, & & MIJ) END SELECT diff --git a/src/ecwam/frcutindex_zbry.F90 b/src/ecwam/frcutindex_zbry.F90 new file mode 100644 index 000000000..ade10e9e3 --- /dev/null +++ b/src/ecwam/frcutindex_zbry.F90 @@ -0,0 +1,119 @@ + SUBROUTINE FRCUTINDEX_ZBRY (KIJS, KIJL, FM, UFRIC, CICOVER, & + & MIJ) + +! ---------------------------------------------------------------------- + +!**** *FRCUTINDEX_ZBRY* - RETURNS THE LAST FREQUENCY INDEX OF +! PROGNOSTIC PART OF SPECTRUM. + +!** INTERFACE. +! ---------- + +! *CALL* *FRCUTINDEX_ZBRY (KIJS, KIJL, FM, UFRIC, CICOVER,MIJ) +! *KIJS* - INDEX OF FIRST GRIDPOINT +! *KIJL* - INDEX OF LAST GRIDPOINT +! *FM* - MEAN FREQUENCY +! *UFRIC* - FRICTION VELOCITY IN M/S +! *CICOVER*- CICOVER +! *MIJ* - LAST FREQUENCY INDEX for imposing high frequency tail + + + +! METHOD. +! ------- + +!* COMPUTES LAST FREQUENCY INDEX OF PROGNOSTIC PART OF SPECTRUM +! ACCORDING TO ZBRY + +! EXTERNALS. +! --------- + +! REFERENCE. +! ---------- + +! ORIGIN. +! ---------- +! Adapted from Babanin Young Donelan & Banner (ZBRY) physics +! as implemented as ST6 in WAVEWATCH-III +! WW3 module: W3SRCEMD +! WW3 subroutine: +! Implementation into ECWAM DECEMBER 2021 by J. Kousal + +! ---------------------------------------------------------------------- + + USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU + + USE YOWPHYS , ONLY : TAILFACTOR, TAILFACTOR_PM + USE YOWFRED , ONLY : FR ,DFIM ,FRATIO ,FLOGSPRDM1, & + & DELTH ,RHOWG_DFIM ,FRIC + USE YOWICE , ONLY : CITHRSH_TAIL + USE YOWPARAM , ONLY : NANG ,NFRE + USE YOWPCONS , ONLY : G ,ZPI ,EPSMIN, EPSUS + USE YOMHOOK , ONLY : LHOOK, DR_HOOK + +! ---------------------------------------------------------------------- + + IMPLICIT NONE + + INTEGER(KIND=JWIM), INTENT(IN) :: KIJS, KIJL + INTEGER(KIND=JWIM), INTENT(OUT) :: MIJ(KIJL) + + REAL(KIND=JWRB),DIMENSION(KIJL), INTENT(IN) :: FM, UFRIC, CICOVER + + REAL(KIND=JWRB) :: ZHOOK_HANDLE + + INTEGER(KIND=JWIM) :: IJ, NK, NKH, NKH1, M + REAL(KIND=JWRB), PARAMETER :: SIN6FC = 6.0_JWRB + REAL(KIND=JWRB) :: FXFM, FXPM, FACTI1, FACTI2 ! constants + REAL(KIND=JWRB) :: FHIGH ! Cut-off frequency in integration (rad/s) + REAL(KIND=JWRB) :: SIGNK ! LAST FREQUENCY [RAD] + REAL(KIND=JWRB) :: USTM1 + + +! ---------------------------------------------------------------------- + + IF (LHOOK) CALL DR_HOOK('FRCUTINDEX_ZBRY',0,ZHOOK_HANDLE) + + NK = NFRE + FXFM = SIN6FC + FXFM = FXFM * ZPI + FXPM = 4.0_JWRB !TODO: 4.0_JWRB is the factor for the tail (is this right) + FXPM = FXPM * G / 28.0_JWRB !TODO: should this be FRIC? + SIGNK = ZPI*FR(NFRE) + + DO IJ=KIJS,KIJL + IF (CICOVER(IJ) <= CITHRSH_TAIL) THEN + + USTM1 = 1.0_JWRB/MAX(UFRIC(IJ),EPSUS) ! Protect the code + + IF (FXFM .LE. 0) THEN + FHIGH = SIGNK ! LAST FREQ i.e. let tail evolve freely + ELSE + FHIGH = MAX (FXFM * FM(IJ), FXPM * USTM1 ) + ENDIF + + + FACTI1 = 1.0_JWRB / LOG(FRATIO) + FACTI2 = 1.0_JWRB - LOG(ZPI*FR(1)) * FACTI1 + + NKH = MIN ( NK , INT(FACTI2+FACTI1*LOG(MAX(1.0E-7_JWRB,FHIGH))) ) + NKH1 = MIN ( NK , NKH+1 ) + + + IF (FXFM .LE. 0) THEN + FHIGH = SIGNK + ELSE + FHIGH = MIN ( SIGNK, MAX(FXFM * FM(IJ), FXPM * USTM1) ) + ENDIF + NKH = MAX ( 2 , MIN ( NKH1 , & + INT ( FACTI2 + FACTI1*LOG(MAX(1.0E-7_JWRB,FHIGH)) ) ) ) + + MIJ(IJ) = NKH + ELSE + MIJ(IJ) = NFRE + ENDIF + END DO + + IF (LHOOK) CALL DR_HOOK('FRCUTINDEX_ZBRY',1,ZHOOK_HANDLE) + + END SUBROUTINE FRCUTINDEX_ZBRY diff --git a/src/ecwam/implsch.F90 b/src/ecwam/implsch.F90 index 18a14d410..7e07e4b1a 100644 --- a/src/ecwam/implsch.F90 +++ b/src/ecwam/implsch.F90 @@ -255,7 +255,7 @@ SUBROUTINE IMPLSCH (KIJS, KIJL, FL1, & CASE(0,1) NCALL = 2 CASE(2) - ! test without iterating for BYDBR on physics + ! test without iterating for ZBRY on physics NCALL = 1 END SELECT diff --git a/src/ecwam/irange.F90 b/src/ecwam/irange.F90 index 861d9cf9f..9d94cd2d3 100644 --- a/src/ecwam/irange.F90 +++ b/src/ecwam/irange.F90 @@ -13,7 +13,7 @@ FUNCTION IRANGE(X0,X1,DX) RESULT(IX) ! ORIGIN. ! ---------- - ! Adapted from Babanin Young Donelan & Banner (BYDB) physics + ! Adapted from Babanin Young Donelan & Banner (ZBRY) physics ! as implemented as ST6 in WAVEWATCH-III ! WW3 module: W3SRC6MD ! WW3 subroutine: IRANGE diff --git a/src/ecwam/lfactor.F90 b/src/ecwam/lfactor.F90 index 0cb7ecec7..e973a9a16 100644 --- a/src/ecwam/lfactor.F90 +++ b/src/ecwam/lfactor.F90 @@ -65,7 +65,7 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, USDIR, ROAIRN, SIG, DSII, & ! ORIGIN. ! ---------- -! Adapted from Babanin Young Donelan & Banner (BYDB) physics +! Adapted from Babanin Young Donelan & Banner (ZBRY) physics ! as implemented as ST6 in WAVEWATCH-III ! WW3 module: W3SRC6MD ! WW3 subroutine: LFACTOR diff --git a/src/ecwam/sdissip.F90 b/src/ecwam/sdissip.F90 index 41e698303..082baa068 100644 --- a/src/ecwam/sdissip.F90 +++ b/src/ecwam/sdissip.F90 @@ -58,8 +58,8 @@ SUBROUTINE SDISSIP (KIJS, KIJL, FL1, FLD, SL, & #include "sdissip_ard.intfb.h" #include "sdissip_jan.intfb.h" -#include "sdissip_bydbr.intfb.h" -#include "swldissip_bydbr.intfb.h" +#include "sdissip_zbry.intfb.h" +#include "swldissip_zbry.intfb.h" INTEGER(KIND=JWIM), INTENT(IN) :: KIJS, KIJL REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(IN) :: FL1 @@ -89,10 +89,10 @@ SUBROUTINE SDISSIP (KIJS, KIJL, FL1, FLD, SL, & & UFRIC, COSWDIF, RAORW) CASE(2) !$loki inline - CALL SDISSIP_BYDBR (KIJS, KIJL, FL1 ,FLD, SL, & + CALL SDISSIP_ZBRY (KIJS, KIJL, FL1 ,FLD, SL, & & WAVNUM, CGROUP, XK2CG, & & UFRIC, COSWDIF, RAORW) - CALL SWLDISSIP_BYDBR(KIJS, KIJL, FL1 ,FLD, SL, & + CALL SWLDISSIP_ZBRY(KIJS, KIJL, FL1 ,FLD, SL, & & WAVNUM, CGROUP, XK2CG, & & UFRIC, COSWDIF, RAORW) END SELECT diff --git a/src/ecwam/sdissip_zbry.F90 b/src/ecwam/sdissip_zbry.F90 new file mode 100644 index 000000000..40ff03fe8 --- /dev/null +++ b/src/ecwam/sdissip_zbry.F90 @@ -0,0 +1,249 @@ +! (C) Copyright 1989- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! + + SUBROUTINE SDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & + & WAVNUM, CGROUP, XK2CG, & + & UFRIC, COSWDIF, RAORW) +! ---------------------------------------------------------------------- + +!**** *SDISSIP_ZBRY* - COMPUTATION OF DISSIPATION SOURCE FUNCTION. + +! LOTFI AOUF METEO FRANCE 2013 +! FABRICE ARDHUIN IFREMER 2013 + + +!* PURPOSE. +! -------- +! Observation-based source term for dissipation after Babanin et al. +! (2010) following the implementation by Rogers et al. (2012). The +! dissipation function Sds accommodates an inherent breaking term T1 +! and an additional cumulative term T2 at all frequencies above the +! peak. The forced dissipation term T2 is an integral that grows +! toward higher frequencies and dominates at smaller scales +! (Babanin et al. 2010). +! +!** INTERFACE. +! ---------- + +! *CALL* *SDISSIP_ZBRY (KIJS, KIJL, FL1, FLD,SL,* +! WAVNUM, CGROUP, XK2CG, +! UFRIC, COSWDIF, RAORW)* +! *KIJS* - INDEX OF FIRST GRIDPOINT +! *KIJL* - INDEX OF LAST GRIDPOINT +! *FL1* - SPECTRUM. +! *FLD* - DIAGONAL MATRIX OF FUNCTIONAL DERIVATIVE +! *SL* - TOTAL SOURCE FUNCTION ARRAY +! *WAVNUM* - WAVE NUMBER +! *CGROUP* - GROUP SPEED +! *XK2CG* - (WAVE NUMBER)**2 * GROUP SPEED +! *UFRIC* - FRICTION VELOCITY IN M/S. +! *RAORW* - RATIO AIR DENSITY TO WATER DENSITY +! *COSWDIF*- COS(TH(K)-WDWAVE(IJ)) + + +! METHOD. +! ------- + +! SEE REFERENCES. + +! EXTERNALS. +! ---------- + +! IRANGE + +! REFERENCE. +! ---------- + +! Babanin et al. 2010: JPO 40(4), 667-683 +! Rogers et al. 2012: JTECH 29(9) 1329-1346 + +! ORIGIN. +! ---------- +! Adapted from Babanin Young Donelan & Banner (ZBRY) physics +! as implemented as ST6 in WAVEWATCH-III +! WW3 module: W3SRC6MD +! WW3 subroutine: W3SDS6 +! Implementation into ECWAM DECEMBER 2021 by J. Kousal + + +! ---------------------------------------------------------------------- + USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU + + USE YOWFRED , ONLY : FR , TH ,ZPIFR ,FRATIO ,DELTH, DFIM + USE YOWPCONS , ONLY : G ,ZPI + USE YOWPARAM , ONLY : NANG ,NFRE + USE YOWPHYS , ONLY : SDSBR ,ISDSDTH ,ISB ,IPSAT , & +& SSDSC2 , SSDSC4, SSDSC6, MICHE, SSDSC3, SSDSBRF1, & +& BRKPBCOEF ,SSDSC5, NSDSNTH, & +& INDICESSAT, SATWEIGHTS + + USE YOMHOOK , ONLY : LHOOK ,DR_HOOK, JPHOOK + +! ---------------------------------------------------------------------- + + IMPLICIT NONE +#include "irange.intfb.h" + + INTEGER(KIND=JWIM), INTENT(IN) :: KIJS, KIJL + + REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(IN) :: FL1 + REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(INOUT) :: FLD, SL + REAL(KIND=JWRB), DIMENSION(KIJL,NFRE), INTENT(IN) :: WAVNUM, CGROUP, XK2CG + REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: UFRIC, RAORW + REAL(KIND=JWRB), DIMENSION(KIJL, NANG), INTENT(IN) :: COSWDIF + + INTEGER(KIND=JWIM) :: IJ, K, M, I, J, M2, K2, NANGD + INTEGER(KIND=JWIM) :: NSPEC !num. of freqs, dirs, spec. bins + INTEGER(KIND=JWIM), DIMENSION(NANG) :: ITHN + INTEGER(KIND=JWIM), DIMENSION(NFRE) :: IKN + + REAL(KIND=JWRB), PARAMETER :: SDS6A1 = 4.75E-6_JWRB ! ST6 PARAM + REAL(KIND=JWRB), PARAMETER :: SDS6A2 = 7.00E-5_JWRB ! ST6 PARAM + INTEGER(KIND=JWIM), PARAMETER :: SDS6P1 = 4 ! ST6 PARAM + INTEGER(KIND=JWIM), PARAMETER :: SDS6P2 = 4 ! ST6 PARAM + LOGICAL, PARAMETER :: SDS6ET = .TRUE. ! ST6 PARAM + + REAL(KIND=JWRB), DIMENSION(NFRE) :: FREQ ! frequencies [Hz] + REAL(KIND=JWRB), DIMENSION(NFRE) :: SIG ! frequencies [RAD] + REAL(KIND=JWRB), DIMENSION(NFRE) :: DFII ! frequency bandwiths [Hz] + REAL(KIND=JWRB), DIMENSION(NFRE) :: ANAR ! directional narrowness + REAL(KIND=JWRB), DIMENSION(NFRE) :: EDENS ! spectral density E(f) + REAL(KIND=JWRB), DIMENSION(NFRE) :: ETDENS ! threshold spec. density ET(f) + REAL(KIND=JWRB), DIMENSION(NFRE) :: EXDENS ! excess spectral density EX(f) + REAL(KIND=JWRB), DIMENSION(NFRE) :: NEXDENS! normalised excess spec.dens. + REAL(KIND=JWRB), DIMENSION(NFRE) :: T1 ! inherent breaking term + REAL(KIND=JWRB), DIMENSION(NFRE) :: T2 ! forced dissipation term + REAL(KIND=JWRB), DIMENSION(NFRE) :: T12 ! =T1+T2 or combined dissipation + REAL(KIND=JWRB), DIMENSION(NFRE) :: ADF ! temporary variable + REAL(KIND=JWRB), DIMENSION(NFRE) :: DF ! FREQUENCY INTERVALS + REAL(KIND=JWRB) :: BNT ! empirical constant for wave breaking probability + REAL(KIND=JWRB) :: XFAC, EDENSMAX ! temporary variableis + + REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: S, D, A + REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: SIG2, CG2 + REAL(KIND=JWRB), DIMENSION(NANG,NFRE) :: DDS + + + REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: XK, CGG_WAM + REAL(KIND=JWRB), DIMENSION(NFRE) :: SIGP2 + + + REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ---------------------------------------------------------------------- + + IF (LHOOK) CALL DR_HOOK('SDISSIP_ZBRY',0,ZHOOK_HANDLE) + + NSPEC = NANG * NFRE ! NUMBER OF SPECTRAL BINS + + DO M = 1,NFRE + SIG(M) = ZPI*FR(M) + SIGP2(M) = SIG(M)**2 + END DO + +! COMPUTE FREQUENCY INTERVALLS (borrowed from Wam_others/f4spec.F) + DO M = 1,NFRE + DF(M) = FR(M)*( FRATIO - 1.0_JWRB ) + ENDDO + + IKN = IRANGE(1,NSPEC,NANG) ! Index vector for elements of 1 ... NFRE +! ! such that e.g. SIG(1:NFRE) = SIG2(IKN). + DO K = 1, NANG ! Apply to all directions + SIG2 (IKN+(K-1)) = SIG + END DO + + + ! LOOP OVER LOCATIONS + DO IJ = KIJS,KIJL + + DO K = 1, NANG ! Apply to all directions + CG2 (IKN+(K-1)) = CGROUP(IJ,:) + END DO + + A = RESHAPE( FL1(IJ,:,:) , (/NSPEC/)) * CG2 / ( ZPI * SIG2 )! ACTION DENSITY SPECTRUM + ! WAM E(f,theta) to WW3 A(k,theta) conversion factor: CG2 / ( ZPI *SIG2 ) + +!/ 0) --- Initialize essential parameters ---------------------------- / + IKN = IRANGE(1,NSPEC,NANG) ! Index vector for elements of 1, +! ! 2,..., NFRE such that for example +! ! SIG(1:NFRE) = SIG2(IKN). + FREQ = FR(1:NFRE) + ANAR = 1.0_JWRB + BNT = 0.035_JWRB**2 + T1 = 0.0_JWRB + T2 = 0.0_JWRB + NEXDENS = 0.0_JWRB +! +!/ 1) --- Calculate threshold spectral density, spectral density, and +!/ the level of exceedence EXDENS(f) -------------------------- / +! ETDENS = ( ZPI * BNT ) / ( ANAR * CGG(IJ,:) * WN(IJ,:)**3 ) + ETDENS = ( ZPI * BNT ) / ( ANAR * CGROUP(IJ,:) * WAVNUM(IJ,:)**3 ) + !EDENS = SUM(FL1(IJ,:,:),1) * ZPI * SIG * DELTH / CGG(IJ,:) !E(f) + EDENS = SUM(FL1(IJ,:,:),1) * DELTH !E(f) + EXDENS = MAX(0.0_JWRB,EDENS-ETDENS) +! +!/ --- normalise by a generic spectral density -------------------- / + IF (SDS6ET) THEN ! ww3_grid.inp: &SDS6 SDSET = T or F + NEXDENS = EXDENS / ETDENS ! normalise by threshold spectral density + ELSE ! normalise by spectral density + EDENSMAX = MAXVAL(EDENS)*1.0E-5_JWRB + IF (ALL(EDENS .GT. EDENSMAX)) THEN + NEXDENS = EXDENS / EDENS + ELSE + DO M = 1,NFRE + IF (EDENS(M) .GT. EDENSMAX) NEXDENS(M) = EXDENS(M) / EDENS(M) + END DO + END IF + END IF +! +!/ 2) --- Calculate inherent breaking component T1 ------------------- / + T1 = SDS6A1 * ANAR * FREQ * (NEXDENS**SDS6P1) +! +!/ 3) --- Calculate T2, the dissipation of waves induced by +!/ the breaking of longer waves T2 ---------------------------- / + ADF = ANAR * (NEXDENS**SDS6P2) + XFAC = (1.0_JWRB-1.0_JWRB/FRATIO)/(FRATIO-1.0_JWRB/FRATIO) + DO M = 1,NFRE + DFII(M) = DF(M) ! bug fix (spotted by Heinz): brought init into loc loop +! IF (M .GT. 1) DFII(M) = DFII(M) * XFAC + IF (M .GT. 1 .AND. M .LT. NFRE) DFII(M) = DFII(M) * XFAC + T2(M) = SDS6A2 * SUM( ADF(1:M)*DFII(1:M) ) + END DO + +!/ 4) --- Sum up dissipation terms and apply to all directions ------- / + T12 = -1.0_JWRB * ( MAX(0.0_JWRB,T1)+MAX(0.0_JWRB,T2) ) + DO K = 1, NANG + D(IKN+(K-1)) = T12 + END DO +! + !S = D * A +! +!/ 5) --- Diagnostic output (switch !/T6) ---------------------------- / +!/T6 CALL STME21 ( TIME , IDTIME ) +!/T6 WRITE (NDST,270) 'T1*E',IDTIME(1:19),(T1*EDENS) +!/T6 WRITE (NDST,270) 'T2*E',IDTIME(1:19),(T2*EDENS) +!/T6 WRITE (NDST,271) SUM(SUM(RESHAPE(S,(/ NANG,NFRE /)),1)*DDEN/CG) +! +!/T6 270 FORMAT (' TEST W3SDS6 : ',A,'(',A,')',':',70E11.3) +!/T6 271 FORMAT (' TEST W3SDS6 : Total SDS =',E13.5) + + DDS = RESHAPE(D,(/NANG,NFRE/)) + DO M = 1,NFRE + DO K = 1, NANG + SL(IJ,K,M) = SL(IJ,K,M) + DDS(K,M)*FL1(IJ,K,M) + FLD(IJ,K,M) = FLD(IJ,K,M) + DDS(K,M) + END DO + END DO + + END DO + ! END LOOP OVER LOC + + IF (LHOOK) CALL DR_HOOK('SDISSIP_ZBRY',1,ZHOOK_HANDLE) + + END SUBROUTINE SDISSIP_ZBRY diff --git a/src/ecwam/setwavphys.F90 b/src/ecwam/setwavphys.F90 index 873bc486e..ffe588a6d 100644 --- a/src/ecwam/setwavphys.F90 +++ b/src/ecwam/setwavphys.F90 @@ -217,7 +217,7 @@ SUBROUTINE SETWAVPHYS BSWKM=0.425_JWRB - ! Not ALL necessarily used in BYDB physics (TODO: change any others?) + ! Not ALL necessarily used in ZBRY physics (TODO: change any others?) ALPHA = 0.0065_JWRB BETAMAX = 1.40_JWRB ZALP = 0.008_JWRB diff --git a/src/ecwam/sinflx.F90 b/src/ecwam/sinflx.F90 index 0840c17f8..fae260b24 100644 --- a/src/ecwam/sinflx.F90 +++ b/src/ecwam/sinflx.F90 @@ -42,7 +42,7 @@ SUBROUTINE SINFLX (ICALL, NCALL, KIJS, KIJL, & IMPLICIT NONE #include "sinflx_ard_jan.intfb.h" -#include "sinflx_bydbr.intfb.h" +#include "sinflx_zbry.intfb.h" INTEGER(KIND=JWIM), INTENT(IN) :: ICALL !! CALL NUMBER. INTEGER(KIND=JWIM), INTENT(IN) :: NCALL !! TOTAL NUMBER OF CALLS. @@ -115,7 +115,7 @@ SUBROUTINE SINFLX (ICALL, NCALL, KIJS, KIJL, & & FLD, SL, SPOS, & & MIJ, RHOWGDFTH, XLLWS) CASE(2) - CALL SINFLX_BYDBR (ICALL, NCALL, KIJS, KIJL, & + CALL SINFLX_ZBRY (ICALL, NCALL, KIJS, KIJL, & & LUPDTUS, & & FL1, & & WAVNUM,CGROUP, CINV, XK2CG,& diff --git a/src/ecwam/sinflx_zbry.F90 b/src/ecwam/sinflx_zbry.F90 new file mode 100644 index 000000000..d3284cbd3 --- /dev/null +++ b/src/ecwam/sinflx_zbry.F90 @@ -0,0 +1,627 @@ +! (C) Copyright 1989- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! + +SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, KIJS, KIJL, & + & LUPDTUS, & + & FL1, & + & WAVNUM,CGROUP, CINV, XK2CG,& + & WSWAVE, WDWAVE, AIRD, & + & RAORW, WSTAR, CICOVER, & + & COSWDIF, SINWDIF2, & + & FMEAN, HALP, FMEANWS, & + & FLM, & + & UFRIC, TAUW, TAUWDIR, & + & Z0M, Z0B, CHRNCK, PHIWA, & + & FLD, SL, SPOS, & + & MIJ, RHOWGDFTH, XLLWS) + +! ---------------------------------------------------------------------- + +!**** *SINFLX_ZBRY* - COMPUTATION OF INPUT SOURCE FUNCTION AND STRESSES + + +!* PURPOSE. +! --------- + +! Observation-based source term for wind input after Donelan, Babanin, +! Young and Banner (Donelan et al ,2006) following the implementation +! by Rogers et al. (2012). +! +!** INTERFACE. +! ---------- + +! *CALL* *SINFLX_ZBRY (NGST, LLSNEG, KIJS, KIJL, FL1, +! & WAVNUM, CGROUP, CINV, XK2CG, +! & WSWAVE, WDWAVE, UFRIC, Z0M, +! & COSWDIF, SINWDIF2, +! & RAORW, WSTAR, RNFAC, +! & FLD, SL, SPOS, XLLWS) +! *NGST* - IF = 1 THEN NO GUSTINESS PARAMETERISATION +! - IF = 2 THEN GUSTINESS PARAMETERISATION +! *LLSNEG- IF TRUE THEN THE NEGATIVE SINPUT (SWELL DAMPING) WILL BE COMPUTED +! *KIJS* - INDEX OF FIRST GRIDPOINT. +! *KIJL* - INDEX OF LAST GRIDPOINT. +! *FL1* - SPECTRUM. +! *WAVNUM* - WAVE NUMBER. +! *CGROUP* - GROUP SPEED +! *CINV* - INVERSE PHASE VELOCITY. +! *XK2CG* - (WAVNUM)**2 * GROUP SPPED. +! *WDWAVE* - WIND DIRECTION IN RADIANS IN OCEANOGRAPHIC +! NOTATION (POINTING ANGLE OF WIND VECTOR, +! CLOCKWISE FROM NORTH). +! *UFRIC* - NEW FRICTION VELOCITY IN M/S. +! *Z0M* - ROUGHNESS LENGTH IN M. +! *COSWDIF* - COS(TH(K)-WDWAVE(IJ)) +! *SINWDIF2* - SIN(TH(K)-WDWAVE(IJ))**2 +! *RAORW* - RATIO AIR DENSITY TO WATER DENSITY. +! *WSTAR* - FREE CONVECTION VELOCITY SCALE (M/S). +! *RNFAC* - WIND DEPENDENT FACTOR USED IN THE GROWTH RENORMALISATION. +! *CHRNCK*- CHARNOCK COEFFICIENT +! *FLD* - DIAGONAL MATRIX OF FUNCTIONAL DERIVATIVE. +! *SL* - TOTAL SOURCE FUNCTION ARRAY. +! *SPOS* - POSITIVE SOURCE FUNCTION ARRAY. +! *XLLWS* - = 1 WHERE SINPUT IS POSITIVE + +! METHOD. +! ------- + +! SEE REFERENCE. + +! EXTERNALS. +! ---------- +! TAU_WAVE_ATMOS +! LFACTOR +! IRANGE + +! ORIGIN. +! ---------- +! Adapted from Babanin Young Donelan & Banner (ZBRY) physics +! as implemented as ST6 in WAVEWATCH-III +! WW3 module: W3SRC6MD +! WW3 subroutine: W3SIN6 +! Implementation into ECWAM DECEMBER 2021 by J. Kousal + + +! ---------------------------------------------------------------------- + + USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU + + USE YOWCOUP , ONLY : LWCOU ,LLCAPCHNK , LLGCBZ0, LLNORMAGAM + + USE YOWWNDG , ONLY : ICODE ,ICODE_CPL + + USE YOWFRED , ONLY : FR ,TH ,DFIM ,COSTH ,SINTH, ZPIFR, DELTH, FRATIO, FRIC + USE YOWPARAM , ONLY : NANG ,NFRE + USE YOWPCONS , ONLY : G ,GM1 ,EPSMIN, EPSUS, ZPI, ROWATER + USE YOWPHYS , ONLY : ZALP ,TAUWSHELTER, XKAPPA, BETAMAXOXKAPPA2, & + & RNU ,RNUM, & + & SWELLF ,SWELLF2 ,SWELLF3 ,SWELLF4 , SWELLF5, & + & SWELLF6 ,SWELLF7 ,SWELLF7M1, Z0RAT ,Z0TUBMAX , & + & ABMIN ,ABMAX, CDFAC, DTHRN_A ,DTHRN_U + USE YOWTEST , ONLY : IU06 + USE YOWTABL , ONLY : IAB ,SWELLFT + USE YOWSTAT , ONLY : IPHYS2_AIRSEA + + USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK + +! ---------------------------------------------------------------------- + + IMPLICIT NONE + +#include "airsea.intfb.h" +#include "femeanws.intfb.h" +#include "frcutindex.intfb.h" +#include "halphap.intfb.h" +#include "wsigstar.intfb.h" +#include "tau_wave_atmos.intfb.h" +#include "lfactor.intfb.h" +#include "irange.intfb.h" +#include "calcphiwa.intfb.h" + + +INTEGER(KIND=JWIM), INTENT(IN) :: ICALL !! CALL NUMBER. +INTEGER(KIND=JWIM), INTENT(IN) :: NCALL !! TOTAL NUMBER OF CALLS. +INTEGER(KIND=JWIM), INTENT(IN) :: KIJS, KIJL !! GRID POINT INDEXES. + +LOGICAL, INTENT(IN) :: LUPDTUS !! IF TRUE UFRIC AND Z0M WILL BE UPDATED (CALLING AIRSEA). + +REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(INOUT) :: FL1 !! WAVE SPECTRUM. +REAL(KIND=JWRB), DIMENSION(KIJL,NFRE), INTENT(IN) :: WAVNUM !! WAVE NUMBER. +REAL(KIND=JWRB), DIMENSION(KIJL,NFRE), INTENT(IN) :: CGROUP !! GROUP VELOCITY. +REAL(KIND=JWRB), DIMENSION(KIJL,NFRE), INTENT(IN) :: CINV !! INVERSE PHASE VELOCITY. +REAL(KIND=JWRB), DIMENSION(KIJL,NFRE), INTENT(IN) :: XK2CG !! (WAVNUM)**2 * GROUP SPPED. +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: WSWAVE !! WIND SPEED IN M/S. +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: WDWAVE !! WIND DIRECTION IN RADIANS IN OCEANOGRAPHIC NOTATION. +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: AIRD !! AIR DENSITY (KG/M**3). +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: RAORW !! RATIO AIR DENSITY TO WATER DENSITY. +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: WSTAR !! FREE CONVECTION VELOCITY SCALE (M/S) +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: CICOVER !! SEA ICE COVER. +REAL(KIND=JWRB), DIMENSION(KIJL, NANG), INTENT(IN) :: COSWDIF !! COS(TH(K)-WDWAVE(IJ)) +REAL(KIND=JWRB), DIMENSION(KIJL, NANG), INTENT(IN) :: SINWDIF2 !! SIN(TH(K)-WDWAVE(IJ))**2 +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: FMEAN !! MEAN FREQUENCY. +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: HALP !! 1/2 PHILLIPS PARAMETER +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(OUT) :: FMEANWS !! MEAN FREQUENCY OF THE WINDSEA. +REAL(KIND=JWRB), DIMENSION(KIJL,NANG), INTENT(IN) :: FLM !! SPECTAL DENSITY MINIMUM VALUE +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: UFRIC !! FRICTION VELOCITY IN M/S. +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: TAUW !! WAVE STRESS IN (M/S)**2 +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: TAUWDIR !! WAVE STRESS DIRECTION. +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: Z0M !! ROUGHNESS LENGTH IN M. +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: Z0B !! BACKGROUND ROUGHNESS LENGTH. +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: CHRNCK !! CHARNOCK COEFFICIENT. + +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(OUT) :: PHIWA !! ENERGY FLUX FROM WIND INTO WAVES. +REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(OUT) :: FLD !! DIAGONAL MATRIX OF FUNCTIONAL DERIVATIVE. +REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(OUT) :: SL !! TOTAL SOURCE FUNCTION ARRAY. +REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(OUT) :: SPOS !! POSITIVE SINPUT ONLY. + +INTEGER(KIND=JWIM), INTENT(OUT) :: MIJ(KIJL) !! LAST FREQUENCY INDEX OF THE PROGNOSTIC RANGE. + +REAL(KIND=JWRB), DIMENSION(KIJL,NFRE), INTENT(OUT) :: RHOWGDFTH !! WATER DENSITY * G * DF * DTHETA + +REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(OUT) :: XLLWS !! TOTAL WINDSEA MASK FROM INPUT SOURCE TERM. + +INTEGER(KIND=JWIM) :: IUSFG, ICODE_WND +INTEGER(KIND=JWIM), PARAMETER :: NGST=2 + +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE +REAL(KIND=JWRB), DIMENSION(KIJL) :: RNFAC + +LOGICAL :: LLFACT +INTEGER(KIND=JWIM) :: IJ, K, M, IND, IGST +INTEGER(KIND=JWIM) :: NSPEC !num. of freqs, dirs, spec. bins +INTEGER(KIND=JWIM), DIMENSION(NANG) :: ITHN +INTEGER(KIND=JWIM), DIMENSION(NFRE) :: IKN + +REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: CG2, ECOS2, ESIN2, DSII2 +REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: WN2, SIG2 +REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: SQRTBN2, CINV2, A +REAL(KIND=JWRB), DIMENSION(NFRE) :: DSII, SIG, CINV1, DF +REAL(KIND=JWRB), DIMENSION(NFRE) :: ADENSIG, KMAX, ANAR, SQRTBN +REAL(KIND=JWRB), DIMENSION(NANG,NFRE) :: KK +REAL(KIND=JWRB), DIMENSION(NANG,NFRE) :: SPOSDENSIG, SNEGDENSIG +REAL(KIND=JWRB), DIMENSION(NANG*NFRE,NGST) :: W1, W2, S, D +REAL(KIND=JWRB), DIMENSION(NFRE,NGST) :: LFACT +REAL(KIND=JWRB), DIMENSION(NANG,NFRE,NGST) :: SDENSIG, DINPOS, DINTOT + + +REAL(KIND=JWRB), PARAMETER :: SIN6A0 = 9.0E-2_JWRB ! ST6 PARAM +REAL(KIND=JWRB), DIMENSION(NGST) :: TAUWX, TAUWY ! Component of the wave-supported stress +REAL(KIND=JWRB), DIMENSION(NGST) :: TAUNWX, TAUNWY ! Component of the neg. wave-supported stress +REAL(KIND=JWRB) :: COSU, SINU +REAL(KIND=JWRB), DIMENSION(NGST) :: UPROXY + +REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: XK, CGG_WAM, CM +REAL(KIND=JWRB), DIMENSION(NFRE) :: SIGP2, SIGM1 + +! For USTAR, Z0, CHNK +REAL(KIND=JWRB), DIMENSION(KIJL,NGST) :: TAU +REAL(KIND=JWRB), PARAMETER :: ZRN=1.65E-6_JWRB ! effective kinematic viscosity (0.11*1.5e-5) +REAL(KIND=JWRB), PARAMETER :: RKAP = 0.4_JWRB +REAL(KIND=JWRB) :: ZNLEV, Z0, KUOUST, USTM1, USTM2 +REAL(KIND=JWRB), PARAMETER :: XEPS=0.00001_JWRB +REAL(KIND=JWRB), PARAMETER :: USTMIN=0.000001_JWRB +REAL(KIND=JWRB), PARAMETER :: PCHARMAX=0.1_JWRB +REAL(KIND=JWRB), PARAMETER :: Z0FG=0.01_JWRB +INTEGER(KIND=JWIM) :: ITER +REAL(KIND=JWRB) :: XZNLEV, PCHAROG, XKUTOP, XOLOGZ0 +REAL(KIND=JWRB) :: UST, USTOLD, Z0CH, Z0VIS, Z0TOT, FF, DELF +REAL(KIND=JWRB) :: CHARNOCK_MIN,CHNKMIN ! For Capping +INTEGER(KIND=JWIM), PARAMETER :: NITER=15 +REAL(KIND=JWRB), PARAMETER :: ALPHAMAX=0.1_JWRB +REAL(KIND=JWRB), PARAMETER :: AMAX=0.02_JWRB +REAL(KIND=JWRB), PARAMETER :: BMAX=0.01_JWRB +REAL(KIND=JWRB) :: ALPHAOGMAXU10 + +REAL(KIND=JWRB), DIMENSION(KIJL) :: ROAIRN, CHNKOG, TAUNW + +! For GUSTINESS +REAL(KIND=JWRB) :: AVG_GST +REAL(KIND=JWRB), DIMENSION(KIJL) :: SIG_N, SIG_U10, TAUWGST_AVG, TAUWDIRGST_AVG, TAUNWGST_AVG, USTARGST_AVG +REAL(KIND=JWRB), DIMENSION(KIJL,NGST) :: TAUWGST, TAUWDIRGST, TAUNWGST, UABSGST, USTARGST, Z0GST +REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE) :: SLGST_AVG, SPOSGST_AVG, FLGST_AVG +REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE,NGST) :: SLGST, SPOSGST, FLGST + +! For PHIWA calculation +! REAL(KIND=JWRB),DIMENSION(KIJL,NFRE) :: RHOWGDFTH +! REAL(KIND=JWRB), DIMENSION(KIJL) :: SUMT + + +! ---------------------------------------------------------------------- + +IF (LHOOK) CALL DR_HOOK('SINFLX',0,ZHOOK_HANDLE) + +! UPDATE UFRIC AND Z0M +IF (ICALL == 1 ) THEN + IUSFG = 0 + IF (LWCOU) THEN + ICODE_WND = ICODE_CPL + ELSE + ICODE_WND = ICODE + ENDIF +ELSE + IUSFG = 1 + ICODE_WND = 3 +ENDIF + +IF(LLNORMAGAM .AND. LLCAPCHNK ) THEN + RNFAC(KIJS:KIJL) = 1.0_JWRB+DTHRN_A*(1.0_JWRB+TANH(WSWAVE(KIJS:KIJL)-DTHRN_U)) +ELSE + RNFAC(KIJS:KIJL) = 1.0_JWRB +ENDIF + + +IF(LUPDTUS) THEN + ! increase noise level in the tail + IF (ICALL == 1 ) THEN + DO K=1,NANG + FL1(KIJS:KIJL,K,NFRE) = MAX(FL1(KIJS:KIJL,K,NFRE),FLM(KIJS:KIJL,K)) + ENDDO + + IF (LLGCBZ0) THEN + !$loki inline + CALL HALPHAP(KIJS, KIJL, WAVNUM, COSWDIF, FL1, HALP) + ELSE + HALP(KIJS:KIJL) = 0.0_JWRB + ENDIF + + ENDIF + + !$loki inline + CALL AIRSEA (KIJS, KIJL, & +& HALP, WSWAVE, WDWAVE, TAUW, TAUWDIR, RNFAC, & +& UFRIC, Z0M, Z0B, CHRNCK, ICODE_WND, IUSFG) + +ENDIF + + +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! input source term!!!! (start) + +NSPEC = NANG * NFRE ! NUMBER OF SPECTRAL BINS + +! Wind height +ZNLEV = 10._JWRB + +! COMPUTE FREQUENCY INTERVALLS (borrowed from Wam_others/f4spec.F) +DO M = 1,NFRE + DF(M) = FR(M)*( FRATIO - 1.0_JWRB ) +ENDDO + +DO M = 1,NFRE + SIG(M) = ZPI*FR(M) + DSII(M) = ZPI*DF(M) + SIGM1(M) = 1.0_JWRB/SIG(M) + SIGP2(M) = SIG(M)**2 +END DO + +! TODO: clean up stuff in/out of IJ loops (sdissip_zbry + swldissip ) +! TODO: confirm that I'm using exactly the same things here (I've now adopted them throughout the ZBRY code) +! - confirm CGG_WAM=CGROUP +! - confirm XK=WAVNUM + +DO M=1,NFRE + DO IJ=KIJS,KIJL + CM(IJ,M) = WAVNUM(IJ,M)*SIGM1(M) + ENDDO +ENDDO + + +ITHN = IRANGE(1,NANG,1) ! Index vector 1:NANG +DO M = 1, NFRE + ECOS2 (ITHN+(M-1)*NANG) = COSTH + ESIN2 (ITHN+(M-1)*NANG) = SINTH +END DO +! +IKN = IRANGE(1,NSPEC,NANG) ! Index vector for elements of 1 ... NFRE +! ! such that e.g. SIG(1:NFRE) = SIG2(IKN). + +DO K = 1, NANG ! Apply to all directions + DSII2 (IKN+(K-1)) = DSII + SIG2 (IKN+(K-1)) = SIG +END DO + +! ESTIMATE THE STANDARD DEVIATION OF GUSTINESS. +CALL WSIGSTAR (KIJS, KIJL, WSWAVE, UFRIC, Z0M, WSTAR, SIG_N, SIG_U10) +AVG_GST = 1.0_JWRB/NGST + +DO IJ=KIJS,KIJL + USTARGST(IJ,1)= UFRIC(IJ)*(1.0_JWRB+SIG_N(IJ)) + USTARGST(IJ,2)= UFRIC(IJ)*(1.0_JWRB-SIG_N(IJ)) + UABSGST(IJ,1)= WSWAVE(IJ)*(1.0_JWRB+SIG_U10(IJ)) + UABSGST(IJ,2)= WSWAVE(IJ)*(1.0_JWRB-SIG_U10(IJ)) + CHNKOG(IJ) = CHRNCK(IJ)*GM1 + ROAIRN(IJ) = RAORW(IJ)*ROWATER +END DO + +! Define Z0GST associated with USTARGST (as in airsea_zbry) +DO IGST=1,NGST + DO IJ=KIJS,KIJL + UST = USTARGST(IJ,IGST) + PCHAROG = MIN(CHNKOG(IJ),PCHARMAX/G) + Z0CH = PCHAROG*UST**2 + Z0VIS = ZRN/UST + Z0GST(IJ,IGST) = Z0CH+Z0VIS + ENDDO ! IJ loop ENDDO +ENDDO ! NGST loop ENDDO + +! Define UABSGST associated with USTARGST and Z0GST +! U10 = (u*/kappa) log (1 + Z/Z0), z=10 +! DO IGST=1,NGST +! DO IJ=KIJS,KIJL +! UABSGST(IJ,IGST) = USTARGST(IJ,IGST)*LOG(1.0_JWRB + ZNLEV/Z0GST(IJ,IGST))/XKAPPA +! END DO +! END DO + +!/ --- Main loop over LOC ----------------------------------- / + + +! LOOP OVER LOCATIONS +DO IJ = KIJS,KIJL + + DO K = 1, NANG ! Apply to all directions + WN2 (IKN+(K-1)) = WAVNUM(IJ,:) ! using WAM native WN,CG + CG2 (IKN+(K-1)) = CGROUP(IJ,:) + END DO + + CINV2 = WN2 / SIG2 ! inverse phase speed + +!/ 0) --- set up a basic variables ----------------------------------- / + + COSU = COS(WDWAVE(IJ)) + SINU = SIN(WDWAVE(IJ)) +! + DO IGST=1,NGST + TAUNWX(IGST) = 0.0_JWRB + TAUNWY(IGST) = 0.0_JWRB + TAUWX(IGST) = 0.0_JWRB + TAUWY(IGST) = 0.0_JWRB + TAU(IJ,IGST) = 0.0_JWRB + ENDDO + +! +!/ --- scale friction velocity to wind speed (10m) in +!/ the boundary layer ----------------------------------------- / +!/ Donelan et al. (2006) used U10 or U_{λ/2} in their S_{in} +!/ parameterization. To avoid some disadvantages of using U10 or +!/ U_{λ/2}, Rogers et al. (2012) used the following engineering +!/ conversion: +!/ UPROXY = SIN6WS * UST +!/ +!/ SIN6WS = FRIC = 28.0 following Komen et al. (1984) (developed seas) +!/ SIN6WS = 32.0 suggested by E. Rogers (2014) (young seas) +! + DO IGST=1,NGST + SELECT CASE (IPHYS2_AIRSEA) + CASE(0) + UPROXY(IGST) = 32.0_JWRB * CDFAC * USTARGST(IJ,IGST) ! original, suggested by E. Rogers (2014) (young seas) + CASE(1) + UPROXY(IGST) = FRIC * CDFAC * USTARGST(IJ,IGST) ! following Komen et al. (1984) (developed seas) (FRIC=28) + CASE(2) + UPROXY(IGST) = UABSGST(IJ,IGST) * CDFAC ! because FRIC=1/sqrt(CD), then this turns to purely a wind dependence (USTARGST cancels out) + END SELECT + ENDDO +! + ! To reshape from 1D to 2D: + ! K = RESHAPE( A , (/ NANG, NFRE /)) + ! To reshape from 2D to 1D: + ! A = RESHAPE( F(IJ,:,:) , (/NSPEC/) ) + A = RESHAPE( FL1(IJ,:,:) , (/NSPEC/)) * CG2 / ( ZPI * SIG2 )! ACTION DENSITY SPECTRUM +! +!/ 1) --- calculate 1d action density spectrum (A(sigma)) and +!/ zero-out values less than 1.0E-32 to avoid NaNs when +!/ computing directional narrowness in step 4). --------------- / + KK = RESHAPE(A,(/ NANG, NFRE /)) + + ADENSIG = SUM(KK,1) * SIG * DELTH ! Integrate over directions. +! +!/ 2) --- calculate normalised directional spectrum K(theta,sigma) --- / + KMAX = MAXVAL(KK,1) + DO M = 1,NFRE + IF (KMAX(M).LT.1.0E-34_JWRB) THEN + KK(1:NANG,M) = 1.0_JWRB + ELSE + KK(1:NANG,M) = KK(1:NANG,M)/KMAX(M) + END IF + END DO +! +!/ 3) --- calculate normalised spectral saturation BN(M) ------------ / + ANAR = 1.0_JWRB/( SUM(KK,1) * DELTH ) ! directional narrowness +! +! SQRTBN = SQRT( ANAR * ADENSIG * WN(IJ,:)**3 ) + SQRTBN = SQRT( ANAR * ADENSIG * WAVNUM(IJ,:)**3 ) + + DO K = 1, NANG + SQRTBN2(IKN+(K-1)) = SQRTBN ! Calculate SQRTBN for + END DO ! the entire spectrum. +! +!/ 4) --- calculate growth rate GAMMA and S for all directions for +!/ following winds (U10/c - 1 is positive; W1) and in 7) for +!/ adverse winds (U10/c -1 is negative, W2). W1 and W2 +!/ complement one another. ------------------------------------ / + DO IGST=1,NGST + W1(:,IGST)= MAX(0.0_JWRB, & + & UPROXY(IGST)*CINV2*(ECOS2*COSU + ESIN2*SINU) - 1.0_JWRB)**2 +! + D(:,IGST) = (RAORW(IJ) ) * SIG2 * & + (2.8_JWRB-(1.0_JWRB+TANH(10.0_JWRB*SQRTBN2*W1(:,IGST)-11.0_JWRB)))*& + & SQRTBN2*W1(:,IGST) +! + S(:,IGST) = D(:,IGST) * A + ENDDO +! +!/ 5) --- calculate reduction factor LFACT using non-directional +! spectral density of the wind input ------------------------- / + CINV1 = CINV2(IKN) + + DO IGST=1,NGST + SDENSIG(:,:,IGST) = RESHAPE(S(:,IGST)*SIG2/CG2,(/ NANG, NFRE /)) + + CALL LFACTOR(SDENSIG(:,:,IGST), CINV1, UABSGST(IJ,IGST), USTARGST(IJ,IGST), WDWAVE(IJ), & +& ROAIRN(IJ), SIG, DSII, LFACT(:,IGST), TAUWX(IGST), TAUWY(IGST), TAU(IJ,IGST)) + ENDDO + +! +!/ 6) --- apply reduction (LFACT) to the entire spectrum ------------- / + + LLFACT = .TRUE. + ! TODO: if this shows to make a big difference, then I can make this logical more rigorous + ! (and also implement it to save costs in LFACTOR) + IF (LLFACT) THEN + DO IGST=1,NGST + IF (SUM(LFACT(:,IGST)) .LT. NFRE) THEN + DO K = 1, NANG + D(IKN+K-1,IGST) = D(IKN+K-1,IGST) * LFACT(:,IGST) + END DO + S(:,IGST) = D(:,IGST) * A + END IF + DINPOS(:,:,IGST) = RESHAPE(D(:,IGST),(/ NANG, NFRE /)) + ENDDO + END IF + +! +!/ 7) --- compute negative wind input for adverse winds. negative +!/ growth is typically smaller by a factor of ~2.5 (=.28/.11) +!/ than those for the favourable winds [Donelan, 2006, Eq. (7)]. +!/ the factor is adjustable with NAMELIST parameter in +!/ ww3_grid.inp: '&SIN6 SINA0 = 0.04 /' ----------------------- / + DO IGST=1,NGST + IF (SIN6A0.GT.0.0_JWRB) THEN + W2(:,IGST) = MIN( 0.0_JWRB,UPROXY(IGST) * CINV2* & + & (ECOS2*COSU + ESIN2*SINU) - 1.0_JWRB )**2 + D(:,IGST) = D(:,IGST) - ( RAORW(IJ) * SIG2 * SIN6A0 * & + (2.8_JWRB-(1.0_JWRB+TANH(10.0_JWRB*SQRTBN2*W2(:,IGST) - 11.0_JWRB)))& + & *SQRTBN2*W2(:,IGST) ) + + DINTOT(:,:,IGST)= RESHAPE(D(:,IGST),(/NANG,NFRE/)) + S(:,IGST) = D(:,IGST) * A + +! ! --- compute negative component of the wave supported stresses +! ! from negative part of the wind input ---------------------- / + SDENSIG(:,:,IGST) = RESHAPE(S(:,IGST)*SIG2/CG2,(/ NANG, NFRE /)) + CALL TAU_WAVE_ATMOS(SDENSIG(:,:,IGST), CINV1, SIG, DSII, TAUNWX(IGST), TAUNWY(IGST) ) + ELSE + DINTOT(:,:,IGST)=DINPOS(:,:,IGST) + END IF + ENDDO +! + DO IGST=1,NGST + TAUWGST(IJ,IGST) = SQRT(TAUWX(IGST)**2+TAUWY(IGST)**2) / ROAIRN(IJ) ! KINEMATIC TAUW + TAUWDIRGST(IJ,IGST) = ATAN2(TAUWX(IGST),TAUWY(IGST)) + TAUNWGST(IJ,IGST) = SQRT(TAUNWX(IGST)**2+TAUNWY(IGST)**2) / ROAIRN(IJ) ! KINEMATIC TAUNW + USTARGST(IJ,IGST) = SQRT(TAU(IJ,IGST) / ROAIRN(IJ) ) + ENDDO + +! 8) --- Calculate SL, FL and SPOS needed for ecWAM ------------- / + + DO IGST=1,NGST + DO M = 1,NFRE + DO K = 1, NANG + SLGST(IJ,K,M,IGST) = DINTOT(K,M,IGST)*FL1(IJ,K,M) + SPOSGST(IJ,K,M,IGST) = DINPOS(K,M,IGST)*FL1(IJ,K,M) + END DO + END DO + FLGST(IJ,:,:,IGST) = DINTOT(:,:,IGST) + END DO + +! 9) --- Averaging over gust components ------------- / + IGST=1 + TAUWGST_AVG(IJ) = TAUWGST(IJ,IGST) + TAUWDIRGST_AVG(IJ) = TAUWDIRGST(IJ,IGST) + TAUNWGST_AVG(IJ) = TAUNWGST(IJ,IGST) + USTARGST_AVG(IJ) = USTARGST(IJ,IGST) + SLGST_AVG(IJ,:,:) = SLGST(IJ,:,:,IGST) + SPOSGST_AVG(IJ,:,:) = SPOSGST(IJ,:,:,IGST) + FLGST_AVG(IJ,:,:) = FLGST(IJ,:,:,IGST) + DO IGST=2,NGST + TAUWGST_AVG(IJ) = TAUWGST_AVG(IJ) + TAUWGST(IJ,IGST) + TAUWDIRGST_AVG(IJ) = TAUWDIRGST_AVG(IJ) + TAUWDIRGST(IJ,IGST) + TAUNWGST_AVG(IJ) = TAUNWGST_AVG(IJ) + TAUNWGST(IJ,IGST) + USTARGST_AVG(IJ) = USTARGST_AVG(IJ) + USTARGST(IJ,IGST) + SLGST_AVG(IJ,:,:) = SLGST_AVG(IJ,:,:) + SLGST(IJ,:,:,IGST) + SPOSGST_AVG(IJ,:,:) = SPOSGST_AVG(IJ,:,:) + SPOSGST(IJ,:,:,IGST) + FLGST_AVG(IJ,:,:) = FLGST_AVG(IJ,:,:) + FLGST(IJ,:,:,IGST) + ENDDO + TAUW(IJ) = AVG_GST*TAUWGST_AVG(IJ) + TAUWDIR(IJ) = AVG_GST*TAUWDIRGST_AVG(IJ) + TAUNW(IJ) = AVG_GST*TAUNWGST_AVG(IJ) + UFRIC(IJ) = AVG_GST*USTARGST_AVG(IJ) + SL(IJ,:,:) = AVG_GST*SLGST_AVG(IJ,:,:) + SPOS(IJ,:,:) = AVG_GST*SPOSGST_AVG(IJ,:,:) + FLD(IJ,:,:) = AVG_GST*FLGST_AVG(IJ,:,:) + +! 10) --- Calculate roughness length and charnock ------------- / + + USTM1 = 1.0_JWRB/MAX(UFRIC(IJ),EPSUS) ! Protect the code + USTM2 = 1.0_JWRB/MAX(UFRIC(IJ)**2,EPSUS) ! Protect the code + KUOUST = MIN(50._JWRB,XKAPPA*WSWAVE(IJ)*USTM1) ! Protect the code + Z0 = ZNLEV / ( EXP(KUOUST) - 1.0_JWRB ) + Z0 = MAX(Z0, 0.0000001_JWRB) + Z0M(IJ) = Z0 ! Update z0 + CHNKOG(IJ) = ( Z0 - ZRN*USTM1 ) * USTM2 ! Update charnock (where Z0=Z0CH+Z0VIS from airsea_zbry) + ALPHAOGMAXU10 = MIN(ALPHAMAX,AMAX+BMAX*WSWAVE(IJ))*GM1 ! protective code taken from outbeta (incl /G) + CHNKOG(IJ) = MIN(CHNKOG(IJ),ALPHAOGMAXU10) ! protective code taken from outbeta (incl /G) + + IF(LLCAPCHNK) THEN + CHARNOCK_MIN = CHNKMIN(WSWAVE(IJ)) + CHNKOG(IJ) = MAX(CHARNOCK_MIN*GM1,CHNKOG(IJ)) + ELSE + CHNKOG(IJ) = MAX(CHNKOG(IJ), 1E-5_JWRB) + ENDIF + + CHRNCK(IJ) = CHNKOG(IJ)*G + +! 11) --- PHIWA calculation using non-directional +! spectral density of the wind input ---------------------- / + + SPOSDENSIG = SPOS(IJ,:,:) + SNEGDENSIG = SL(IJ,:,:) - SPOS(IJ,:,:) + PHIWA(IJ) = CALCPHIWA(SPOSDENSIG,SNEGDENSIG,DSII) ! TODO: add the HiFreq contribution + +END DO +! END LOOP OVER LOC +! --------------------- + +! XLLWS based on SL (mask for neg. input) +DO IJ=KIJS,KIJL + DO M = 1,NFRE + DO K = 1, NANG + IF (SL(IJ,K,M)>0.0_JWRB) THEN + XLLWS(IJ,K,M)=1.0_JWRB + ELSE + XLLWS(IJ,K,M)=0.0_JWRB + END IF + END DO + END DO +END DO +! --------------------- + +! input source term!!!! (end) +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- + +! MEAN FREQUENCY CHARACTERISTIC FOR WIND SEA +!$loki inline +CALL FEMEANWS(KIJS, KIJL, FL1, XLLWS, FMEANWS) + +! COMPUTE LAST FREQUENCY INDEX OF PROGNOSTIC PART OF SPECTRUM. +!$loki inline +CALL FRCUTINDEX(KIJS, KIJL, FMEAN, FMEANWS, UFRIC, CICOVER, MIJ, RHOWGDFTH) + +! ---------------------------------------------------------------------- + +IF (LHOOK) CALL DR_HOOK('SINFLX',1,ZHOOK_HANDLE) + +END SUBROUTINE SINFLX_ZBRY diff --git a/src/ecwam/swldissip_zbry.F90 b/src/ecwam/swldissip_zbry.F90 new file mode 100644 index 000000000..39d39c929 --- /dev/null +++ b/src/ecwam/swldissip_zbry.F90 @@ -0,0 +1,228 @@ +! (C) Copyright 1989- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! + + SUBROUTINE SWLDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & + & WAVNUM, CGROUP, XK2CG, & + & UFRIC, COSWDIF, RAORW) +! ---------------------------------------------------------------------- + +!**** *SWLDISSIP_ZBRY* - COMPUTATION OF DISSIPATION SOURCE FUNCTION. + +! LOTFI AOUF METEO FRANCE 2013 +! FABRICE ARDHUIN IFREMER 2013 + + +!* PURPOSE. +! -------- +! Turbulent dissipation of narrow-banded swell as described in +! Babanin (2011, Section 7.5). +! +!** INTERFACE. +! ---------- + +! *CALL* *SWLDISSIP_ZBRY (KIJS, KIJL, FL1, FLD,SL,* +! WAVNUM, CGROUP, XK2CG, +! UFRIC, COSWDIF, RAORW)* +! *KIJS* - INDEX OF FIRST GRIDPOINT +! *KIJL* - INDEX OF LAST GRIDPOINT +! *FL1* - SPECTRUM. +! *FLD* - DIAGONAL MATRIX OF FUNCTIONAL DERIVATIVE +! *SL* - TOTAL SOURCE FUNCTION ARRAY +! *WAVNUM* - WAVE NUMBER +! *CGROUP* - GROUP SPEED +! *XK2CG* - (WAVE NUMBER)**2 * GROUP SPEED +! *UFRIC* - FRICTION VELOCITY IN M/S. +! *RAORW* - RATIO AIR DENSITY TO WATER DENSITY +! *COSWDIF*- COS(TH(K)-WDWAVE(IJ)) + + +! METHOD. +! ------- + +! SEE REFERENCES. + +! EXTERNALS. +! ---------- + +! IRANGE + +! REFERENCE. +! ---------- + +! Babanin 2011: Cambridge Press, 295-321, 463pp. + +! ORIGIN. +! ---------- +! Adapted from Babanin Young Donelan & Banner (ZBRY) physics +! as implemented as ST6 in WAVEWATCH-III +! WW3 module: W3SWLDMD +! WW3 subroutine: W3SWL6 +! Implementation into ECWAM DECEMBER 2021 by J. Kousal + + +! ---------------------------------------------------------------------- + USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU + + USE YOWFRED , ONLY : FR , TH ,ZPIFR ,FRATIO ,DELTH, DFIM + USE YOWPCONS , ONLY : G ,ZPI + USE YOWPARAM , ONLY : NANG ,NFRE + USE YOWPHYS , ONLY : SDSBR ,ISDSDTH ,ISB ,IPSAT , & +& SSDSC2 , SSDSC4, SSDSC6, MICHE, SSDSC3, SSDSBRF1, & +& BRKPBCOEF ,SSDSC5, NSDSNTH, & +& INDICESSAT, SATWEIGHTS + + USE YOMHOOK , ONLY : LHOOK ,DR_HOOK, JPHOOK + +! ---------------------------------------------------------------------- + + IMPLICIT NONE +#include "irange.intfb.h" + + INTEGER(KIND=JWIM), INTENT(IN) :: KIJS, KIJL + + REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(IN) :: FL1 + REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(INOUT) :: FLD, SL + REAL(KIND=JWRB), DIMENSION(KIJL,NFRE), INTENT(IN) :: WAVNUM, CGROUP, XK2CG + REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: UFRIC, RAORW + REAL(KIND=JWRB), DIMENSION(KIJL, NANG), INTENT(IN) :: COSWDIF + + INTEGER(KIND=JWIM) :: IJ, M, I, J, M2, K2, K, NANGD + INTEGER(KIND=JWIM) :: NSPEC !num. of freqs, dirs, spec. bins + INTEGER(KIND=JWIM), DIMENSION(NANG) :: KKD + INTEGER(KIND=JWIM), DIMENSION(NANG) :: ITHN + INTEGER(KIND=JWIM), DIMENSION(NFRE) :: IKN + + REAL(KIND=JWRB), PARAMETER :: SWL6B1 = 0.0041_JWRB ! ST6 PARAM + LOGICAL, PARAMETER :: SWL6CSTB1 = .FALSE. ! ST6 PARAM + + REAL(KIND=JWRB), DIMENSION(NFRE) :: ABAND, KMAX, ANAR, BN, AORB, DDIS + REAL(KIND=JWRB), DIMENSION(NFRE) :: SIG, DDEN + REAL(KIND=JWRB), DIMENSION(NANG,NFRE) :: KK + REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: S, D, A + REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: SIG2, CG2 + REAL(KIND=JWRB) :: B1 + REAL(KIND=JWRB), DIMENSION(NANG,NFRE) :: DSWL + + REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: XK, CGG_WAM + REAL(KIND=JWRB), DIMENSION(NFRE) :: SIGP2 + REAL(KIND=JWRB), DIMENSION(NFRE) :: DF ! FREQUENCY INTERVALS + + REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ---------------------------------------------------------------------- + + IF (LHOOK) CALL DR_HOOK('SWLDISSIP_ZBRY',0,ZHOOK_HANDLE) + + NSPEC = NANG * NFRE ! NUMBER OF SPECTRAL BINS + + DO M = 1,NFRE + SIG(M) = ZPI*FR(M) + SIGP2(M) = SIG(M)**2 + DDEN(M) = ZPI*DFIM(M)*SIG(M) + END DO + +! COMPUTE FREQUENCY INTERVALLS (borrowed from Wam_others/f4spec.F) + DO M = 1,NFRE + DF(M) = FR(M)*( FRATIO - 1.0_JWRB ) + ENDDO + + IKN = IRANGE(1,NSPEC,NANG) ! Index vector for elements of 1 ... NFRE +! ! such that e.g. SIG(1:NFRE) = SIG2(IKN). + DO K = 1, NANG ! Apply to all directions + SIG2 (IKN+(K-1)) = SIG + END DO + + + ! LOOP OVER LOCATIONS + DO IJ = KIJS,KIJL + + DO K = 1, NANG ! Apply to all directions + CG2 (IKN+(K-1)) = CGROUP(IJ,:) + END DO + + A = RESHAPE( FL1(IJ,:,:) , (/NSPEC/)) * CG2 / ( ZPI * SIG2 )! ACTION DENSITY SPECTRUM + ! WAM E(f,theta) to WW3 A(k,theta) conversion factor: CG2 / ( ZPI *SIG2 ) + +!/ 0) --- Initialize parameters -------------------------------------- / + IKN = IRANGE(1,NSPEC,NANG) ! Index vector for array access, e.g. + ! in form of WN(1:NFRE) == WN2(IKN). + ABAND = SUM(RESHAPE(A,(/ NANG,NFRE /)),1) ! action density as function of wavenumber + DDIS = 0.0_JWRB + D = 0.0_JWRB + B1 = SWL6B1 ! empirical constant from NAMELIST + +!/ 1) --- Choose calculation of steepness a*k ------------------------ / +!/ Replace the measure of steepness with the spectral +! saturation after Banner et al. (2002) ---------------------- / + KK = RESHAPE(A,(/ NANG,NFRE /)) + KMAX = MAXVAL(KK,1) + DO M = 1,NFRE + IF (KMAX(M).LT.1.0E-34_JWRB) THEN + KK(1:NANG,M) = 1.0_JWRB + ELSE + KK(1:NANG,M) = KK(1:NANG,M)/KMAX(M) + END IF + END DO + ANAR = 1.0_JWRB/( SUM(KK,1) * DELTH ) +! BN = ANAR * ( ABAND * SIG * DELTH ) * WN(IJ,:)**3 + BN = ANAR * ( ABAND * SIG * DELTH ) * WAVNUM(IJ,:)**3 + +! + IF (.NOT.SWL6CSTB1) THEN +! +!/ --- A constant value for B1 attenuates swell too strong in the +!/ western central Pacific (i.e. cross swell less than 1.0m). +!/ Workaround is to scale B1 with steepness a*kp, where kp is +!/ the peak wavenumber. SWL6B1 remains a scaling constant, but +!/ with different magnitude. --------------------------------- / + M = MAXLOC(ABAND,1) ! Index for peak +! EMEAN = SUM(ABAND * DDEN / CG) ! Total sea surface variance +! B1 = SWL6B1*(2.0_JWRB*SQRT(SUM(ABAND*DDEN/CGG(IJ,:)))*& +! & WN(IJ,M)) + B1 = SWL6B1*(2.0_JWRB*SQRT(SUM(ABAND*DDEN/CGROUP(IJ,:)))*& + & WAVNUM(IJ,M)) + +! + END IF +! +!/ 2) --- Calculate the derivative term only (in units of 1/s) ------- / + DO M = 1,NFRE + IF (ABAND(M) .GT. 1.0E-30_JWRB) THEN + DDIS(M) = -(2.0_JWRB/3.0_JWRB) * B1 * SIG(M) * SQRT(BN(M)) + END IF + END DO +! +!/ 3) --- Apply dissipation term of derivative to all directions ----- / + DO K = 1, NANG + D(IKN+(K-1)) = DDIS + END DO +! + !S = D * A +! +! WRITE(*,*) ' B1 =',B1 +! WRITE(*,*) ' DDIS_tot =',SUM(DDIS*ABAND*DDEN/CG) +! WRITE(*,*) ' EDENS_tot=',sum(aband*dden/cg) +! WRITE(*,*) ' EDENS_tot=',sum(aband*sig*dth*dsii/cg) +! WRITE(*,*) ' ' +! WRITE(*,*) ' SWL6_tot =',sum(SUM(RESHAPE(S,(/ NANG,NFRE /)),1)*DDEN/CG) + + DSWL = RESHAPE(D,(/NANG,NFRE/)) + DO M = 1,NFRE + DO K = 1, NANG + SL(IJ,K,M) = SL(IJ,K,M) + DSWL(K,M)*FL1(IJ,K,M) + FLD(IJ,K,M) = FLD(IJ,K,M) + DSWL(K,M) + END DO + END DO + + END DO + ! END LOOP OVER LOC + + IF (LHOOK) CALL DR_HOOK('SWLDISSIP_ZBRY',1,ZHOOK_HANDLE) + + END SUBROUTINE SWLDISSIP_ZBRY diff --git a/src/ecwam/tau_wave_atmos.F90 b/src/ecwam/tau_wave_atmos.F90 index bc67a85af..be2fc38f7 100644 --- a/src/ecwam/tau_wave_atmos.F90 +++ b/src/ecwam/tau_wave_atmos.F90 @@ -45,7 +45,7 @@ SUBROUTINE TAU_WAVE_ATMOS(S, CINV, SIG, DSII, TAUNWX, TAUNWY ) ! ORIGIN. ! ---------- -! Adapted from Babanin Young Donelan & Banner (BYDB) physics +! Adapted from Babanin Young Donelan & Banner (ZBRY) physics ! as implemented as ST6 in WAVEWATCH-III ! WW3 module: W3SRC6MD ! WW3 subroutine: TAU_WAVE_ATMOS diff --git a/src/ecwam/tauwinds.F90 b/src/ecwam/tauwinds.F90 index 67db2621a..f5c53428e 100644 --- a/src/ecwam/tauwinds.F90 +++ b/src/ecwam/tauwinds.F90 @@ -26,7 +26,7 @@ FUNCTION TAUWINDS(SDENSIG,CINV,DSII) RESULT(TAU_WINDS) ! ORIGIN. ! ---------- -! Adapted from Babanin Young Donelan & Banner (BYDB) physics +! Adapted from Babanin Young Donelan & Banner (ZBRY) physics ! as implemented as ST6 in WAVEWATCH-III ! WW3 module: W3SRC6MD ! WW3 subroutine: TAUWINDS diff --git a/src/ecwam/yowphys.F90 b/src/ecwam/yowphys.F90 index 1c7a9e0de..6e25332d4 100644 --- a/src/ecwam/yowphys.F90 +++ b/src/ecwam/yowphys.F90 @@ -33,7 +33,7 @@ MODULE YOWPHYS ! *BETAMAX* PARAMETER FOR WIND INPUT. REAL(KIND=JWRB) :: BETAMAX -! *CDFAC* PARAMETER FOR WIND INPUT FOR BYDBR PHYS. +! *CDFAC* PARAMETER FOR WIND INPUT FOR ZBRY PHYS. REAL(KIND=JWRB) :: CDFAC ! *BETAMAXOXKAPPA2* BETAMAX/XKAPPA**2 From 6cbecd74944f7f771b7c48e5badf1ddd34592329 Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Tue, 14 Oct 2025 10:03:08 +0000 Subject: [PATCH 16/89] renaming bydbr to zbry --- src/ecwam/CMakeLists.txt | 8 +- src/ecwam/frcutindex_bydb.F90 | 119 ------- src/ecwam/sdissip_bydbr.F90 | 249 -------------- src/ecwam/sinflx_bydbr.F90 | 627 ---------------------------------- src/ecwam/swldissip_bydbr.F90 | 228 ------------- 5 files changed, 4 insertions(+), 1227 deletions(-) delete mode 100644 src/ecwam/frcutindex_bydb.F90 delete mode 100644 src/ecwam/sdissip_bydbr.F90 delete mode 100644 src/ecwam/sinflx_bydbr.F90 delete mode 100644 src/ecwam/swldissip_bydbr.F90 diff --git a/src/ecwam/CMakeLists.txt b/src/ecwam/CMakeLists.txt index 76a9f92c4..3582a0c48 100644 --- a/src/ecwam/CMakeLists.txt +++ b/src/ecwam/CMakeLists.txt @@ -83,7 +83,7 @@ list( APPEND ecwam_srcs fndprt.F90 frcutindex.F90 frcutindex_default.F90 - frcutindex_bydb.F90 + frcutindex_zbry.F90 gc_dispersion.h get_preset_wgrib_template.F90 getbobstrct.F90 @@ -224,7 +224,7 @@ list( APPEND ecwam_srcs sdissip.F90 sdissip_ard.F90 sdissip_jan.F90 - sdissip_bydbr.F90 + sdissip_zbry.F90 sdiwbk.F90 sdice.F90 sdice1.F90 @@ -246,7 +246,7 @@ list( APPEND ecwam_srcs setmarstype.F90 setwavphys.F90 sinflx.F90 - sinflx_bydbr.F90 + sinflx_zbry.F90 sinflx_ard_jan.F90 sinput.F90 sinput_ard.F90 @@ -262,7 +262,7 @@ list( APPEND ecwam_srcs stress_gc.F90 stresso.F90 strspec.F90 - swldissip_bydbr.F90 + swldissip_zbry.F90 tables_2nd.F90 tabu_swellft.F90 tau_phi_hf.F90 diff --git a/src/ecwam/frcutindex_bydb.F90 b/src/ecwam/frcutindex_bydb.F90 deleted file mode 100644 index 3b4a55248..000000000 --- a/src/ecwam/frcutindex_bydb.F90 +++ /dev/null @@ -1,119 +0,0 @@ - SUBROUTINE FRCUTINDEX_BYDB (KIJS, KIJL, FM, UFRIC, CICOVER, & - & MIJ) - -! ---------------------------------------------------------------------- - -!**** *FRCUTINDEX_BYDB* - RETURNS THE LAST FREQUENCY INDEX OF -! PROGNOSTIC PART OF SPECTRUM. - -!** INTERFACE. -! ---------- - -! *CALL* *FRCUTINDEX_BYDB (KIJS, KIJL, FM, UFRIC, CICOVER,MIJ) -! *KIJS* - INDEX OF FIRST GRIDPOINT -! *KIJL* - INDEX OF LAST GRIDPOINT -! *FM* - MEAN FREQUENCY -! *UFRIC* - FRICTION VELOCITY IN M/S -! *CICOVER*- CICOVER -! *MIJ* - LAST FREQUENCY INDEX for imposing high frequency tail - - - -! METHOD. -! ------- - -!* COMPUTES LAST FREQUENCY INDEX OF PROGNOSTIC PART OF SPECTRUM -! ACCORDING TO BYDB - -! EXTERNALS. -! --------- - -! REFERENCE. -! ---------- - -! ORIGIN. -! ---------- -! Adapted from Babanin Young Donelan & Banner (BYDB) physics -! as implemented as ST6 in WAVEWATCH-III -! WW3 module: W3SRCEMD -! WW3 subroutine: -! Implementation into ECWAM DECEMBER 2021 by J. Kousal - -! ---------------------------------------------------------------------- - - USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU - - USE YOWPHYS , ONLY : TAILFACTOR, TAILFACTOR_PM - USE YOWFRED , ONLY : FR ,DFIM ,FRATIO ,FLOGSPRDM1, & - & DELTH ,RHOWG_DFIM ,FRIC - USE YOWICE , ONLY : CITHRSH_TAIL - USE YOWPARAM , ONLY : NANG ,NFRE - USE YOWPCONS , ONLY : G ,ZPI ,EPSMIN, EPSUS - USE YOMHOOK , ONLY : LHOOK, DR_HOOK - -! ---------------------------------------------------------------------- - - IMPLICIT NONE - - INTEGER(KIND=JWIM), INTENT(IN) :: KIJS, KIJL - INTEGER(KIND=JWIM), INTENT(OUT) :: MIJ(KIJL) - - REAL(KIND=JWRB),DIMENSION(KIJL), INTENT(IN) :: FM, UFRIC, CICOVER - - REAL(KIND=JWRB) :: ZHOOK_HANDLE - - INTEGER(KIND=JWIM) :: IJ, NK, NKH, NKH1, M - REAL(KIND=JWRB), PARAMETER :: SIN6FC = 6.0_JWRB - REAL(KIND=JWRB) :: FXFM, FXPM, FACTI1, FACTI2 ! constants - REAL(KIND=JWRB) :: FHIGH ! Cut-off frequency in integration (rad/s) - REAL(KIND=JWRB) :: SIGNK ! LAST FREQUENCY [RAD] - REAL(KIND=JWRB) :: USTM1 - - -! ---------------------------------------------------------------------- - - IF (LHOOK) CALL DR_HOOK('FRCUTINDEX_BYDB',0,ZHOOK_HANDLE) - - NK = NFRE - FXFM = SIN6FC - FXFM = FXFM * ZPI - FXPM = 4.0_JWRB !TODO: 4.0_JWRB is the factor for the tail (is this right) - FXPM = FXPM * G / 28.0_JWRB !TODO: should this be FRIC? - SIGNK = ZPI*FR(NFRE) - - DO IJ=KIJS,KIJL - IF (CICOVER(IJ) <= CITHRSH_TAIL) THEN - - USTM1 = 1.0_JWRB/MAX(UFRIC(IJ),EPSUS) ! Protect the code - - IF (FXFM .LE. 0) THEN - FHIGH = SIGNK ! LAST FREQ i.e. let tail evolve freely - ELSE - FHIGH = MAX (FXFM * FM(IJ), FXPM * USTM1 ) - ENDIF - - - FACTI1 = 1.0_JWRB / LOG(FRATIO) - FACTI2 = 1.0_JWRB - LOG(ZPI*FR(1)) * FACTI1 - - NKH = MIN ( NK , INT(FACTI2+FACTI1*LOG(MAX(1.0E-7_JWRB,FHIGH))) ) - NKH1 = MIN ( NK , NKH+1 ) - - - IF (FXFM .LE. 0) THEN - FHIGH = SIGNK - ELSE - FHIGH = MIN ( SIGNK, MAX(FXFM * FM(IJ), FXPM * USTM1) ) - ENDIF - NKH = MAX ( 2 , MIN ( NKH1 , & - INT ( FACTI2 + FACTI1*LOG(MAX(1.0E-7_JWRB,FHIGH)) ) ) ) - - MIJ(IJ) = NKH - ELSE - MIJ(IJ) = NFRE - ENDIF - END DO - - IF (LHOOK) CALL DR_HOOK('FRCUTINDEX_BYDB',1,ZHOOK_HANDLE) - - END SUBROUTINE FRCUTINDEX_BYDB diff --git a/src/ecwam/sdissip_bydbr.F90 b/src/ecwam/sdissip_bydbr.F90 deleted file mode 100644 index c5661b1b3..000000000 --- a/src/ecwam/sdissip_bydbr.F90 +++ /dev/null @@ -1,249 +0,0 @@ -! (C) Copyright 1989- ECMWF. -! -! This software is licensed under the terms of the Apache Licence Version 2.0 -! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. -! In applying this licence, ECMWF does not waive the privileges and immunities -! granted to it by virtue of its status as an intergovernmental organisation -! nor does it submit to any jurisdiction. -! - - SUBROUTINE SDISSIP_BYDBR (KIJS, KIJL, FL1, FLD, SL, & - & WAVNUM, CGROUP, XK2CG, & - & UFRIC, COSWDIF, RAORW) -! ---------------------------------------------------------------------- - -!**** *SDISSIP_BYDBR* - COMPUTATION OF DISSIPATION SOURCE FUNCTION. - -! LOTFI AOUF METEO FRANCE 2013 -! FABRICE ARDHUIN IFREMER 2013 - - -!* PURPOSE. -! -------- -! Observation-based source term for dissipation after Babanin et al. -! (2010) following the implementation by Rogers et al. (2012). The -! dissipation function Sds accommodates an inherent breaking term T1 -! and an additional cumulative term T2 at all frequencies above the -! peak. The forced dissipation term T2 is an integral that grows -! toward higher frequencies and dominates at smaller scales -! (Babanin et al. 2010). -! -!** INTERFACE. -! ---------- - -! *CALL* *SDISSIP_BYDBR (KIJS, KIJL, FL1, FLD,SL,* -! WAVNUM, CGROUP, XK2CG, -! UFRIC, COSWDIF, RAORW)* -! *KIJS* - INDEX OF FIRST GRIDPOINT -! *KIJL* - INDEX OF LAST GRIDPOINT -! *FL1* - SPECTRUM. -! *FLD* - DIAGONAL MATRIX OF FUNCTIONAL DERIVATIVE -! *SL* - TOTAL SOURCE FUNCTION ARRAY -! *WAVNUM* - WAVE NUMBER -! *CGROUP* - GROUP SPEED -! *XK2CG* - (WAVE NUMBER)**2 * GROUP SPEED -! *UFRIC* - FRICTION VELOCITY IN M/S. -! *RAORW* - RATIO AIR DENSITY TO WATER DENSITY -! *COSWDIF*- COS(TH(K)-WDWAVE(IJ)) - - -! METHOD. -! ------- - -! SEE REFERENCES. - -! EXTERNALS. -! ---------- - -! IRANGE - -! REFERENCE. -! ---------- - -! Babanin et al. 2010: JPO 40(4), 667-683 -! Rogers et al. 2012: JTECH 29(9) 1329-1346 - -! ORIGIN. -! ---------- -! Adapted from Babanin Young Donelan & Banner (BYDB) physics -! as implemented as ST6 in WAVEWATCH-III -! WW3 module: W3SRC6MD -! WW3 subroutine: W3SDS6 -! Implementation into ECWAM DECEMBER 2021 by J. Kousal - - -! ---------------------------------------------------------------------- - USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU - - USE YOWFRED , ONLY : FR , TH ,ZPIFR ,FRATIO ,DELTH, DFIM - USE YOWPCONS , ONLY : G ,ZPI - USE YOWPARAM , ONLY : NANG ,NFRE - USE YOWPHYS , ONLY : SDSBR ,ISDSDTH ,ISB ,IPSAT , & -& SSDSC2 , SSDSC4, SSDSC6, MICHE, SSDSC3, SSDSBRF1, & -& BRKPBCOEF ,SSDSC5, NSDSNTH, & -& INDICESSAT, SATWEIGHTS - - USE YOMHOOK , ONLY : LHOOK ,DR_HOOK, JPHOOK - -! ---------------------------------------------------------------------- - - IMPLICIT NONE -#include "irange.intfb.h" - - INTEGER(KIND=JWIM), INTENT(IN) :: KIJS, KIJL - - REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(IN) :: FL1 - REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(INOUT) :: FLD, SL - REAL(KIND=JWRB), DIMENSION(KIJL,NFRE), INTENT(IN) :: WAVNUM, CGROUP, XK2CG - REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: UFRIC, RAORW - REAL(KIND=JWRB), DIMENSION(KIJL, NANG), INTENT(IN) :: COSWDIF - - INTEGER(KIND=JWIM) :: IJ, K, M, I, J, M2, K2, NANGD - INTEGER(KIND=JWIM) :: NSPEC !num. of freqs, dirs, spec. bins - INTEGER(KIND=JWIM), DIMENSION(NANG) :: ITHN - INTEGER(KIND=JWIM), DIMENSION(NFRE) :: IKN - - REAL(KIND=JWRB), PARAMETER :: SDS6A1 = 4.75E-6_JWRB ! ST6 PARAM - REAL(KIND=JWRB), PARAMETER :: SDS6A2 = 7.00E-5_JWRB ! ST6 PARAM - INTEGER(KIND=JWIM), PARAMETER :: SDS6P1 = 4 ! ST6 PARAM - INTEGER(KIND=JWIM), PARAMETER :: SDS6P2 = 4 ! ST6 PARAM - LOGICAL, PARAMETER :: SDS6ET = .TRUE. ! ST6 PARAM - - REAL(KIND=JWRB), DIMENSION(NFRE) :: FREQ ! frequencies [Hz] - REAL(KIND=JWRB), DIMENSION(NFRE) :: SIG ! frequencies [RAD] - REAL(KIND=JWRB), DIMENSION(NFRE) :: DFII ! frequency bandwiths [Hz] - REAL(KIND=JWRB), DIMENSION(NFRE) :: ANAR ! directional narrowness - REAL(KIND=JWRB), DIMENSION(NFRE) :: EDENS ! spectral density E(f) - REAL(KIND=JWRB), DIMENSION(NFRE) :: ETDENS ! threshold spec. density ET(f) - REAL(KIND=JWRB), DIMENSION(NFRE) :: EXDENS ! excess spectral density EX(f) - REAL(KIND=JWRB), DIMENSION(NFRE) :: NEXDENS! normalised excess spec.dens. - REAL(KIND=JWRB), DIMENSION(NFRE) :: T1 ! inherent breaking term - REAL(KIND=JWRB), DIMENSION(NFRE) :: T2 ! forced dissipation term - REAL(KIND=JWRB), DIMENSION(NFRE) :: T12 ! =T1+T2 or combined dissipation - REAL(KIND=JWRB), DIMENSION(NFRE) :: ADF ! temporary variable - REAL(KIND=JWRB), DIMENSION(NFRE) :: DF ! FREQUENCY INTERVALS - REAL(KIND=JWRB) :: BNT ! empirical constant for wave breaking probability - REAL(KIND=JWRB) :: XFAC, EDENSMAX ! temporary variableis - - REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: S, D, A - REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: SIG2, CG2 - REAL(KIND=JWRB), DIMENSION(NANG,NFRE) :: DDS - - - REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: XK, CGG_WAM - REAL(KIND=JWRB), DIMENSION(NFRE) :: SIGP2 - - - REAL(KIND=JPHOOK) :: ZHOOK_HANDLE - -! ---------------------------------------------------------------------- - - IF (LHOOK) CALL DR_HOOK('SDISSIP_BYDBR',0,ZHOOK_HANDLE) - - NSPEC = NANG * NFRE ! NUMBER OF SPECTRAL BINS - - DO M = 1,NFRE - SIG(M) = ZPI*FR(M) - SIGP2(M) = SIG(M)**2 - END DO - -! COMPUTE FREQUENCY INTERVALLS (borrowed from Wam_others/f4spec.F) - DO M = 1,NFRE - DF(M) = FR(M)*( FRATIO - 1.0_JWRB ) - ENDDO - - IKN = IRANGE(1,NSPEC,NANG) ! Index vector for elements of 1 ... NFRE -! ! such that e.g. SIG(1:NFRE) = SIG2(IKN). - DO K = 1, NANG ! Apply to all directions - SIG2 (IKN+(K-1)) = SIG - END DO - - - ! LOOP OVER LOCATIONS - DO IJ = KIJS,KIJL - - DO K = 1, NANG ! Apply to all directions - CG2 (IKN+(K-1)) = CGROUP(IJ,:) - END DO - - A = RESHAPE( FL1(IJ,:,:) , (/NSPEC/)) * CG2 / ( ZPI * SIG2 )! ACTION DENSITY SPECTRUM - ! WAM E(f,theta) to WW3 A(k,theta) conversion factor: CG2 / ( ZPI *SIG2 ) - -!/ 0) --- Initialize essential parameters ---------------------------- / - IKN = IRANGE(1,NSPEC,NANG) ! Index vector for elements of 1, -! ! 2,..., NFRE such that for example -! ! SIG(1:NFRE) = SIG2(IKN). - FREQ = FR(1:NFRE) - ANAR = 1.0_JWRB - BNT = 0.035_JWRB**2 - T1 = 0.0_JWRB - T2 = 0.0_JWRB - NEXDENS = 0.0_JWRB -! -!/ 1) --- Calculate threshold spectral density, spectral density, and -!/ the level of exceedence EXDENS(f) -------------------------- / -! ETDENS = ( ZPI * BNT ) / ( ANAR * CGG(IJ,:) * WN(IJ,:)**3 ) - ETDENS = ( ZPI * BNT ) / ( ANAR * CGROUP(IJ,:) * WAVNUM(IJ,:)**3 ) - !EDENS = SUM(FL1(IJ,:,:),1) * ZPI * SIG * DELTH / CGG(IJ,:) !E(f) - EDENS = SUM(FL1(IJ,:,:),1) * DELTH !E(f) - EXDENS = MAX(0.0_JWRB,EDENS-ETDENS) -! -!/ --- normalise by a generic spectral density -------------------- / - IF (SDS6ET) THEN ! ww3_grid.inp: &SDS6 SDSET = T or F - NEXDENS = EXDENS / ETDENS ! normalise by threshold spectral density - ELSE ! normalise by spectral density - EDENSMAX = MAXVAL(EDENS)*1.0E-5_JWRB - IF (ALL(EDENS .GT. EDENSMAX)) THEN - NEXDENS = EXDENS / EDENS - ELSE - DO M = 1,NFRE - IF (EDENS(M) .GT. EDENSMAX) NEXDENS(M) = EXDENS(M) / EDENS(M) - END DO - END IF - END IF -! -!/ 2) --- Calculate inherent breaking component T1 ------------------- / - T1 = SDS6A1 * ANAR * FREQ * (NEXDENS**SDS6P1) -! -!/ 3) --- Calculate T2, the dissipation of waves induced by -!/ the breaking of longer waves T2 ---------------------------- / - ADF = ANAR * (NEXDENS**SDS6P2) - XFAC = (1.0_JWRB-1.0_JWRB/FRATIO)/(FRATIO-1.0_JWRB/FRATIO) - DO M = 1,NFRE - DFII(M) = DF(M) ! bug fix (spotted by Heinz): brought init into loc loop -! IF (M .GT. 1) DFII(M) = DFII(M) * XFAC - IF (M .GT. 1 .AND. M .LT. NFRE) DFII(M) = DFII(M) * XFAC - T2(M) = SDS6A2 * SUM( ADF(1:M)*DFII(1:M) ) - END DO - -!/ 4) --- Sum up dissipation terms and apply to all directions ------- / - T12 = -1.0_JWRB * ( MAX(0.0_JWRB,T1)+MAX(0.0_JWRB,T2) ) - DO K = 1, NANG - D(IKN+(K-1)) = T12 - END DO -! - !S = D * A -! -!/ 5) --- Diagnostic output (switch !/T6) ---------------------------- / -!/T6 CALL STME21 ( TIME , IDTIME ) -!/T6 WRITE (NDST,270) 'T1*E',IDTIME(1:19),(T1*EDENS) -!/T6 WRITE (NDST,270) 'T2*E',IDTIME(1:19),(T2*EDENS) -!/T6 WRITE (NDST,271) SUM(SUM(RESHAPE(S,(/ NANG,NFRE /)),1)*DDEN/CG) -! -!/T6 270 FORMAT (' TEST W3SDS6 : ',A,'(',A,')',':',70E11.3) -!/T6 271 FORMAT (' TEST W3SDS6 : Total SDS =',E13.5) - - DDS = RESHAPE(D,(/NANG,NFRE/)) - DO M = 1,NFRE - DO K = 1, NANG - SL(IJ,K,M) = SL(IJ,K,M) + DDS(K,M)*FL1(IJ,K,M) - FLD(IJ,K,M) = FLD(IJ,K,M) + DDS(K,M) - END DO - END DO - - END DO - ! END LOOP OVER LOC - - IF (LHOOK) CALL DR_HOOK('SDISSIP_BYDBR',1,ZHOOK_HANDLE) - - END SUBROUTINE SDISSIP_BYDBR diff --git a/src/ecwam/sinflx_bydbr.F90 b/src/ecwam/sinflx_bydbr.F90 deleted file mode 100644 index 6a62065c8..000000000 --- a/src/ecwam/sinflx_bydbr.F90 +++ /dev/null @@ -1,627 +0,0 @@ -! (C) Copyright 1989- ECMWF. -! -! This software is licensed under the terms of the Apache Licence Version 2.0 -! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. -! In applying this licence, ECMWF does not waive the privileges and immunities -! granted to it by virtue of its status as an intergovernmental organisation -! nor does it submit to any jurisdiction. -! - -SUBROUTINE SINFLX_BYDBR (ICALL, NCALL, KIJS, KIJL, & - & LUPDTUS, & - & FL1, & - & WAVNUM,CGROUP, CINV, XK2CG,& - & WSWAVE, WDWAVE, AIRD, & - & RAORW, WSTAR, CICOVER, & - & COSWDIF, SINWDIF2, & - & FMEAN, HALP, FMEANWS, & - & FLM, & - & UFRIC, TAUW, TAUWDIR, & - & Z0M, Z0B, CHRNCK, PHIWA, & - & FLD, SL, SPOS, & - & MIJ, RHOWGDFTH, XLLWS) - -! ---------------------------------------------------------------------- - -!**** *SINFLX_BYDBR* - COMPUTATION OF INPUT SOURCE FUNCTION AND STRESSES - - -!* PURPOSE. -! --------- - -! Observation-based source term for wind input after Donelan, Babanin, -! Young and Banner (Donelan et al ,2006) following the implementation -! by Rogers et al. (2012). -! -!** INTERFACE. -! ---------- - -! *CALL* *SINFLX_BYDBR (NGST, LLSNEG, KIJS, KIJL, FL1, -! & WAVNUM, CGROUP, CINV, XK2CG, -! & WSWAVE, WDWAVE, UFRIC, Z0M, -! & COSWDIF, SINWDIF2, -! & RAORW, WSTAR, RNFAC, -! & FLD, SL, SPOS, XLLWS) -! *NGST* - IF = 1 THEN NO GUSTINESS PARAMETERISATION -! - IF = 2 THEN GUSTINESS PARAMETERISATION -! *LLSNEG- IF TRUE THEN THE NEGATIVE SINPUT (SWELL DAMPING) WILL BE COMPUTED -! *KIJS* - INDEX OF FIRST GRIDPOINT. -! *KIJL* - INDEX OF LAST GRIDPOINT. -! *FL1* - SPECTRUM. -! *WAVNUM* - WAVE NUMBER. -! *CGROUP* - GROUP SPEED -! *CINV* - INVERSE PHASE VELOCITY. -! *XK2CG* - (WAVNUM)**2 * GROUP SPPED. -! *WDWAVE* - WIND DIRECTION IN RADIANS IN OCEANOGRAPHIC -! NOTATION (POINTING ANGLE OF WIND VECTOR, -! CLOCKWISE FROM NORTH). -! *UFRIC* - NEW FRICTION VELOCITY IN M/S. -! *Z0M* - ROUGHNESS LENGTH IN M. -! *COSWDIF* - COS(TH(K)-WDWAVE(IJ)) -! *SINWDIF2* - SIN(TH(K)-WDWAVE(IJ))**2 -! *RAORW* - RATIO AIR DENSITY TO WATER DENSITY. -! *WSTAR* - FREE CONVECTION VELOCITY SCALE (M/S). -! *RNFAC* - WIND DEPENDENT FACTOR USED IN THE GROWTH RENORMALISATION. -! *CHRNCK*- CHARNOCK COEFFICIENT -! *FLD* - DIAGONAL MATRIX OF FUNCTIONAL DERIVATIVE. -! *SL* - TOTAL SOURCE FUNCTION ARRAY. -! *SPOS* - POSITIVE SOURCE FUNCTION ARRAY. -! *XLLWS* - = 1 WHERE SINPUT IS POSITIVE - -! METHOD. -! ------- - -! SEE REFERENCE. - -! EXTERNALS. -! ---------- -! TAU_WAVE_ATMOS -! LFACTOR -! IRANGE - -! ORIGIN. -! ---------- -! Adapted from Babanin Young Donelan & Banner (BYDB) physics -! as implemented as ST6 in WAVEWATCH-III -! WW3 module: W3SRC6MD -! WW3 subroutine: W3SIN6 -! Implementation into ECWAM DECEMBER 2021 by J. Kousal - - -! ---------------------------------------------------------------------- - - USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU - - USE YOWCOUP , ONLY : LWCOU ,LLCAPCHNK , LLGCBZ0, LLNORMAGAM - - USE YOWWNDG , ONLY : ICODE ,ICODE_CPL - - USE YOWFRED , ONLY : FR ,TH ,DFIM ,COSTH ,SINTH, ZPIFR, DELTH, FRATIO, FRIC - USE YOWPARAM , ONLY : NANG ,NFRE - USE YOWPCONS , ONLY : G ,GM1 ,EPSMIN, EPSUS, ZPI, ROWATER - USE YOWPHYS , ONLY : ZALP ,TAUWSHELTER, XKAPPA, BETAMAXOXKAPPA2, & - & RNU ,RNUM, & - & SWELLF ,SWELLF2 ,SWELLF3 ,SWELLF4 , SWELLF5, & - & SWELLF6 ,SWELLF7 ,SWELLF7M1, Z0RAT ,Z0TUBMAX , & - & ABMIN ,ABMAX, CDFAC, DTHRN_A ,DTHRN_U - USE YOWTEST , ONLY : IU06 - USE YOWTABL , ONLY : IAB ,SWELLFT - USE YOWSTAT , ONLY : IPHYS2_AIRSEA - - USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK - -! ---------------------------------------------------------------------- - - IMPLICIT NONE - -#include "airsea.intfb.h" -#include "femeanws.intfb.h" -#include "frcutindex.intfb.h" -#include "halphap.intfb.h" -#include "wsigstar.intfb.h" -#include "tau_wave_atmos.intfb.h" -#include "lfactor.intfb.h" -#include "irange.intfb.h" -#include "calcphiwa.intfb.h" - - -INTEGER(KIND=JWIM), INTENT(IN) :: ICALL !! CALL NUMBER. -INTEGER(KIND=JWIM), INTENT(IN) :: NCALL !! TOTAL NUMBER OF CALLS. -INTEGER(KIND=JWIM), INTENT(IN) :: KIJS, KIJL !! GRID POINT INDEXES. - -LOGICAL, INTENT(IN) :: LUPDTUS !! IF TRUE UFRIC AND Z0M WILL BE UPDATED (CALLING AIRSEA). - -REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(INOUT) :: FL1 !! WAVE SPECTRUM. -REAL(KIND=JWRB), DIMENSION(KIJL,NFRE), INTENT(IN) :: WAVNUM !! WAVE NUMBER. -REAL(KIND=JWRB), DIMENSION(KIJL,NFRE), INTENT(IN) :: CGROUP !! GROUP VELOCITY. -REAL(KIND=JWRB), DIMENSION(KIJL,NFRE), INTENT(IN) :: CINV !! INVERSE PHASE VELOCITY. -REAL(KIND=JWRB), DIMENSION(KIJL,NFRE), INTENT(IN) :: XK2CG !! (WAVNUM)**2 * GROUP SPPED. -REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: WSWAVE !! WIND SPEED IN M/S. -REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: WDWAVE !! WIND DIRECTION IN RADIANS IN OCEANOGRAPHIC NOTATION. -REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: AIRD !! AIR DENSITY (KG/M**3). -REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: RAORW !! RATIO AIR DENSITY TO WATER DENSITY. -REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: WSTAR !! FREE CONVECTION VELOCITY SCALE (M/S) -REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: CICOVER !! SEA ICE COVER. -REAL(KIND=JWRB), DIMENSION(KIJL, NANG), INTENT(IN) :: COSWDIF !! COS(TH(K)-WDWAVE(IJ)) -REAL(KIND=JWRB), DIMENSION(KIJL, NANG), INTENT(IN) :: SINWDIF2 !! SIN(TH(K)-WDWAVE(IJ))**2 -REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: FMEAN !! MEAN FREQUENCY. -REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: HALP !! 1/2 PHILLIPS PARAMETER -REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(OUT) :: FMEANWS !! MEAN FREQUENCY OF THE WINDSEA. -REAL(KIND=JWRB), DIMENSION(KIJL,NANG), INTENT(IN) :: FLM !! SPECTAL DENSITY MINIMUM VALUE -REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: UFRIC !! FRICTION VELOCITY IN M/S. -REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: TAUW !! WAVE STRESS IN (M/S)**2 -REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: TAUWDIR !! WAVE STRESS DIRECTION. -REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: Z0M !! ROUGHNESS LENGTH IN M. -REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: Z0B !! BACKGROUND ROUGHNESS LENGTH. -REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: CHRNCK !! CHARNOCK COEFFICIENT. - -REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(OUT) :: PHIWA !! ENERGY FLUX FROM WIND INTO WAVES. -REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(OUT) :: FLD !! DIAGONAL MATRIX OF FUNCTIONAL DERIVATIVE. -REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(OUT) :: SL !! TOTAL SOURCE FUNCTION ARRAY. -REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(OUT) :: SPOS !! POSITIVE SINPUT ONLY. - -INTEGER(KIND=JWIM), INTENT(OUT) :: MIJ(KIJL) !! LAST FREQUENCY INDEX OF THE PROGNOSTIC RANGE. - -REAL(KIND=JWRB), DIMENSION(KIJL,NFRE), INTENT(OUT) :: RHOWGDFTH !! WATER DENSITY * G * DF * DTHETA - -REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(OUT) :: XLLWS !! TOTAL WINDSEA MASK FROM INPUT SOURCE TERM. - -INTEGER(KIND=JWIM) :: IUSFG, ICODE_WND -INTEGER(KIND=JWIM), PARAMETER :: NGST=2 - -REAL(KIND=JPHOOK) :: ZHOOK_HANDLE -REAL(KIND=JWRB), DIMENSION(KIJL) :: RNFAC - -LOGICAL :: LLFACT -INTEGER(KIND=JWIM) :: IJ, K, M, IND, IGST -INTEGER(KIND=JWIM) :: NSPEC !num. of freqs, dirs, spec. bins -INTEGER(KIND=JWIM), DIMENSION(NANG) :: ITHN -INTEGER(KIND=JWIM), DIMENSION(NFRE) :: IKN - -REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: CG2, ECOS2, ESIN2, DSII2 -REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: WN2, SIG2 -REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: SQRTBN2, CINV2, A -REAL(KIND=JWRB), DIMENSION(NFRE) :: DSII, SIG, CINV1, DF -REAL(KIND=JWRB), DIMENSION(NFRE) :: ADENSIG, KMAX, ANAR, SQRTBN -REAL(KIND=JWRB), DIMENSION(NANG,NFRE) :: KK -REAL(KIND=JWRB), DIMENSION(NANG,NFRE) :: SPOSDENSIG, SNEGDENSIG -REAL(KIND=JWRB), DIMENSION(NANG*NFRE,NGST) :: W1, W2, S, D -REAL(KIND=JWRB), DIMENSION(NFRE,NGST) :: LFACT -REAL(KIND=JWRB), DIMENSION(NANG,NFRE,NGST) :: SDENSIG, DINPOS, DINTOT - - -REAL(KIND=JWRB), PARAMETER :: SIN6A0 = 9.0E-2_JWRB ! ST6 PARAM -REAL(KIND=JWRB), DIMENSION(NGST) :: TAUWX, TAUWY ! Component of the wave-supported stress -REAL(KIND=JWRB), DIMENSION(NGST) :: TAUNWX, TAUNWY ! Component of the neg. wave-supported stress -REAL(KIND=JWRB) :: COSU, SINU -REAL(KIND=JWRB), DIMENSION(NGST) :: UPROXY - -REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: XK, CGG_WAM, CM -REAL(KIND=JWRB), DIMENSION(NFRE) :: SIGP2, SIGM1 - -! For USTAR, Z0, CHNK -REAL(KIND=JWRB), DIMENSION(KIJL,NGST) :: TAU -REAL(KIND=JWRB), PARAMETER :: ZRN=1.65E-6_JWRB ! effective kinematic viscosity (0.11*1.5e-5) -REAL(KIND=JWRB), PARAMETER :: RKAP = 0.4_JWRB -REAL(KIND=JWRB) :: ZNLEV, Z0, KUOUST, USTM1, USTM2 -REAL(KIND=JWRB), PARAMETER :: XEPS=0.00001_JWRB -REAL(KIND=JWRB), PARAMETER :: USTMIN=0.000001_JWRB -REAL(KIND=JWRB), PARAMETER :: PCHARMAX=0.1_JWRB -REAL(KIND=JWRB), PARAMETER :: Z0FG=0.01_JWRB -INTEGER(KIND=JWIM) :: ITER -REAL(KIND=JWRB) :: XZNLEV, PCHAROG, XKUTOP, XOLOGZ0 -REAL(KIND=JWRB) :: UST, USTOLD, Z0CH, Z0VIS, Z0TOT, FF, DELF -REAL(KIND=JWRB) :: CHARNOCK_MIN,CHNKMIN ! For Capping -INTEGER(KIND=JWIM), PARAMETER :: NITER=15 -REAL(KIND=JWRB), PARAMETER :: ALPHAMAX=0.1_JWRB -REAL(KIND=JWRB), PARAMETER :: AMAX=0.02_JWRB -REAL(KIND=JWRB), PARAMETER :: BMAX=0.01_JWRB -REAL(KIND=JWRB) :: ALPHAOGMAXU10 - -REAL(KIND=JWRB), DIMENSION(KIJL) :: ROAIRN, CHNKOG, TAUNW - -! For GUSTINESS -REAL(KIND=JWRB) :: AVG_GST -REAL(KIND=JWRB), DIMENSION(KIJL) :: SIG_N, SIG_U10, TAUWGST_AVG, TAUWDIRGST_AVG, TAUNWGST_AVG, USTARGST_AVG -REAL(KIND=JWRB), DIMENSION(KIJL,NGST) :: TAUWGST, TAUWDIRGST, TAUNWGST, UABSGST, USTARGST, Z0GST -REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE) :: SLGST_AVG, SPOSGST_AVG, FLGST_AVG -REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE,NGST) :: SLGST, SPOSGST, FLGST - -! For PHIWA calculation -! REAL(KIND=JWRB),DIMENSION(KIJL,NFRE) :: RHOWGDFTH -! REAL(KIND=JWRB), DIMENSION(KIJL) :: SUMT - - -! ---------------------------------------------------------------------- - -IF (LHOOK) CALL DR_HOOK('SINFLX',0,ZHOOK_HANDLE) - -! UPDATE UFRIC AND Z0M -IF (ICALL == 1 ) THEN - IUSFG = 0 - IF (LWCOU) THEN - ICODE_WND = ICODE_CPL - ELSE - ICODE_WND = ICODE - ENDIF -ELSE - IUSFG = 1 - ICODE_WND = 3 -ENDIF - -IF(LLNORMAGAM .AND. LLCAPCHNK ) THEN - RNFAC(KIJS:KIJL) = 1.0_JWRB+DTHRN_A*(1.0_JWRB+TANH(WSWAVE(KIJS:KIJL)-DTHRN_U)) -ELSE - RNFAC(KIJS:KIJL) = 1.0_JWRB -ENDIF - - -IF(LUPDTUS) THEN - ! increase noise level in the tail - IF (ICALL == 1 ) THEN - DO K=1,NANG - FL1(KIJS:KIJL,K,NFRE) = MAX(FL1(KIJS:KIJL,K,NFRE),FLM(KIJS:KIJL,K)) - ENDDO - - IF (LLGCBZ0) THEN - !$loki inline - CALL HALPHAP(KIJS, KIJL, WAVNUM, COSWDIF, FL1, HALP) - ELSE - HALP(KIJS:KIJL) = 0.0_JWRB - ENDIF - - ENDIF - - !$loki inline - CALL AIRSEA (KIJS, KIJL, & -& HALP, WSWAVE, WDWAVE, TAUW, TAUWDIR, RNFAC, & -& UFRIC, Z0M, Z0B, CHRNCK, ICODE_WND, IUSFG) - -ENDIF - - -! ---------------------------------------------------------------------- -! ---------------------------------------------------------------------- -! ---------------------------------------------------------------------- -! ---------------------------------------------------------------------- -! ---------------------------------------------------------------------- -! input source term!!!! (start) - -NSPEC = NANG * NFRE ! NUMBER OF SPECTRAL BINS - -! Wind height -ZNLEV = 10._JWRB - -! COMPUTE FREQUENCY INTERVALLS (borrowed from Wam_others/f4spec.F) -DO M = 1,NFRE - DF(M) = FR(M)*( FRATIO - 1.0_JWRB ) -ENDDO - -DO M = 1,NFRE - SIG(M) = ZPI*FR(M) - DSII(M) = ZPI*DF(M) - SIGM1(M) = 1.0_JWRB/SIG(M) - SIGP2(M) = SIG(M)**2 -END DO - -! TODO: clean up stuff in/out of IJ loops (sdissip_bydb + swldissip ) -! TODO: confirm that I'm using exactly the same things here (I've now adopted them throughout the BYDBR code) -! - confirm CGG_WAM=CGROUP -! - confirm XK=WAVNUM - -DO M=1,NFRE - DO IJ=KIJS,KIJL - CM(IJ,M) = WAVNUM(IJ,M)*SIGM1(M) - ENDDO -ENDDO - - -ITHN = IRANGE(1,NANG,1) ! Index vector 1:NANG -DO M = 1, NFRE - ECOS2 (ITHN+(M-1)*NANG) = COSTH - ESIN2 (ITHN+(M-1)*NANG) = SINTH -END DO -! -IKN = IRANGE(1,NSPEC,NANG) ! Index vector for elements of 1 ... NFRE -! ! such that e.g. SIG(1:NFRE) = SIG2(IKN). - -DO K = 1, NANG ! Apply to all directions - DSII2 (IKN+(K-1)) = DSII - SIG2 (IKN+(K-1)) = SIG -END DO - -! ESTIMATE THE STANDARD DEVIATION OF GUSTINESS. -CALL WSIGSTAR (KIJS, KIJL, WSWAVE, UFRIC, Z0M, WSTAR, SIG_N, SIG_U10) -AVG_GST = 1.0_JWRB/NGST - -DO IJ=KIJS,KIJL - USTARGST(IJ,1)= UFRIC(IJ)*(1.0_JWRB+SIG_N(IJ)) - USTARGST(IJ,2)= UFRIC(IJ)*(1.0_JWRB-SIG_N(IJ)) - UABSGST(IJ,1)= WSWAVE(IJ)*(1.0_JWRB+SIG_U10(IJ)) - UABSGST(IJ,2)= WSWAVE(IJ)*(1.0_JWRB-SIG_U10(IJ)) - CHNKOG(IJ) = CHRNCK(IJ)*GM1 - ROAIRN(IJ) = RAORW(IJ)*ROWATER -END DO - -! Define Z0GST associated with USTARGST (as in airsea_zbry) -DO IGST=1,NGST - DO IJ=KIJS,KIJL - UST = USTARGST(IJ,IGST) - PCHAROG = MIN(CHNKOG(IJ),PCHARMAX/G) - Z0CH = PCHAROG*UST**2 - Z0VIS = ZRN/UST - Z0GST(IJ,IGST) = Z0CH+Z0VIS - ENDDO ! IJ loop ENDDO -ENDDO ! NGST loop ENDDO - -! Define UABSGST associated with USTARGST and Z0GST -! U10 = (u*/kappa) log (1 + Z/Z0), z=10 -! DO IGST=1,NGST -! DO IJ=KIJS,KIJL -! UABSGST(IJ,IGST) = USTARGST(IJ,IGST)*LOG(1.0_JWRB + ZNLEV/Z0GST(IJ,IGST))/XKAPPA -! END DO -! END DO - -!/ --- Main loop over LOC ----------------------------------- / - - -! LOOP OVER LOCATIONS -DO IJ = KIJS,KIJL - - DO K = 1, NANG ! Apply to all directions - WN2 (IKN+(K-1)) = WAVNUM(IJ,:) ! using WAM native WN,CG - CG2 (IKN+(K-1)) = CGROUP(IJ,:) - END DO - - CINV2 = WN2 / SIG2 ! inverse phase speed - -!/ 0) --- set up a basic variables ----------------------------------- / - - COSU = COS(WDWAVE(IJ)) - SINU = SIN(WDWAVE(IJ)) -! - DO IGST=1,NGST - TAUNWX(IGST) = 0.0_JWRB - TAUNWY(IGST) = 0.0_JWRB - TAUWX(IGST) = 0.0_JWRB - TAUWY(IGST) = 0.0_JWRB - TAU(IJ,IGST) = 0.0_JWRB - ENDDO - -! -!/ --- scale friction velocity to wind speed (10m) in -!/ the boundary layer ----------------------------------------- / -!/ Donelan et al. (2006) used U10 or U_{λ/2} in their S_{in} -!/ parameterization. To avoid some disadvantages of using U10 or -!/ U_{λ/2}, Rogers et al. (2012) used the following engineering -!/ conversion: -!/ UPROXY = SIN6WS * UST -!/ -!/ SIN6WS = FRIC = 28.0 following Komen et al. (1984) (developed seas) -!/ SIN6WS = 32.0 suggested by E. Rogers (2014) (young seas) -! - DO IGST=1,NGST - SELECT CASE (IPHYS2_AIRSEA) - CASE(0) - UPROXY(IGST) = 32.0_JWRB * CDFAC * USTARGST(IJ,IGST) ! original, suggested by E. Rogers (2014) (young seas) - CASE(1) - UPROXY(IGST) = FRIC * CDFAC * USTARGST(IJ,IGST) ! following Komen et al. (1984) (developed seas) (FRIC=28) - CASE(2) - UPROXY(IGST) = UABSGST(IJ,IGST) * CDFAC ! because FRIC=1/sqrt(CD), then this turns to purely a wind dependence (USTARGST cancels out) - END SELECT - ENDDO -! - ! To reshape from 1D to 2D: - ! K = RESHAPE( A , (/ NANG, NFRE /)) - ! To reshape from 2D to 1D: - ! A = RESHAPE( F(IJ,:,:) , (/NSPEC/) ) - A = RESHAPE( FL1(IJ,:,:) , (/NSPEC/)) * CG2 / ( ZPI * SIG2 )! ACTION DENSITY SPECTRUM -! -!/ 1) --- calculate 1d action density spectrum (A(sigma)) and -!/ zero-out values less than 1.0E-32 to avoid NaNs when -!/ computing directional narrowness in step 4). --------------- / - KK = RESHAPE(A,(/ NANG, NFRE /)) - - ADENSIG = SUM(KK,1) * SIG * DELTH ! Integrate over directions. -! -!/ 2) --- calculate normalised directional spectrum K(theta,sigma) --- / - KMAX = MAXVAL(KK,1) - DO M = 1,NFRE - IF (KMAX(M).LT.1.0E-34_JWRB) THEN - KK(1:NANG,M) = 1.0_JWRB - ELSE - KK(1:NANG,M) = KK(1:NANG,M)/KMAX(M) - END IF - END DO -! -!/ 3) --- calculate normalised spectral saturation BN(M) ------------ / - ANAR = 1.0_JWRB/( SUM(KK,1) * DELTH ) ! directional narrowness -! -! SQRTBN = SQRT( ANAR * ADENSIG * WN(IJ,:)**3 ) - SQRTBN = SQRT( ANAR * ADENSIG * WAVNUM(IJ,:)**3 ) - - DO K = 1, NANG - SQRTBN2(IKN+(K-1)) = SQRTBN ! Calculate SQRTBN for - END DO ! the entire spectrum. -! -!/ 4) --- calculate growth rate GAMMA and S for all directions for -!/ following winds (U10/c - 1 is positive; W1) and in 7) for -!/ adverse winds (U10/c -1 is negative, W2). W1 and W2 -!/ complement one another. ------------------------------------ / - DO IGST=1,NGST - W1(:,IGST)= MAX(0.0_JWRB, & - & UPROXY(IGST)*CINV2*(ECOS2*COSU + ESIN2*SINU) - 1.0_JWRB)**2 -! - D(:,IGST) = (RAORW(IJ) ) * SIG2 * & - (2.8_JWRB-(1.0_JWRB+TANH(10.0_JWRB*SQRTBN2*W1(:,IGST)-11.0_JWRB)))*& - & SQRTBN2*W1(:,IGST) -! - S(:,IGST) = D(:,IGST) * A - ENDDO -! -!/ 5) --- calculate reduction factor LFACT using non-directional -! spectral density of the wind input ------------------------- / - CINV1 = CINV2(IKN) - - DO IGST=1,NGST - SDENSIG(:,:,IGST) = RESHAPE(S(:,IGST)*SIG2/CG2,(/ NANG, NFRE /)) - - CALL LFACTOR(SDENSIG(:,:,IGST), CINV1, UABSGST(IJ,IGST), USTARGST(IJ,IGST), WDWAVE(IJ), & -& ROAIRN(IJ), SIG, DSII, LFACT(:,IGST), TAUWX(IGST), TAUWY(IGST), TAU(IJ,IGST)) - ENDDO - -! -!/ 6) --- apply reduction (LFACT) to the entire spectrum ------------- / - - LLFACT = .TRUE. - ! TODO: if this shows to make a big difference, then I can make this logical more rigorous - ! (and also implement it to save costs in LFACTOR) - IF (LLFACT) THEN - DO IGST=1,NGST - IF (SUM(LFACT(:,IGST)) .LT. NFRE) THEN - DO K = 1, NANG - D(IKN+K-1,IGST) = D(IKN+K-1,IGST) * LFACT(:,IGST) - END DO - S(:,IGST) = D(:,IGST) * A - END IF - DINPOS(:,:,IGST) = RESHAPE(D(:,IGST),(/ NANG, NFRE /)) - ENDDO - END IF - -! -!/ 7) --- compute negative wind input for adverse winds. negative -!/ growth is typically smaller by a factor of ~2.5 (=.28/.11) -!/ than those for the favourable winds [Donelan, 2006, Eq. (7)]. -!/ the factor is adjustable with NAMELIST parameter in -!/ ww3_grid.inp: '&SIN6 SINA0 = 0.04 /' ----------------------- / - DO IGST=1,NGST - IF (SIN6A0.GT.0.0_JWRB) THEN - W2(:,IGST) = MIN( 0.0_JWRB,UPROXY(IGST) * CINV2* & - & (ECOS2*COSU + ESIN2*SINU) - 1.0_JWRB )**2 - D(:,IGST) = D(:,IGST) - ( RAORW(IJ) * SIG2 * SIN6A0 * & - (2.8_JWRB-(1.0_JWRB+TANH(10.0_JWRB*SQRTBN2*W2(:,IGST) - 11.0_JWRB)))& - & *SQRTBN2*W2(:,IGST) ) - - DINTOT(:,:,IGST)= RESHAPE(D(:,IGST),(/NANG,NFRE/)) - S(:,IGST) = D(:,IGST) * A - -! ! --- compute negative component of the wave supported stresses -! ! from negative part of the wind input ---------------------- / - SDENSIG(:,:,IGST) = RESHAPE(S(:,IGST)*SIG2/CG2,(/ NANG, NFRE /)) - CALL TAU_WAVE_ATMOS(SDENSIG(:,:,IGST), CINV1, SIG, DSII, TAUNWX(IGST), TAUNWY(IGST) ) - ELSE - DINTOT(:,:,IGST)=DINPOS(:,:,IGST) - END IF - ENDDO -! - DO IGST=1,NGST - TAUWGST(IJ,IGST) = SQRT(TAUWX(IGST)**2+TAUWY(IGST)**2) / ROAIRN(IJ) ! KINEMATIC TAUW - TAUWDIRGST(IJ,IGST) = ATAN2(TAUWX(IGST),TAUWY(IGST)) - TAUNWGST(IJ,IGST) = SQRT(TAUNWX(IGST)**2+TAUNWY(IGST)**2) / ROAIRN(IJ) ! KINEMATIC TAUNW - USTARGST(IJ,IGST) = SQRT(TAU(IJ,IGST) / ROAIRN(IJ) ) - ENDDO - -! 8) --- Calculate SL, FL and SPOS needed for ecWAM ------------- / - - DO IGST=1,NGST - DO M = 1,NFRE - DO K = 1, NANG - SLGST(IJ,K,M,IGST) = DINTOT(K,M,IGST)*FL1(IJ,K,M) - SPOSGST(IJ,K,M,IGST) = DINPOS(K,M,IGST)*FL1(IJ,K,M) - END DO - END DO - FLGST(IJ,:,:,IGST) = DINTOT(:,:,IGST) - END DO - -! 9) --- Averaging over gust components ------------- / - IGST=1 - TAUWGST_AVG(IJ) = TAUWGST(IJ,IGST) - TAUWDIRGST_AVG(IJ) = TAUWDIRGST(IJ,IGST) - TAUNWGST_AVG(IJ) = TAUNWGST(IJ,IGST) - USTARGST_AVG(IJ) = USTARGST(IJ,IGST) - SLGST_AVG(IJ,:,:) = SLGST(IJ,:,:,IGST) - SPOSGST_AVG(IJ,:,:) = SPOSGST(IJ,:,:,IGST) - FLGST_AVG(IJ,:,:) = FLGST(IJ,:,:,IGST) - DO IGST=2,NGST - TAUWGST_AVG(IJ) = TAUWGST_AVG(IJ) + TAUWGST(IJ,IGST) - TAUWDIRGST_AVG(IJ) = TAUWDIRGST_AVG(IJ) + TAUWDIRGST(IJ,IGST) - TAUNWGST_AVG(IJ) = TAUNWGST_AVG(IJ) + TAUNWGST(IJ,IGST) - USTARGST_AVG(IJ) = USTARGST_AVG(IJ) + USTARGST(IJ,IGST) - SLGST_AVG(IJ,:,:) = SLGST_AVG(IJ,:,:) + SLGST(IJ,:,:,IGST) - SPOSGST_AVG(IJ,:,:) = SPOSGST_AVG(IJ,:,:) + SPOSGST(IJ,:,:,IGST) - FLGST_AVG(IJ,:,:) = FLGST_AVG(IJ,:,:) + FLGST(IJ,:,:,IGST) - ENDDO - TAUW(IJ) = AVG_GST*TAUWGST_AVG(IJ) - TAUWDIR(IJ) = AVG_GST*TAUWDIRGST_AVG(IJ) - TAUNW(IJ) = AVG_GST*TAUNWGST_AVG(IJ) - UFRIC(IJ) = AVG_GST*USTARGST_AVG(IJ) - SL(IJ,:,:) = AVG_GST*SLGST_AVG(IJ,:,:) - SPOS(IJ,:,:) = AVG_GST*SPOSGST_AVG(IJ,:,:) - FLD(IJ,:,:) = AVG_GST*FLGST_AVG(IJ,:,:) - -! 10) --- Calculate roughness length and charnock ------------- / - - USTM1 = 1.0_JWRB/MAX(UFRIC(IJ),EPSUS) ! Protect the code - USTM2 = 1.0_JWRB/MAX(UFRIC(IJ)**2,EPSUS) ! Protect the code - KUOUST = MIN(50._JWRB,XKAPPA*WSWAVE(IJ)*USTM1) ! Protect the code - Z0 = ZNLEV / ( EXP(KUOUST) - 1.0_JWRB ) - Z0 = MAX(Z0, 0.0000001_JWRB) - Z0M(IJ) = Z0 ! Update z0 - CHNKOG(IJ) = ( Z0 - ZRN*USTM1 ) * USTM2 ! Update charnock (where Z0=Z0CH+Z0VIS from airsea_zbry) - ALPHAOGMAXU10 = MIN(ALPHAMAX,AMAX+BMAX*WSWAVE(IJ))*GM1 ! protective code taken from outbeta (incl /G) - CHNKOG(IJ) = MIN(CHNKOG(IJ),ALPHAOGMAXU10) ! protective code taken from outbeta (incl /G) - - IF(LLCAPCHNK) THEN - CHARNOCK_MIN = CHNKMIN(WSWAVE(IJ)) - CHNKOG(IJ) = MAX(CHARNOCK_MIN*GM1,CHNKOG(IJ)) - ELSE - CHNKOG(IJ) = MAX(CHNKOG(IJ), 1E-5_JWRB) - ENDIF - - CHRNCK(IJ) = CHNKOG(IJ)*G - -! 11) --- PHIWA calculation using non-directional -! spectral density of the wind input ---------------------- / - - SPOSDENSIG = SPOS(IJ,:,:) - SNEGDENSIG = SL(IJ,:,:) - SPOS(IJ,:,:) - PHIWA(IJ) = CALCPHIWA(SPOSDENSIG,SNEGDENSIG,DSII) ! TODO: add the HiFreq contribution - -END DO -! END LOOP OVER LOC -! --------------------- - -! XLLWS based on SL (mask for neg. input) -DO IJ=KIJS,KIJL - DO M = 1,NFRE - DO K = 1, NANG - IF (SL(IJ,K,M)>0.0_JWRB) THEN - XLLWS(IJ,K,M)=1.0_JWRB - ELSE - XLLWS(IJ,K,M)=0.0_JWRB - END IF - END DO - END DO -END DO -! --------------------- - -! input source term!!!! (end) -! ---------------------------------------------------------------------- -! ---------------------------------------------------------------------- -! ---------------------------------------------------------------------- -! ---------------------------------------------------------------------- -! ---------------------------------------------------------------------- - -! MEAN FREQUENCY CHARACTERISTIC FOR WIND SEA -!$loki inline -CALL FEMEANWS(KIJS, KIJL, FL1, XLLWS, FMEANWS) - -! COMPUTE LAST FREQUENCY INDEX OF PROGNOSTIC PART OF SPECTRUM. -!$loki inline -CALL FRCUTINDEX(KIJS, KIJL, FMEAN, FMEANWS, UFRIC, CICOVER, MIJ, RHOWGDFTH) - -! ---------------------------------------------------------------------- - -IF (LHOOK) CALL DR_HOOK('SINFLX',1,ZHOOK_HANDLE) - -END SUBROUTINE SINFLX_BYDBR diff --git a/src/ecwam/swldissip_bydbr.F90 b/src/ecwam/swldissip_bydbr.F90 deleted file mode 100644 index f75110156..000000000 --- a/src/ecwam/swldissip_bydbr.F90 +++ /dev/null @@ -1,228 +0,0 @@ -! (C) Copyright 1989- ECMWF. -! -! This software is licensed under the terms of the Apache Licence Version 2.0 -! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. -! In applying this licence, ECMWF does not waive the privileges and immunities -! granted to it by virtue of its status as an intergovernmental organisation -! nor does it submit to any jurisdiction. -! - - SUBROUTINE SWLDISSIP_BYDBR (KIJS, KIJL, FL1, FLD, SL, & - & WAVNUM, CGROUP, XK2CG, & - & UFRIC, COSWDIF, RAORW) -! ---------------------------------------------------------------------- - -!**** *SWLDISSIP_BYDBR* - COMPUTATION OF DISSIPATION SOURCE FUNCTION. - -! LOTFI AOUF METEO FRANCE 2013 -! FABRICE ARDHUIN IFREMER 2013 - - -!* PURPOSE. -! -------- -! Turbulent dissipation of narrow-banded swell as described in -! Babanin (2011, Section 7.5). -! -!** INTERFACE. -! ---------- - -! *CALL* *SWLDISSIP_BYDBR (KIJS, KIJL, FL1, FLD,SL,* -! WAVNUM, CGROUP, XK2CG, -! UFRIC, COSWDIF, RAORW)* -! *KIJS* - INDEX OF FIRST GRIDPOINT -! *KIJL* - INDEX OF LAST GRIDPOINT -! *FL1* - SPECTRUM. -! *FLD* - DIAGONAL MATRIX OF FUNCTIONAL DERIVATIVE -! *SL* - TOTAL SOURCE FUNCTION ARRAY -! *WAVNUM* - WAVE NUMBER -! *CGROUP* - GROUP SPEED -! *XK2CG* - (WAVE NUMBER)**2 * GROUP SPEED -! *UFRIC* - FRICTION VELOCITY IN M/S. -! *RAORW* - RATIO AIR DENSITY TO WATER DENSITY -! *COSWDIF*- COS(TH(K)-WDWAVE(IJ)) - - -! METHOD. -! ------- - -! SEE REFERENCES. - -! EXTERNALS. -! ---------- - -! IRANGE - -! REFERENCE. -! ---------- - -! Babanin 2011: Cambridge Press, 295-321, 463pp. - -! ORIGIN. -! ---------- -! Adapted from Babanin Young Donelan & Banner (BYDB) physics -! as implemented as ST6 in WAVEWATCH-III -! WW3 module: W3SWLDMD -! WW3 subroutine: W3SWL6 -! Implementation into ECWAM DECEMBER 2021 by J. Kousal - - -! ---------------------------------------------------------------------- - USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU - - USE YOWFRED , ONLY : FR , TH ,ZPIFR ,FRATIO ,DELTH, DFIM - USE YOWPCONS , ONLY : G ,ZPI - USE YOWPARAM , ONLY : NANG ,NFRE - USE YOWPHYS , ONLY : SDSBR ,ISDSDTH ,ISB ,IPSAT , & -& SSDSC2 , SSDSC4, SSDSC6, MICHE, SSDSC3, SSDSBRF1, & -& BRKPBCOEF ,SSDSC5, NSDSNTH, & -& INDICESSAT, SATWEIGHTS - - USE YOMHOOK , ONLY : LHOOK ,DR_HOOK, JPHOOK - -! ---------------------------------------------------------------------- - - IMPLICIT NONE -#include "irange.intfb.h" - - INTEGER(KIND=JWIM), INTENT(IN) :: KIJS, KIJL - - REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(IN) :: FL1 - REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(INOUT) :: FLD, SL - REAL(KIND=JWRB), DIMENSION(KIJL,NFRE), INTENT(IN) :: WAVNUM, CGROUP, XK2CG - REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: UFRIC, RAORW - REAL(KIND=JWRB), DIMENSION(KIJL, NANG), INTENT(IN) :: COSWDIF - - INTEGER(KIND=JWIM) :: IJ, M, I, J, M2, K2, K, NANGD - INTEGER(KIND=JWIM) :: NSPEC !num. of freqs, dirs, spec. bins - INTEGER(KIND=JWIM), DIMENSION(NANG) :: KKD - INTEGER(KIND=JWIM), DIMENSION(NANG) :: ITHN - INTEGER(KIND=JWIM), DIMENSION(NFRE) :: IKN - - REAL(KIND=JWRB), PARAMETER :: SWL6B1 = 0.0041_JWRB ! ST6 PARAM - LOGICAL, PARAMETER :: SWL6CSTB1 = .FALSE. ! ST6 PARAM - - REAL(KIND=JWRB), DIMENSION(NFRE) :: ABAND, KMAX, ANAR, BN, AORB, DDIS - REAL(KIND=JWRB), DIMENSION(NFRE) :: SIG, DDEN - REAL(KIND=JWRB), DIMENSION(NANG,NFRE) :: KK - REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: S, D, A - REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: SIG2, CG2 - REAL(KIND=JWRB) :: B1 - REAL(KIND=JWRB), DIMENSION(NANG,NFRE) :: DSWL - - REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: XK, CGG_WAM - REAL(KIND=JWRB), DIMENSION(NFRE) :: SIGP2 - REAL(KIND=JWRB), DIMENSION(NFRE) :: DF ! FREQUENCY INTERVALS - - REAL(KIND=JPHOOK) :: ZHOOK_HANDLE - -! ---------------------------------------------------------------------- - - IF (LHOOK) CALL DR_HOOK('SWLDISSIP_BYDBR',0,ZHOOK_HANDLE) - - NSPEC = NANG * NFRE ! NUMBER OF SPECTRAL BINS - - DO M = 1,NFRE - SIG(M) = ZPI*FR(M) - SIGP2(M) = SIG(M)**2 - DDEN(M) = ZPI*DFIM(M)*SIG(M) - END DO - -! COMPUTE FREQUENCY INTERVALLS (borrowed from Wam_others/f4spec.F) - DO M = 1,NFRE - DF(M) = FR(M)*( FRATIO - 1.0_JWRB ) - ENDDO - - IKN = IRANGE(1,NSPEC,NANG) ! Index vector for elements of 1 ... NFRE -! ! such that e.g. SIG(1:NFRE) = SIG2(IKN). - DO K = 1, NANG ! Apply to all directions - SIG2 (IKN+(K-1)) = SIG - END DO - - - ! LOOP OVER LOCATIONS - DO IJ = KIJS,KIJL - - DO K = 1, NANG ! Apply to all directions - CG2 (IKN+(K-1)) = CGROUP(IJ,:) - END DO - - A = RESHAPE( FL1(IJ,:,:) , (/NSPEC/)) * CG2 / ( ZPI * SIG2 )! ACTION DENSITY SPECTRUM - ! WAM E(f,theta) to WW3 A(k,theta) conversion factor: CG2 / ( ZPI *SIG2 ) - -!/ 0) --- Initialize parameters -------------------------------------- / - IKN = IRANGE(1,NSPEC,NANG) ! Index vector for array access, e.g. - ! in form of WN(1:NFRE) == WN2(IKN). - ABAND = SUM(RESHAPE(A,(/ NANG,NFRE /)),1) ! action density as function of wavenumber - DDIS = 0.0_JWRB - D = 0.0_JWRB - B1 = SWL6B1 ! empirical constant from NAMELIST - -!/ 1) --- Choose calculation of steepness a*k ------------------------ / -!/ Replace the measure of steepness with the spectral -! saturation after Banner et al. (2002) ---------------------- / - KK = RESHAPE(A,(/ NANG,NFRE /)) - KMAX = MAXVAL(KK,1) - DO M = 1,NFRE - IF (KMAX(M).LT.1.0E-34_JWRB) THEN - KK(1:NANG,M) = 1.0_JWRB - ELSE - KK(1:NANG,M) = KK(1:NANG,M)/KMAX(M) - END IF - END DO - ANAR = 1.0_JWRB/( SUM(KK,1) * DELTH ) -! BN = ANAR * ( ABAND * SIG * DELTH ) * WN(IJ,:)**3 - BN = ANAR * ( ABAND * SIG * DELTH ) * WAVNUM(IJ,:)**3 - -! - IF (.NOT.SWL6CSTB1) THEN -! -!/ --- A constant value for B1 attenuates swell too strong in the -!/ western central Pacific (i.e. cross swell less than 1.0m). -!/ Workaround is to scale B1 with steepness a*kp, where kp is -!/ the peak wavenumber. SWL6B1 remains a scaling constant, but -!/ with different magnitude. --------------------------------- / - M = MAXLOC(ABAND,1) ! Index for peak -! EMEAN = SUM(ABAND * DDEN / CG) ! Total sea surface variance -! B1 = SWL6B1*(2.0_JWRB*SQRT(SUM(ABAND*DDEN/CGG(IJ,:)))*& -! & WN(IJ,M)) - B1 = SWL6B1*(2.0_JWRB*SQRT(SUM(ABAND*DDEN/CGROUP(IJ,:)))*& - & WAVNUM(IJ,M)) - -! - END IF -! -!/ 2) --- Calculate the derivative term only (in units of 1/s) ------- / - DO M = 1,NFRE - IF (ABAND(M) .GT. 1.0E-30_JWRB) THEN - DDIS(M) = -(2.0_JWRB/3.0_JWRB) * B1 * SIG(M) * SQRT(BN(M)) - END IF - END DO -! -!/ 3) --- Apply dissipation term of derivative to all directions ----- / - DO K = 1, NANG - D(IKN+(K-1)) = DDIS - END DO -! - !S = D * A -! -! WRITE(*,*) ' B1 =',B1 -! WRITE(*,*) ' DDIS_tot =',SUM(DDIS*ABAND*DDEN/CG) -! WRITE(*,*) ' EDENS_tot=',sum(aband*dden/cg) -! WRITE(*,*) ' EDENS_tot=',sum(aband*sig*dth*dsii/cg) -! WRITE(*,*) ' ' -! WRITE(*,*) ' SWL6_tot =',sum(SUM(RESHAPE(S,(/ NANG,NFRE /)),1)*DDEN/CG) - - DSWL = RESHAPE(D,(/NANG,NFRE/)) - DO M = 1,NFRE - DO K = 1, NANG - SL(IJ,K,M) = SL(IJ,K,M) + DSWL(K,M)*FL1(IJ,K,M) - FLD(IJ,K,M) = FLD(IJ,K,M) + DSWL(K,M) - END DO - END DO - - END DO - ! END LOOP OVER LOC - - IF (LHOOK) CALL DR_HOOK('SWLDISSIP_BYDBR',1,ZHOOK_HANDLE) - - END SUBROUTINE SWLDISSIP_BYDBR From 069e61760f05909a0a366749fa7bfd271029d3b9 Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Tue, 14 Oct 2025 10:45:07 +0000 Subject: [PATCH 17/89] correct zbry implementation for NGST=1 --- src/ecwam/sinflx_zbry.F90 | 33 +++++++++++++++++++++++++-------- 1 file changed, 25 insertions(+), 8 deletions(-) diff --git a/src/ecwam/sinflx_zbry.F90 b/src/ecwam/sinflx_zbry.F90 index d3284cbd3..d24187cbf 100644 --- a/src/ecwam/sinflx_zbry.F90 +++ b/src/ecwam/sinflx_zbry.F90 @@ -334,14 +334,31 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, KIJS, KIJL, & CALL WSIGSTAR (KIJS, KIJL, WSWAVE, UFRIC, Z0M, WSTAR, SIG_N, SIG_U10) AVG_GST = 1.0_JWRB/NGST -DO IJ=KIJS,KIJL - USTARGST(IJ,1)= UFRIC(IJ)*(1.0_JWRB+SIG_N(IJ)) - USTARGST(IJ,2)= UFRIC(IJ)*(1.0_JWRB-SIG_N(IJ)) - UABSGST(IJ,1)= WSWAVE(IJ)*(1.0_JWRB+SIG_U10(IJ)) - UABSGST(IJ,2)= WSWAVE(IJ)*(1.0_JWRB-SIG_U10(IJ)) - CHNKOG(IJ) = CHRNCK(IJ)*GM1 - ROAIRN(IJ) = RAORW(IJ)*ROWATER -END DO +IF (NGST == 1) THEN + DO IJ=KIJS,KIJL + USTP(IJ,1) = UFRIC(IJ) + ENDDO +ELSE IF (NGST == 2) THEN + DO IJ=KIJS,KIJL + USTARGST(IJ,1)= UFRIC(IJ)*(1.0_JWRB+SIG_N(IJ)) + USTARGST(IJ,2)= UFRIC(IJ)*(1.0_JWRB-SIG_N(IJ)) + UABSGST(IJ,1)= WSWAVE(IJ)*(1.0_JWRB+SIG_U10(IJ)) + UABSGST(IJ,2)= WSWAVE(IJ)*(1.0_JWRB-SIG_U10(IJ)) + CHNKOG(IJ) = CHRNCK(IJ)*GM1 + ROAIRN(IJ) = RAORW(IJ)*ROWATER + END DO +ELSE + WRITE (IU06,*) '**************************************' + WRITE (IU06,*) '* FATAL ERROR *' + WRITE (IU06,*) '* =========== *' + WRITE (IU06,*) '* IN SINPUT_ARD: NGST > 2 *' + WRITE (IU06,*) '* NGST = ', NGST + WRITE (IU06,*) '* PROGRAM ABORTS. PROGRAM ABORTS. *' + WRITE (IU06,*) '* *' + WRITE (IU06,*) '**************************************' + CALL ABORT1 +ENDIF + ! Define Z0GST associated with USTARGST (as in airsea_zbry) DO IGST=1,NGST From 17291dff7d6c40227997e39e5d6a8f95852d8da1 Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Tue, 14 Oct 2025 10:53:08 +0000 Subject: [PATCH 18/89] bugfix on SIG_U10 --- src/ecwam/wsigstar.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/ecwam/wsigstar.F90 b/src/ecwam/wsigstar.F90 index 7466f84c6..a56ba419e 100644 --- a/src/ecwam/wsigstar.F90 +++ b/src/ecwam/wsigstar.F90 @@ -103,7 +103,7 @@ SUBROUTINE WSIGSTAR (KIJS, KIJL, WSWAVE, UFRIC, Z0M, WSTAR, SIG_N, SIG_U10) SIG_N(IJ) = MIN(SIG_NMAX, SIG_CONV * U10M1*(BG_GUST*UFRIC(IJ)**3 + & & 0.5_JWRB*XKAPPA*WSTAR(IJ)**3)**ONETHIRD ) SIG_U10(IJ) = MIN(SIG_U10MAX, (BG_GUST*UFRIC(IJ)**3 + & - & 0.5_JWRB*(XKAPPA*WSTAR(IJ))**3)**ONETHIRD ) + & 0.5_JWRB*XKAPPA*WSTAR(IJ)**3)**ONETHIRD ) ENDDO @@ -130,7 +130,7 @@ SUBROUTINE WSIGSTAR (KIJS, KIJL, WSWAVE, UFRIC, Z0M, WSTAR, SIG_N, SIG_U10) SIG_N(IJ) = MIN(SIG_NMAX, SIG_CONV * U10M1*(BG_GUST*UFRIC(IJ)**3 + & & 0.5_JWRB*XKAPPA*WSTAR(IJ)**3)**ONETHIRD ) SIG_U10(IJ) = MIN(SIG_U10MAX, (BG_GUST*UFRIC(IJ)**3 + & - & 0.5_JWRB*(XKAPPA*WSTAR(IJ))**3)**ONETHIRD ) + & 0.5_JWRB*XKAPPA*WSTAR(IJ)**3)**ONETHIRD ) ENDDO From 79e99e5821fd24e09940e0136908a689219165e1 Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Tue, 14 Oct 2025 11:13:36 +0000 Subject: [PATCH 19/89] for IPHYS2_AIRSEA=0, diagnose CD directly from U10 & UFRIC --- src/ecwam/outbeta.F90 | 30 ++++++++++++++++++++++-------- 1 file changed, 22 insertions(+), 8 deletions(-) diff --git a/src/ecwam/outbeta.F90 b/src/ecwam/outbeta.F90 index 0e7583122..3c35ae9f9 100644 --- a/src/ecwam/outbeta.F90 +++ b/src/ecwam/outbeta.F90 @@ -68,7 +68,8 @@ SUBROUTINE OUTBETA (KIJS, KIJL, & USE YOWCOUP , ONLY : LLGCBZ0 USE YOWPCONS , ONLY : G , GM1, EPSUS - USE YOWPHYS , ONLY : XKAPPA, XNLEV, RNUM , PRCHAR, ALPHAMIN, ALPHAMAX, ALPHA + USE YOWPHYS , ONLY : XKAPPA, XNLEV, RNUM , PRCHAR, ALPHAMIN, ALPHAMAX, ALPHA, CDFAC + USE YOWSTAT , ONLY : IPHYS, IPHYS2_AIRSEA USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK @@ -97,7 +98,7 @@ SUBROUTINE OUTBETA (KIJS, KIJL, & INTEGER(KIND=JWIM) :: IJ - REAL(KIND=JWRB) :: GUSM2, Z0ATM + REAL(KIND=JWRB) :: GUSM2, Z0ATM, FLX4A0, USPROXY REAL(KIND=JWRB), DIMENSION(KIJL) :: USM REAL(KIND=JWRB), DIMENSION(KIJL) :: ALPHAMAXU10 REAL(KIND=JPHOOK) :: ZHOOK_HANDLE @@ -125,12 +126,25 @@ SUBROUTINE OUTBETA (KIJS, KIJL, & ENDDO IF( PRESENT(CD) ) THEN - DO IJ = KIJS,KIJL -!!! we are assuming here that z0 = RNUM/USTAR + Charnock USTAR**2/g -!!! in order to fit with what is used in the IFS. - Z0ATM = RNUM*USM(IJ) + GM1 * BETAM(IJ) * USTAR(IJ)**2 - CD(IJ) = ( XKAPPA / LOG( 1.0_JWRB + XNLEV/Z0ATM) )**2 - ENDDO + IF (IPHYS==2 .AND. IPHYS2_AIRSEA==0) THEN ! TODO: implement module for Hwang instead of duplicating it here + FLX4A0 = CDFAC + DO IJ = KIJS,KIJL + IF (U10(IJ) .GE. 50.33_JWRB) THEN + USPROXY = 2.026_JWRB * SQRT(FLX4A0) + CD(IJ) = (USPROXY/U10(IJ))**2 + ELSE + CD(IJ) = FLX4A0 * ( 8.058_JWRB + 0.967_JWRB*U10(IJ) - 0.016_JWRB*U10(IJ)**2 ) * 1E-4_JWRB + ! USPROXY = U10(IJ) * SQRT(CD) + END IF + ENDDO + ELSE + DO IJ = KIJS,KIJL + !!! we are assuming here that z0 = RNUM/USTAR + Charnock USTAR**2/g + !!! in order to fit with what is used in the IFS. + Z0ATM = RNUM*USM(IJ) + GM1 * BETAM(IJ) * USTAR(IJ)**2 + CD(IJ) = ( XKAPPA / LOG( 1.0_JWRB + XNLEV/Z0ATM) )**2 + ENDDO + ENDIF ENDIF IF (LHOOK) CALL DR_HOOK('OUTBETA',1,ZHOOK_HANDLE) From df58475fec483f2d99ad02f138d85f90ffb05ca7 Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Tue, 14 Oct 2025 11:19:10 +0000 Subject: [PATCH 20/89] further bugfix on implementation NGST=1 --- src/ecwam/outbeta.F90 | 2 +- src/ecwam/sinflx_zbry.F90 | 9 ++++++--- 2 files changed, 7 insertions(+), 4 deletions(-) diff --git a/src/ecwam/outbeta.F90 b/src/ecwam/outbeta.F90 index 3c35ae9f9..f8f58c6fe 100644 --- a/src/ecwam/outbeta.F90 +++ b/src/ecwam/outbeta.F90 @@ -134,7 +134,7 @@ SUBROUTINE OUTBETA (KIJS, KIJL, & CD(IJ) = (USPROXY/U10(IJ))**2 ELSE CD(IJ) = FLX4A0 * ( 8.058_JWRB + 0.967_JWRB*U10(IJ) - 0.016_JWRB*U10(IJ)**2 ) * 1E-4_JWRB - ! USPROXY = U10(IJ) * SQRT(CD) + ! USPROXY = U10(IJ) * SQRT(CD) ! not needed, not updating USTAR here END IF ENDDO ELSE diff --git a/src/ecwam/sinflx_zbry.F90 b/src/ecwam/sinflx_zbry.F90 index d24187cbf..0797f1531 100644 --- a/src/ecwam/sinflx_zbry.F90 +++ b/src/ecwam/sinflx_zbry.F90 @@ -336,7 +336,8 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, KIJS, KIJL, & IF (NGST == 1) THEN DO IJ=KIJS,KIJL - USTP(IJ,1) = UFRIC(IJ) + USTARGST(IJ,1) = UFRIC(IJ) + UABSGST(IJ,1) = WSWAVE(IJ) ENDDO ELSE IF (NGST == 2) THEN DO IJ=KIJS,KIJL @@ -344,8 +345,6 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, KIJS, KIJL, & USTARGST(IJ,2)= UFRIC(IJ)*(1.0_JWRB-SIG_N(IJ)) UABSGST(IJ,1)= WSWAVE(IJ)*(1.0_JWRB+SIG_U10(IJ)) UABSGST(IJ,2)= WSWAVE(IJ)*(1.0_JWRB-SIG_U10(IJ)) - CHNKOG(IJ) = CHRNCK(IJ)*GM1 - ROAIRN(IJ) = RAORW(IJ)*ROWATER END DO ELSE WRITE (IU06,*) '**************************************' @@ -359,6 +358,10 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, KIJS, KIJL, & CALL ABORT1 ENDIF +DO IJ=KIJS,KIJL + CHNKOG(IJ) = CHRNCK(IJ)*GM1 + ROAIRN(IJ) = RAORW(IJ)*ROWATER +END DO ! Define Z0GST associated with USTARGST (as in airsea_zbry) DO IGST=1,NGST From bec80064144d62875cee7c4b6e1780eb503ffdc0 Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Tue, 14 Oct 2025 15:20:36 +0000 Subject: [PATCH 21/89] diagnose CD; output UPROXY --- src/ecwam/implsch.F90 | 6 +- src/ecwam/mpuserin.F90 | 2 +- src/ecwam/outbeta.F90 | 9 +- src/ecwam/outblock.F90 | 7 +- src/ecwam/outbs.F90 | 2 +- src/ecwam/outbs_loki_gpu.F90 | 2 +- src/ecwam/outstep0.F90 | 2 +- src/ecwam/sinflx.F90 | 5 +- src/ecwam/sinflx_zbry.F90 | 29 +++-- src/ecwam/wamintgr.F90 | 2 +- src/ecwam/wamintgr_loki_gpu.F90 | 2 +- src/ecwam/wdfluxes.F90 | 6 +- src/ecwam/yowdrvtype_config.yml | 2 +- tests/etopo1_oper_an_fc_O48_cy50r1_zbry.yml | 129 ++++++++++++++++++++ 14 files changed, 169 insertions(+), 36 deletions(-) create mode 100644 tests/etopo1_oper_an_fc_O48_cy50r1_zbry.yml diff --git a/src/ecwam/implsch.F90 b/src/ecwam/implsch.F90 index 7e07e4b1a..0d83a3194 100644 --- a/src/ecwam/implsch.F90 +++ b/src/ecwam/implsch.F90 @@ -19,7 +19,7 @@ SUBROUTINE IMPLSCH (KIJS, KIJL, FL1, & & WSEMEAN, WSFMEAN, USTOKES, VSTOKES, STRNMS, & & TAUXD, TAUYD, TAUOCXD, TAUOCYD, TAUOC, & & TAUICX, TAUICY, & - & PHIOCD, PHIEPS, PHIAW, & + & PHIOCD, PHIEPS, PHIAW, UPROXY, & & MIJ, XLLWS) ! ---------------------------------------------------------------------- @@ -130,7 +130,7 @@ SUBROUTINE IMPLSCH (KIJS, KIJL, FL1, & INTEGER(KIND=JWIM), DIMENSION(KIJL), INTENT(IN) :: IOBND REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: AIRD, WDWAVE, CICOVER, WSWAVE, WSTAR, USTRA, VSTRA - REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: UFRIC, TAUW, TAUWDIR, Z0M, Z0B, CHRNCK, CITHICK + REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: UFRIC, UPROXY, TAUW, TAUWDIR, Z0M, Z0B, CHRNCK, CITHICK REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: WSEMEAN, WSFMEAN, USTOKES, VSTOKES, STRNMS REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: TAUXD, TAUYD, TAUOCXD, TAUOCYD, TAUOC, PHIOCD REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: TAUICX, TAUICY @@ -270,7 +270,7 @@ SUBROUTINE IMPLSCH (KIJS, KIJL, FL1, & & COSWDIF, SINWDIF2, & & FMEAN, HALP, FMEANWS, & & FLM, & - & UFRIC, TAUW, TAUWDIR, & + & UFRIC, UPROXY, TAUW, TAUWDIR, & & Z0M, Z0B, CHRNCK, PHIWA, & & FLD, SL, SPOS, & & MIJ, RHOWGDFTH, XLLWS) diff --git a/src/ecwam/mpuserin.F90 b/src/ecwam/mpuserin.F90 index d96313ba3..86d622565 100644 --- a/src/ecwam/mpuserin.F90 +++ b/src/ecwam/mpuserin.F90 @@ -605,7 +605,7 @@ SUBROUTINE MPUSERIN ICASE = 1 ISHALLO = 0 !! depricated IPHYS = 1 - IPHYS2_AIRSEA = 2 !0=~ST6, 1=iterative, 2=based only on wind! + IPHYS2_AIRSEA = 0 !0=~ST6, 1=iterative, 2=based only on wind! ISNONLIN = 1 IDAMPING = 1 IPROPAGS = 0 diff --git a/src/ecwam/outbeta.F90 b/src/ecwam/outbeta.F90 index f8f58c6fe..15760aafa 100644 --- a/src/ecwam/outbeta.F90 +++ b/src/ecwam/outbeta.F90 @@ -127,15 +127,8 @@ SUBROUTINE OUTBETA (KIJS, KIJL, & IF( PRESENT(CD) ) THEN IF (IPHYS==2 .AND. IPHYS2_AIRSEA==0) THEN ! TODO: implement module for Hwang instead of duplicating it here - FLX4A0 = CDFAC DO IJ = KIJS,KIJL - IF (U10(IJ) .GE. 50.33_JWRB) THEN - USPROXY = 2.026_JWRB * SQRT(FLX4A0) - CD(IJ) = (USPROXY/U10(IJ))**2 - ELSE - CD(IJ) = FLX4A0 * ( 8.058_JWRB + 0.967_JWRB*U10(IJ) - 0.016_JWRB*U10(IJ)**2 ) * 1E-4_JWRB - ! USPROXY = U10(IJ) * SQRT(CD) ! not needed, not updating USTAR here - END IF + CD(IJ) = (USTAR(IJ)/U10(IJ))**2 ENDDO ELSE DO IJ = KIJS,KIJL diff --git a/src/ecwam/outblock.F90 b/src/ecwam/outblock.F90 index d7e5a3059..0ab8c1481 100644 --- a/src/ecwam/outblock.F90 +++ b/src/ecwam/outblock.F90 @@ -16,7 +16,7 @@ SUBROUTINE OUTBLOCK (KIJS, KIJL, MIJ, & & TAUXD, TAUYD, TAUOCXD, & & TAUOCYD, TAUOC, & & TAUICX, TAUICY, PHIOCD, & - & PHIEPS, PHIAW, & + & PHIEPS, PHIAW, UPROXY, & & AIRD, WDWAVE, CICOVER, & & WSWAVE, WSTAR, & & UFRIC, TAUW, & @@ -110,7 +110,7 @@ SUBROUTINE OUTBLOCK (KIJS, KIJL, MIJ, & REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: IBRMEM REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: AIRD, WDWAVE, CICOVER, WSWAVE, WSTAR - REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: UFRIC, TAUW, Z0M, Z0B, CHRNCK, CITHICK + REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: UFRIC, UPROXY, TAUW, Z0M, Z0B, CHRNCK, CITHICK REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: ALTWH, CALTWH, RALTCOR, USTOKES, VSTOKES, STRNMS REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: TAUXD, TAUYD, TAUOCXD, TAUOCYD, TAUOC, PHIOCD REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: TAUICX, TAUICY @@ -575,7 +575,8 @@ SUBROUTINE OUTBLOCK (KIJS, KIJL, MIJ, & ENDIF IF (IPFGTBL(66 + 3*NTRAIN + NTEWH) /= 0) THEN - BOUT(KIJS:KIJL,ITOBOUT(66 + 3*NTRAIN + NTEWH))=HMAX_ST(KIJS:KIJL) + ! BOUT(KIJS:KIJL,ITOBOUT(66 + 3*NTRAIN + NTEWH))=HMAX_ST(KIJS:KIJL) + BOUT(KIJS:KIJL,ITOBOUT(66 + 3*NTRAIN + NTEWH))=UPROXY(KIJS:KIJL) ! josh hack ENDIF IF (IPFGTBL(67 + 3*NTRAIN + NTEWH) /= 0) THEN diff --git a/src/ecwam/outbs.F90 b/src/ecwam/outbs.F90 index 317ec1103..da3f80a8f 100644 --- a/src/ecwam/outbs.F90 +++ b/src/ecwam/outbs.F90 @@ -106,7 +106,7 @@ SUBROUTINE OUTBS (MIJ, FL1, XLLWS, & & INTFLDS%TAUXD(:,ICHNK), INTFLDS%TAUYD(:,ICHNK), INTFLDS%TAUOCXD(:,ICHNK), & & INTFLDS%TAUOCYD(:,ICHNK), INTFLDS%TAUOC(:,ICHNK), & & INTFLDS%TAUICX(:,ICHNK), INTFLDS%TAUICY(:,ICHNK), INTFLDS%PHIOCD(:,ICHNK), & - & INTFLDS%PHIEPS(:,ICHNK), INTFLDS%PHIAW(:,ICHNK), & + & INTFLDS%PHIEPS(:,ICHNK), INTFLDS%PHIAW(:,ICHNK), INTFLDS%UPROXY(:,ICHNK), & & FF_NOW%AIRD(:,ICHNK), FF_NOW%WDWAVE(:,ICHNK), FF_NOW%CICOVER(:,ICHNK), & & FF_NOW%WSWAVE(:,ICHNK), FF_NOW%WSTAR(:,ICHNK), & & FF_NOW%UFRIC(:,ICHNK), FF_NOW%TAUW(:,ICHNK), & diff --git a/src/ecwam/outbs_loki_gpu.F90 b/src/ecwam/outbs_loki_gpu.F90 index a0336a04b..66a517ad6 100644 --- a/src/ecwam/outbs_loki_gpu.F90 +++ b/src/ecwam/outbs_loki_gpu.F90 @@ -112,7 +112,7 @@ SUBROUTINE OUTBS_LOKI_GPU (MIJ, FL1, XLLWS, & & INTFLDS%TAUXD(:,ICHNK), INTFLDS%TAUYD(:,ICHNK), INTFLDS%TAUOCXD(:,ICHNK), & & INTFLDS%TAUOCYD(:,ICHNK), INTFLDS%TAUOC(:,ICHNK), & & INTFLDS%TAUICX(:,ICHNK), INTFLDS%TAUICY(:,ICHNK), INTFLDS%PHIOCD(:,ICHNK), & - & INTFLDS%PHIEPS(:,ICHNK), INTFLDS%PHIAW(:,ICHNK), & + & INTFLDS%PHIEPS(:,ICHNK), INTFLDS%PHIAW(:,ICHNK), INTFLDS%UPROXY(:,ICHNK), & & FF_NOW%AIRD(:,ICHNK), FF_NOW%WDWAVE(:,ICHNK), FF_NOW%CICOVER(:,ICHNK), & & FF_NOW%WSWAVE(:,ICHNK), FF_NOW%WSTAR(:,ICHNK), & & FF_NOW%UFRIC(:,ICHNK), FF_NOW%TAUW(:,ICHNK), & diff --git a/src/ecwam/outstep0.F90 b/src/ecwam/outstep0.F90 index a99d946e1..5e00e51b3 100644 --- a/src/ecwam/outstep0.F90 +++ b/src/ecwam/outstep0.F90 @@ -126,7 +126,7 @@ SUBROUTINE OUTSTEP0 (WVENVI, WVPRPT, FF_NOW, INTFLDS, & & INTFLDS%TAUXD(:,ICHNK), INTFLDS%TAUYD(:,ICHNK), INTFLDS%TAUOCXD(:,ICHNK), & & INTFLDS%TAUOCYD(:,ICHNK), INTFLDS%TAUOC(:,ICHNK), & & INTFLDS%TAUICX(:,ICHNK), INTFLDS%TAUICY(:,ICHNK), INTFLDS%PHIOCD(:,ICHNK), & - & INTFLDS%PHIEPS(:,ICHNK), INTFLDS%PHIAW(:,ICHNK), & + & INTFLDS%PHIEPS(:,ICHNK), INTFLDS%PHIAW(:,ICHNK), INTFLDS%UPROXY(:,ICHNK), & & WAM2NEMO%NEMOUSTOKES(:,ICHNK), WAM2NEMO%NEMOVSTOKES(:,ICHNK), WAM2NEMO%NEMOSTRN(:,ICHNK), & & WAM2NEMO%NPHIEPS(:,ICHNK), WAM2NEMO%NTAUOC(:,ICHNK), WAM2NEMO%NSWH(:,ICHNK), & & WAM2NEMO%NMWP(:,ICHNK), WAM2NEMO%NEMOTAUX(:,ICHNK), WAM2NEMO%NEMOTAUY(:,ICHNK), & diff --git a/src/ecwam/sinflx.F90 b/src/ecwam/sinflx.F90 index fae260b24..6e93f4d68 100644 --- a/src/ecwam/sinflx.F90 +++ b/src/ecwam/sinflx.F90 @@ -16,7 +16,7 @@ SUBROUTINE SINFLX (ICALL, NCALL, KIJS, KIJL, & & COSWDIF, SINWDIF2, & & FMEAN, HALP, FMEANWS, & & FLM, & - & UFRIC, TAUW, TAUWDIR, & + & UFRIC, UPROXY, TAUW, TAUWDIR, & & Z0M, Z0B, CHRNCK, PHIWA, & & FLD, SL, SPOS, & & MIJ, RHOWGDFTH, XLLWS) @@ -68,6 +68,7 @@ SUBROUTINE SINFLX (ICALL, NCALL, KIJS, KIJL, & REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(OUT) :: FMEANWS !! MEAN FREQUENCY OF THE WINDSEA. REAL(KIND=JWRB), DIMENSION(KIJL,NANG), INTENT(IN) :: FLM !! SPECTAL DENSITY MINIMUM VALUE REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: UFRIC !! FRICTION VELOCITY IN M/S. +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: UPROXY !! FRICTION VELOCITY IN M/S. REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: TAUW !! WAVE STRESS IN (M/S)**2 REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: TAUWDIR !! WAVE STRESS DIRECTION. REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: Z0M !! ROUGHNESS LENGTH IN M. @@ -124,7 +125,7 @@ SUBROUTINE SINFLX (ICALL, NCALL, KIJS, KIJL, & & COSWDIF, SINWDIF2, & & FMEAN, HALP, FMEANWS, & & FLM, & - & UFRIC, TAUW, TAUWDIR, & + & UFRIC, UPROXY, TAUW, TAUWDIR, & & Z0M, Z0B, CHRNCK, PHIWA, & & FLD, SL, SPOS, & & MIJ, RHOWGDFTH, XLLWS) diff --git a/src/ecwam/sinflx_zbry.F90 b/src/ecwam/sinflx_zbry.F90 index 0797f1531..8a044c860 100644 --- a/src/ecwam/sinflx_zbry.F90 +++ b/src/ecwam/sinflx_zbry.F90 @@ -16,7 +16,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, KIJS, KIJL, & & COSWDIF, SINWDIF2, & & FMEAN, HALP, FMEANWS, & & FLM, & - & UFRIC, TAUW, TAUWDIR, & + & UFRIC, UPROXY, TAUW, TAUWDIR, & & Z0M, Z0B, CHRNCK, PHIWA, & & FLD, SL, SPOS, & & MIJ, RHOWGDFTH, XLLWS) @@ -149,6 +149,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, KIJS, KIJL, & REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(OUT) :: FMEANWS !! MEAN FREQUENCY OF THE WINDSEA. REAL(KIND=JWRB), DIMENSION(KIJL,NANG), INTENT(IN) :: FLM !! SPECTAL DENSITY MINIMUM VALUE REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: UFRIC !! FRICTION VELOCITY IN M/S. +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: UPROXY !! FRICTION VELOCITY IN M/S. REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: TAUW !! WAVE STRESS IN (M/S)**2 REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: TAUWDIR !! WAVE STRESS DIRECTION. REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: Z0M !! ROUGHNESS LENGTH IN M. @@ -167,7 +168,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, KIJS, KIJL, & REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(OUT) :: XLLWS !! TOTAL WINDSEA MASK FROM INPUT SOURCE TERM. INTEGER(KIND=JWIM) :: IUSFG, ICODE_WND -INTEGER(KIND=JWIM), PARAMETER :: NGST=2 +INTEGER(KIND=JWIM), PARAMETER :: NGST=1 REAL(KIND=JPHOOK) :: ZHOOK_HANDLE REAL(KIND=JWRB), DIMENSION(KIJL) :: RNFAC @@ -194,7 +195,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, KIJS, KIJL, & REAL(KIND=JWRB), DIMENSION(NGST) :: TAUWX, TAUWY ! Component of the wave-supported stress REAL(KIND=JWRB), DIMENSION(NGST) :: TAUNWX, TAUNWY ! Component of the neg. wave-supported stress REAL(KIND=JWRB) :: COSU, SINU -REAL(KIND=JWRB), DIMENSION(NGST) :: UPROXY +REAL(KIND=JWRB), DIMENSION(NGST) :: UPROXYGST REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: XK, CGG_WAM, CM REAL(KIND=JWRB), DIMENSION(NFRE) :: SIGP2, SIGM1 @@ -222,7 +223,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, KIJS, KIJL, & ! For GUSTINESS REAL(KIND=JWRB) :: AVG_GST -REAL(KIND=JWRB), DIMENSION(KIJL) :: SIG_N, SIG_U10, TAUWGST_AVG, TAUWDIRGST_AVG, TAUNWGST_AVG, USTARGST_AVG +REAL(KIND=JWRB), DIMENSION(KIJL) :: SIG_N, SIG_U10, TAUWGST_AVG, TAUWDIRGST_AVG, TAUNWGST_AVG, USTARGST_AVG, UPROXYGST_AVG REAL(KIND=JWRB), DIMENSION(KIJL,NGST) :: TAUWGST, TAUWDIRGST, TAUNWGST, UABSGST, USTARGST, Z0GST REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE) :: SLGST_AVG, SPOSGST_AVG, FLGST_AVG REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE,NGST) :: SLGST, SPOSGST, FLGST @@ -423,11 +424,11 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, KIJS, KIJL, & DO IGST=1,NGST SELECT CASE (IPHYS2_AIRSEA) CASE(0) - UPROXY(IGST) = 32.0_JWRB * CDFAC * USTARGST(IJ,IGST) ! original, suggested by E. Rogers (2014) (young seas) + UPROXYGST(IGST) = 32.0_JWRB * CDFAC * USTARGST(IJ,IGST) ! original, suggested by E. Rogers (2014) (young seas) CASE(1) - UPROXY(IGST) = FRIC * CDFAC * USTARGST(IJ,IGST) ! following Komen et al. (1984) (developed seas) (FRIC=28) + UPROXYGST(IGST) = FRIC * CDFAC * USTARGST(IJ,IGST) ! following Komen et al. (1984) (developed seas) (FRIC=28) CASE(2) - UPROXY(IGST) = UABSGST(IJ,IGST) * CDFAC ! because FRIC=1/sqrt(CD), then this turns to purely a wind dependence (USTARGST cancels out) + UPROXYGST(IGST) = UABSGST(IJ,IGST) * CDFAC ! because FRIC=1/sqrt(CD), then this turns to purely a wind dependence (USTARGST cancels out) END SELECT ENDDO ! @@ -470,7 +471,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, KIJS, KIJL, & !/ complement one another. ------------------------------------ / DO IGST=1,NGST W1(:,IGST)= MAX(0.0_JWRB, & - & UPROXY(IGST)*CINV2*(ECOS2*COSU + ESIN2*SINU) - 1.0_JWRB)**2 + & UPROXYGST(IGST)*CINV2*(ECOS2*COSU + ESIN2*SINU) - 1.0_JWRB)**2 ! D(:,IGST) = (RAORW(IJ) ) * SIG2 * & (2.8_JWRB-(1.0_JWRB+TANH(10.0_JWRB*SQRTBN2*W1(:,IGST)-11.0_JWRB)))*& @@ -516,7 +517,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, KIJS, KIJL, & !/ ww3_grid.inp: '&SIN6 SINA0 = 0.04 /' ----------------------- / DO IGST=1,NGST IF (SIN6A0.GT.0.0_JWRB) THEN - W2(:,IGST) = MIN( 0.0_JWRB,UPROXY(IGST) * CINV2* & + W2(:,IGST) = MIN( 0.0_JWRB,UPROXYGST(IGST) * CINV2* & & (ECOS2*COSU + ESIN2*SINU) - 1.0_JWRB )**2 D(:,IGST) = D(:,IGST) - ( RAORW(IJ) * SIG2 * SIN6A0 * & (2.8_JWRB-(1.0_JWRB+TANH(10.0_JWRB*SQRTBN2*W2(:,IGST) - 11.0_JWRB)))& @@ -538,7 +539,12 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, KIJS, KIJL, & TAUWGST(IJ,IGST) = SQRT(TAUWX(IGST)**2+TAUWY(IGST)**2) / ROAIRN(IJ) ! KINEMATIC TAUW TAUWDIRGST(IJ,IGST) = ATAN2(TAUWX(IGST),TAUWY(IGST)) TAUNWGST(IJ,IGST) = SQRT(TAUNWX(IGST)**2+TAUNWY(IGST)**2) / ROAIRN(IJ) ! KINEMATIC TAUNW - USTARGST(IJ,IGST) = SQRT(TAU(IJ,IGST) / ROAIRN(IJ) ) + SELECT CASE (IPHYS2_AIRSEA) + ! CASE(0) + ! USTARGST(IJ,IGST) = USTARGST(IJ,IGST) ! i.e. do nothing here, don't update, inherent but not explicitly done in ST6 + CASE(1,2) + USTARGST(IJ,IGST) = SQRT(TAU(IJ,IGST) / ROAIRN(IJ) ) + END SELECT ENDDO ! 8) --- Calculate SL, FL and SPOS needed for ecWAM ------------- / @@ -559,6 +565,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, KIJS, KIJL, & TAUWDIRGST_AVG(IJ) = TAUWDIRGST(IJ,IGST) TAUNWGST_AVG(IJ) = TAUNWGST(IJ,IGST) USTARGST_AVG(IJ) = USTARGST(IJ,IGST) + UPROXYGST_AVG(IJ) = UPROXYGST(IGST) SLGST_AVG(IJ,:,:) = SLGST(IJ,:,:,IGST) SPOSGST_AVG(IJ,:,:) = SPOSGST(IJ,:,:,IGST) FLGST_AVG(IJ,:,:) = FLGST(IJ,:,:,IGST) @@ -567,6 +574,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, KIJS, KIJL, & TAUWDIRGST_AVG(IJ) = TAUWDIRGST_AVG(IJ) + TAUWDIRGST(IJ,IGST) TAUNWGST_AVG(IJ) = TAUNWGST_AVG(IJ) + TAUNWGST(IJ,IGST) USTARGST_AVG(IJ) = USTARGST_AVG(IJ) + USTARGST(IJ,IGST) + UPROXYGST_AVG(IJ) = UPROXYGST_AVG(IJ) + UPROXYGST(IGST) SLGST_AVG(IJ,:,:) = SLGST_AVG(IJ,:,:) + SLGST(IJ,:,:,IGST) SPOSGST_AVG(IJ,:,:) = SPOSGST_AVG(IJ,:,:) + SPOSGST(IJ,:,:,IGST) FLGST_AVG(IJ,:,:) = FLGST_AVG(IJ,:,:) + FLGST(IJ,:,:,IGST) @@ -575,6 +583,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, KIJS, KIJL, & TAUWDIR(IJ) = AVG_GST*TAUWDIRGST_AVG(IJ) TAUNW(IJ) = AVG_GST*TAUNWGST_AVG(IJ) UFRIC(IJ) = AVG_GST*USTARGST_AVG(IJ) + UPROXY(IJ) = AVG_GST*UPROXYGST_AVG(IJ) SL(IJ,:,:) = AVG_GST*SLGST_AVG(IJ,:,:) SPOS(IJ,:,:) = AVG_GST*SPOSGST_AVG(IJ,:,:) FLD(IJ,:,:) = AVG_GST*FLGST_AVG(IJ,:,:) diff --git a/src/ecwam/wamintgr.F90 b/src/ecwam/wamintgr.F90 index ac1cf6041..8d3e9ef5b 100644 --- a/src/ecwam/wamintgr.F90 +++ b/src/ecwam/wamintgr.F90 @@ -139,7 +139,7 @@ SUBROUTINE WAMINTGR (CDTPRA, CDATE, CDATEWH, CDTIMP, CDTIMPNEXT, & & INTFLDS%TAUXD(:,ICHNK), INTFLDS%TAUYD(:,ICHNK), INTFLDS%TAUOCXD(:,ICHNK), & & INTFLDS%TAUOCYD(:,ICHNK), INTFLDS%TAUOC(:,ICHNK), & & INTFLDS%TAUICX(:,ICHNK), INTFLDS%TAUICY(:,ICHNK), INTFLDS%PHIOCD(:,ICHNK), & - & INTFLDS%PHIEPS(:,ICHNK), INTFLDS%PHIAW(:,ICHNK), & + & INTFLDS%PHIEPS(:,ICHNK), INTFLDS%PHIAW(:,ICHNK), INTFLDS%UPROXY(:,ICHNK), & & MIJ%PTR(:,ICHNK), VARS_4D%XLLWS(:,:,:,ICHNK) ) ENDDO diff --git a/src/ecwam/wamintgr_loki_gpu.F90 b/src/ecwam/wamintgr_loki_gpu.F90 index 2c139b197..4237185b1 100644 --- a/src/ecwam/wamintgr_loki_gpu.F90 +++ b/src/ecwam/wamintgr_loki_gpu.F90 @@ -184,7 +184,7 @@ SUBROUTINE WAMINTGR_LOKI_GPU(CDTPRA, CDATE, CDATEWH, CDTIMP, CDTIMPNEXT, & & INTFLDS%TAUXD(:,ICHNK), INTFLDS%TAUYD(:,ICHNK), INTFLDS%TAUOCXD(:,ICHNK), & & INTFLDS%TAUOCYD(:,ICHNK), INTFLDS%TAUOC(:,ICHNK), & & INTFLDS%TAUICX(:,ICHNK), INTFLDS%TAUICY(:,ICHNK), INTFLDS%PHIOCD(:,ICHNK), & - & INTFLDS%PHIEPS(:,ICHNK), INTFLDS%PHIAW(:,ICHNK), & + & INTFLDS%PHIEPS(:,ICHNK), INTFLDS%PHIAW(:,ICHNK), INTFLDS%UPROXY(:,ICHNK), & & MIJ%PTR(:,ICHNK), VARS_4D%XLLWS(:,:,:,ICHNK) ) END DO diff --git a/src/ecwam/wdfluxes.F90 b/src/ecwam/wdfluxes.F90 index e43ed67ea..cf8e0ae06 100644 --- a/src/ecwam/wdfluxes.F90 +++ b/src/ecwam/wdfluxes.F90 @@ -23,7 +23,7 @@ SUBROUTINE WDFLUXES (KIJS, KIJL, & & USTOKES, VSTOKES, STRNMS, & & TAUXD, TAUYD, TAUOCXD, & & TAUOCYD, TAUOC, TAUICX, TAUICY, & - & PHIOCD, PHIEPS, PHIAW, & + & PHIOCD, PHIEPS, PHIAW, UPROXY, & & NEMOUSTOKES, NEMOVSTOKES, NEMOSTRN, & & NPHIEPS, NTAUOC, NSWH, & & NMWP,NEMOTAUX, NEMOTAUY, & @@ -107,7 +107,7 @@ SUBROUTINE WDFLUXES (KIJS, KIJL, & REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: AIRD, WSTAR REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: USTRA, VSTRA REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: CICOVER - REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: UFRIC, Z0M, Z0B, CHRNCK, CITHICK + REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: UFRIC, UPROXY, Z0M, Z0B, CHRNCK, CITHICK REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: TAUXD, TAUYD, TAUOCXD, TAUOCYD, TAUOC REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: TAUICX, TAUICY REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: PHIOCD, PHIEPS, PHIAW, USTOKES, VSTOKES @@ -209,7 +209,7 @@ SUBROUTINE WDFLUXES (KIJS, KIJL, & & COSWDIF, SINWDIF2, & & FMEAN, HALP, FMEANWS, & & FLM, & - & UFRIC, TAUW_LOC, TAUWDIR_LOC, & + & UFRIC, UPROXY, TAUW_LOC, TAUWDIR_LOC, & & Z0M, Z0B, CHRNCK, PHIWA, & & FLD, SL, SPOS, & & MIJ, RHOWGDFTH, XLLWS) diff --git a/src/ecwam/yowdrvtype_config.yml b/src/ecwam/yowdrvtype_config.yml index 011089c3c..8a11e8ec7 100644 --- a/src/ecwam/yowdrvtype_config.yml +++ b/src/ecwam/yowdrvtype_config.yml @@ -31,7 +31,7 @@ objtypes: intgt_param_fields: rank: 2 types: [real] - vars: [[wsemean, wsfmean, ustokes, vstokes, phieps, phiocd, phiaw, tauoc, tauxd, tauyd, + vars: [[wsemean, wsfmean, ustokes, vstokes, phieps, phiocd, phiaw, uproxy, tauoc, tauxd, tauyd, tauocxd, tauocyd, tauicx, tauicy, strnms, altwh, caltwh, raltcor]] wvgridglo: rank: 1 diff --git a/tests/etopo1_oper_an_fc_O48_cy50r1_zbry.yml b/tests/etopo1_oper_an_fc_O48_cy50r1_zbry.yml new file mode 100644 index 000000000..28d06c6f8 --- /dev/null +++ b/tests/etopo1_oper_an_fc_O48_cy50r1_zbry.yml @@ -0,0 +1,129 @@ +grid: O48 +directions: 12 +frequencies: 25 +bathymetry: ETOPO1 +iphys: 2 + +advection: + timestep: 900 +physics: + timestep: 900 + +analysis.begin: 2022-12-31 12:00:00 +analysis.end: 2023-01-01 00:00:00 +forecast.begin: 2023-01-01 00:00:00 +forecast.end: 2023-01-01 06:00:00 + +begin: ${analysis.begin} +end: ${forecast.end} + +nproma: 32 +llgcbz0: T +llnormagam: T +lciwa3: T +lciscal: T + +forcings: + file: data/forcings/oper_an_12h_fc_2023010100_36h_O48.grib + + at: + - begin: ${analysis.begin} + end: ${analysis.end} + timestep: 06:00 + - begin: ${forecast.begin} + end: ${forecast.end} + timestep: 01:00 + +output: + fields: + name: + - swh # Significant height of combined wind waves and swell + - mwd # Mean wave direction + - mwp # Mean wave period + - pp1d # Peak wave period + - dwi # 10 metre wind direction + - cdww # Coefficient of drag with waves + - wind # 10 metre wind speed + - ust # U-component stokes stress + - vst # V-component stokes stress + - '075' # utauo + - '076' # vtauo + - '077' # wphio + - '081' # uproxy + format: grib # (default : grib) or binary + at: + - timestep: 01:00 + + restart: + format: binary # (default : binary) or grib + at: + - time: ${end} + + +validation: + + double_precision: + + # initial analysis time + - name: swh + time: 2022-12-31 12:00:00 + average: 0.1337362278436861E+01 + relative_tolerance: 1.e-14 + hashes: ['0x3FF565D5FD0CA556'] + + # initial forecast time + - name: swh + time: 2023-01-01 00:00:00 + average: 0.1549542256416082E+01 + relative_tolerance: 1.e-14 + hashes: ['0x3FF8CAECD2313BDF'] + + # 6h into forecast + - name: swh + time: 2023-01-01 06:00:00 + average: 0.1632449648145021E+01 + relative_tolerance: 1.e-14 + hashes: ['0x3FFA1E8385B264A5'] + - name: swh + time: 2023-01-01 06:00:00 + minimum: 0.1905182728883706E-01 + relative_tolerance: 1.e-14 + hashes: ['0x3F9382527C89D368'] + - name: swh + time: 2023-01-01 06:00:00 + maximum: 0.6807117063618366E+01 + relative_tolerance: 1.e-14 + hashes: ['0x401B3A7CE5412342'] + + single_precision: + + # initial analysis time + - name: swh + time: 2022-12-31 12:00:00 + average: 0.1337408304214478E+01 + relative_tolerance: 1.e-6 + hashes: ['0x3FF5660640000000'] + + # initial forecast time + - name: swh + time: 2023-01-01 00:00:00 + average: 0.1549576163291931E+01 + relative_tolerance: 1.e-6 + hashes: ['0x3FF8CB1060000000'] + + # 6h into forecast + - name: swh + time: 2023-01-01 06:00:00 + average: 0.1632413744926453E+01 + relative_tolerance: 1.e-6 + hashes: ['0x3FFA1E5DE0000000'] + - name: swh + time: 2023-01-01 06:00:00 + minimum: 0.1905178464949131E-01 + relative_tolerance: 1.e-6 + hashes: ['0x3F93824FA0000000'] + - name: swh + time: 2023-01-01 06:00:00 + maximum: 0.6807114124298096E+01 + relative_tolerance: 1.e-6 + hashes: ['0x401B3A7C20000000'] From 428dbf601b12b22c8ec63e5b8499dae2cd63cf5e Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Tue, 14 Oct 2025 15:27:15 +0000 Subject: [PATCH 22/89] bydbr config file replaced with zbry --- tests/etopo1_oper_an_fc_O48_cy50r1_bydbr.yml | 128 ------------------- 1 file changed, 128 deletions(-) delete mode 100644 tests/etopo1_oper_an_fc_O48_cy50r1_bydbr.yml diff --git a/tests/etopo1_oper_an_fc_O48_cy50r1_bydbr.yml b/tests/etopo1_oper_an_fc_O48_cy50r1_bydbr.yml deleted file mode 100644 index de9145a4b..000000000 --- a/tests/etopo1_oper_an_fc_O48_cy50r1_bydbr.yml +++ /dev/null @@ -1,128 +0,0 @@ -grid: O48 -directions: 12 -frequencies: 25 -bathymetry: ETOPO1 -iphys: 2 - -advection: - timestep: 900 -physics: - timestep: 900 - -analysis.begin: 2022-12-31 12:00:00 -analysis.end: 2023-01-01 00:00:00 -forecast.begin: 2023-01-01 00:00:00 -forecast.end: 2023-01-01 06:00:00 - -begin: ${analysis.begin} -end: ${forecast.end} - -nproma: 32 -llgcbz0: T -llnormagam: T -lciwa3: T -lciscal: T - -forcings: - file: data/forcings/oper_an_12h_fc_2023010100_36h_O48.grib - - at: - - begin: ${analysis.begin} - end: ${analysis.end} - timestep: 06:00 - - begin: ${forecast.begin} - end: ${forecast.end} - timestep: 01:00 - -output: - fields: - name: - - swh # Significant height of combined wind waves and swell - - mwd # Mean wave direction - - mwp # Mean wave period - - pp1d # Peak wave period - - dwi # 10 metre wind direction - - cdww # Coefficient of drag with waves - - wind # 10 metre wind speed - - ust # U-component stokes stress - - vst # V-component stokes stress - - '075' # utauo - - '076' # vtauo - - '077' # wphio - format: grib # (default : grib) or binary - at: - - timestep: 01:00 - - restart: - format: binary # (default : binary) or grib - at: - - time: ${end} - - -validation: - - double_precision: - - # initial analysis time - - name: swh - time: 2022-12-31 12:00:00 - average: 0.1337362278436861E+01 - relative_tolerance: 1.e-14 - hashes: ['0x3FF565D5FD0CA556'] - - # initial forecast time - - name: swh - time: 2023-01-01 00:00:00 - average: 0.1549542256416082E+01 - relative_tolerance: 1.e-14 - hashes: ['0x3FF8CAECD2313BDF'] - - # 6h into forecast - - name: swh - time: 2023-01-01 06:00:00 - average: 0.1632449648145021E+01 - relative_tolerance: 1.e-14 - hashes: ['0x3FFA1E8385B264A5'] - - name: swh - time: 2023-01-01 06:00:00 - minimum: 0.1905182728883706E-01 - relative_tolerance: 1.e-14 - hashes: ['0x3F9382527C89D368'] - - name: swh - time: 2023-01-01 06:00:00 - maximum: 0.6807117063618366E+01 - relative_tolerance: 1.e-14 - hashes: ['0x401B3A7CE5412342'] - - single_precision: - - # initial analysis time - - name: swh - time: 2022-12-31 12:00:00 - average: 0.1337408304214478E+01 - relative_tolerance: 1.e-6 - hashes: ['0x3FF5660640000000'] - - # initial forecast time - - name: swh - time: 2023-01-01 00:00:00 - average: 0.1549576163291931E+01 - relative_tolerance: 1.e-6 - hashes: ['0x3FF8CB1060000000'] - - # 6h into forecast - - name: swh - time: 2023-01-01 06:00:00 - average: 0.1632413744926453E+01 - relative_tolerance: 1.e-6 - hashes: ['0x3FFA1E5DE0000000'] - - name: swh - time: 2023-01-01 06:00:00 - minimum: 0.1905178464949131E-01 - relative_tolerance: 1.e-6 - hashes: ['0x3F93824FA0000000'] - - name: swh - time: 2023-01-01 06:00:00 - maximum: 0.6807114124298096E+01 - relative_tolerance: 1.e-6 - hashes: ['0x401B3A7C20000000'] From 06abc336ff930fda9846059365e90166b9ade046 Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Tue, 14 Oct 2025 17:02:52 +0000 Subject: [PATCH 23/89] small tidy --- src/ecwam/mpuserin.F90 | 2 +- src/ecwam/sinflx_zbry.F90 | 17 +++-------------- 2 files changed, 4 insertions(+), 15 deletions(-) diff --git a/src/ecwam/mpuserin.F90 b/src/ecwam/mpuserin.F90 index 86d622565..d96313ba3 100644 --- a/src/ecwam/mpuserin.F90 +++ b/src/ecwam/mpuserin.F90 @@ -605,7 +605,7 @@ SUBROUTINE MPUSERIN ICASE = 1 ISHALLO = 0 !! depricated IPHYS = 1 - IPHYS2_AIRSEA = 0 !0=~ST6, 1=iterative, 2=based only on wind! + IPHYS2_AIRSEA = 2 !0=~ST6, 1=iterative, 2=based only on wind! ISNONLIN = 1 IDAMPING = 1 IPROPAGS = 0 diff --git a/src/ecwam/sinflx_zbry.F90 b/src/ecwam/sinflx_zbry.F90 index 8a044c860..9cb240081 100644 --- a/src/ecwam/sinflx_zbry.F90 +++ b/src/ecwam/sinflx_zbry.F90 @@ -168,7 +168,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, KIJS, KIJL, & REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(OUT) :: XLLWS !! TOTAL WINDSEA MASK FROM INPUT SOURCE TERM. INTEGER(KIND=JWIM) :: IUSFG, ICODE_WND -INTEGER(KIND=JWIM), PARAMETER :: NGST=1 +INTEGER(KIND=JWIM), PARAMETER :: NGST=2 REAL(KIND=JPHOOK) :: ZHOOK_HANDLE REAL(KIND=JWRB), DIMENSION(KIJL) :: RNFAC @@ -306,9 +306,6 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, KIJS, KIJL, & END DO ! TODO: clean up stuff in/out of IJ loops (sdissip_zbry + swldissip ) -! TODO: confirm that I'm using exactly the same things here (I've now adopted them throughout the ZBRY code) -! - confirm CGG_WAM=CGROUP -! - confirm XK=WAVNUM DO M=1,NFRE DO IJ=KIJS,KIJL @@ -351,7 +348,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, KIJS, KIJL, & WRITE (IU06,*) '**************************************' WRITE (IU06,*) '* FATAL ERROR *' WRITE (IU06,*) '* =========== *' - WRITE (IU06,*) '* IN SINPUT_ARD: NGST > 2 *' + WRITE (IU06,*) '* IN SINFLX_ZBRY: NGST > 2 *' WRITE (IU06,*) '* NGST = ', NGST WRITE (IU06,*) '* PROGRAM ABORTS. PROGRAM ABORTS. *' WRITE (IU06,*) '* *' @@ -375,14 +372,6 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, KIJS, KIJL, & ENDDO ! IJ loop ENDDO ENDDO ! NGST loop ENDDO -! Define UABSGST associated with USTARGST and Z0GST -! U10 = (u*/kappa) log (1 + Z/Z0), z=10 -! DO IGST=1,NGST -! DO IJ=KIJS,KIJL -! UABSGST(IJ,IGST) = USTARGST(IJ,IGST)*LOG(1.0_JWRB + ZNLEV/Z0GST(IJ,IGST))/XKAPPA -! END DO -! END DO - !/ --- Main loop over LOC ----------------------------------- / @@ -541,7 +530,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, KIJS, KIJL, & TAUNWGST(IJ,IGST) = SQRT(TAUNWX(IGST)**2+TAUNWY(IGST)**2) / ROAIRN(IJ) ! KINEMATIC TAUNW SELECT CASE (IPHYS2_AIRSEA) ! CASE(0) - ! USTARGST(IJ,IGST) = USTARGST(IJ,IGST) ! i.e. do nothing here, don't update, inherent but not explicitly done in ST6 + ! USTARGST(IJ,IGST) = USTARGST(IJ,IGST) ! i.e. do nothing here, don't update USTAR because it is not true to WW3_ST6 CASE(1,2) USTARGST(IJ,IGST) = SQRT(TAU(IJ,IGST) / ROAIRN(IJ) ) END SELECT From ab7349a986c6ac87e88ceb37c8a6e8780f21bda8 Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Tue, 14 Oct 2025 18:16:02 +0000 Subject: [PATCH 24/89] add low winds parameterization from Mohammed Yasrab --- src/ecwam/implsch.F90 | 2 +- src/ecwam/mpuserin.F90 | 3 ++- src/ecwam/sdissip.F90 | 6 +++--- src/ecwam/sdissip_zbry.F90 | 23 ++++++++++++++--------- src/ecwam/sinflx_zbry.F90 | 13 ++++++++++--- src/ecwam/wdfluxes.F90 | 2 +- src/ecwam/yowphys.F90 | 2 ++ src/ecwam/yowstat.F90 | 1 + 8 files changed, 34 insertions(+), 18 deletions(-) diff --git a/src/ecwam/implsch.F90 b/src/ecwam/implsch.F90 index 0d83a3194..7965b87e4 100644 --- a/src/ecwam/implsch.F90 +++ b/src/ecwam/implsch.F90 @@ -282,7 +282,7 @@ SUBROUTINE IMPLSCH (KIJS, KIJL, FL1, & !$loki inline CALL SDISSIP (KIJS, KIJL, FL1 ,FLD, SL, & - & WAVNUM, CGROUP, XK2CG, & + & WSWAVE, WAVNUM, CGROUP, XK2CG, & & EMEAN, F1MEAN, XKMEAN, & & UFRIC, COSWDIF, RAORW) diff --git a/src/ecwam/mpuserin.F90 b/src/ecwam/mpuserin.F90 index d96313ba3..0f5e7889a 100644 --- a/src/ecwam/mpuserin.F90 +++ b/src/ecwam/mpuserin.F90 @@ -98,7 +98,7 @@ SUBROUTINE MPUSERIN & IDELWO ,IDELALT ,IREST ,IDELRES ,IDELINT , & & IDELBC , & & ICASE ,ISHALLO , & - & IPHYS ,IPHYS2_AIRSEA, & + & IPHYS ,IPHYS2_AIRSEA,IPHYS2_LOWWINDS, & & ISNONLIN , & & IDAMPING , & & LBIWBK , & @@ -606,6 +606,7 @@ SUBROUTINE MPUSERIN ISHALLO = 0 !! depricated IPHYS = 1 IPHYS2_AIRSEA = 2 !0=~ST6, 1=iterative, 2=based only on wind! + IPHYS2_LOWWINDS = .TRUE. ! .TRUE. if low winds are treated differently ISNONLIN = 1 IDAMPING = 1 IPROPAGS = 0 diff --git a/src/ecwam/sdissip.F90 b/src/ecwam/sdissip.F90 index 082baa068..a8f0f5a7b 100644 --- a/src/ecwam/sdissip.F90 +++ b/src/ecwam/sdissip.F90 @@ -8,7 +8,7 @@ ! SUBROUTINE SDISSIP (KIJS, KIJL, FL1, FLD, SL, & - & WAVNUM, CGROUP, XK2CG, & + & WSWAVE, WAVNUM, CGROUP, XK2CG, & & EMEAN, F1MEAN, XKMEAN, & & UFRIC, COSWDIF, RAORW) ! ---------------------------------------------------------------------- @@ -65,7 +65,7 @@ SUBROUTINE SDISSIP (KIJS, KIJL, FL1, FLD, SL, & REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(IN) :: FL1 REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(INOUT) :: FLD, SL REAL(KIND=JWRB), DIMENSION(KIJL,NFRE), INTENT(IN) :: WAVNUM, CGROUP, XK2CG - REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: EMEAN, F1MEAN, XKMEAN + REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: WSWAVE, EMEAN, F1MEAN, XKMEAN REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: UFRIC, RAORW REAL(KIND=JWRB), DIMENSION(KIJL, NANG), INTENT(IN) :: COSWDIF @@ -90,7 +90,7 @@ SUBROUTINE SDISSIP (KIJS, KIJL, FL1, FLD, SL, & CASE(2) !$loki inline CALL SDISSIP_ZBRY (KIJS, KIJL, FL1 ,FLD, SL, & - & WAVNUM, CGROUP, XK2CG, & + & WSWAVE, WAVNUM, CGROUP, XK2CG, & & UFRIC, COSWDIF, RAORW) CALL SWLDISSIP_ZBRY(KIJS, KIJL, FL1 ,FLD, SL, & & WAVNUM, CGROUP, XK2CG, & diff --git a/src/ecwam/sdissip_zbry.F90 b/src/ecwam/sdissip_zbry.F90 index 40ff03fe8..39cdc74d1 100644 --- a/src/ecwam/sdissip_zbry.F90 +++ b/src/ecwam/sdissip_zbry.F90 @@ -8,7 +8,7 @@ ! SUBROUTINE SDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & - & WAVNUM, CGROUP, XK2CG, & + & WSWAVE, WAVNUM, CGROUP, XK2CG, & & UFRIC, COSWDIF, RAORW) ! ---------------------------------------------------------------------- @@ -82,6 +82,7 @@ SUBROUTINE SDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & & SSDSC2 , SSDSC4, SSDSC6, MICHE, SSDSC3, SSDSBRF1, & & BRKPBCOEF ,SSDSC5, NSDSNTH, & & INDICESSAT, SATWEIGHTS + USE YOWSTAT , ONLY : IPHYS2_LOWWINDS USE YOMHOOK , ONLY : LHOOK ,DR_HOOK, JPHOOK @@ -95,7 +96,7 @@ SUBROUTINE SDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(IN) :: FL1 REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(INOUT) :: FLD, SL REAL(KIND=JWRB), DIMENSION(KIJL,NFRE), INTENT(IN) :: WAVNUM, CGROUP, XK2CG - REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: UFRIC, RAORW + REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: WSWAVE, UFRIC, RAORW REAL(KIND=JWRB), DIMENSION(KIJL, NANG), INTENT(IN) :: COSWDIF INTEGER(KIND=JWIM) :: IJ, K, M, I, J, M2, K2, NANGD @@ -233,13 +234,17 @@ SUBROUTINE SDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & !/T6 270 FORMAT (' TEST W3SDS6 : ',A,'(',A,')',':',70E11.3) !/T6 271 FORMAT (' TEST W3SDS6 : Total SDS =',E13.5) - DDS = RESHAPE(D,(/NANG,NFRE/)) - DO M = 1,NFRE - DO K = 1, NANG - SL(IJ,K,M) = SL(IJ,K,M) + DDS(K,M)*FL1(IJ,K,M) - FLD(IJ,K,M) = FLD(IJ,K,M) + DDS(K,M) - END DO - END DO + IF (.NOT. (IPHYS2_LOWWINDS .AND. WSWAVE(IJ)<=5._JWRB)) THEN + ! no dissipation for U10<5m/s (following Muhammad Yasrab's work) + ! i.e. don't update SL and FLD for low winds + DDS = RESHAPE(D,(/NANG,NFRE/)) + DO M = 1,NFRE + DO K = 1, NANG + SL(IJ,K,M) = SL(IJ,K,M) + DDS(K,M)*FL1(IJ,K,M) + FLD(IJ,K,M) = FLD(IJ,K,M) + DDS(K,M) + END DO + END DO + END IF END DO ! END LOOP OVER LOC diff --git a/src/ecwam/sinflx_zbry.F90 b/src/ecwam/sinflx_zbry.F90 index 9cb240081..fe9b765a1 100644 --- a/src/ecwam/sinflx_zbry.F90 +++ b/src/ecwam/sinflx_zbry.F90 @@ -103,10 +103,10 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, KIJS, KIJL, & & RNU ,RNUM, & & SWELLF ,SWELLF2 ,SWELLF3 ,SWELLF4 , SWELLF5, & & SWELLF6 ,SWELLF7 ,SWELLF7M1, Z0RAT ,Z0TUBMAX , & - & ABMIN ,ABMAX, CDFAC, DTHRN_A ,DTHRN_U + & ABMIN ,ABMAX, CDFAC, DTHRN_A ,DTHRN_U, RNU_WATER USE YOWTEST , ONLY : IU06 USE YOWTABL , ONLY : IAB ,SWELLFT - USE YOWSTAT , ONLY : IPHYS2_AIRSEA + USE YOWSTAT , ONLY : IPHYS2_AIRSEA, IPHYS2_LOWWINDS USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK @@ -466,7 +466,14 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, KIJS, KIJL, & (2.8_JWRB-(1.0_JWRB+TANH(10.0_JWRB*SQRTBN2*W1(:,IGST)-11.0_JWRB)))*& & SQRTBN2*W1(:,IGST) ! - S(:,IGST) = D(:,IGST) * A + IF (IPHYS2_LOWWINDS .AND. UABSGST(IJ,IGST)<=1.5_JWRB) THEN + ! Reduce growth rates for low winds (following Muhammad Yasrab's work) + D(:,IGST) = D(:,IGST) - (4._JWRB*(RNU_WATER)*(WAVNUM(IJ,:)**2)) + S(:,IGST) = D(:,IGST) * A + ELSE + S(:,IGST) = D(:,IGST) * A + END IF + ENDDO ! !/ 5) --- calculate reduction factor LFACT using non-directional diff --git a/src/ecwam/wdfluxes.F90 b/src/ecwam/wdfluxes.F90 index cf8e0ae06..e18cc1c7a 100644 --- a/src/ecwam/wdfluxes.F90 +++ b/src/ecwam/wdfluxes.F90 @@ -217,7 +217,7 @@ SUBROUTINE WDFLUXES (KIJS, KIJL, & IF (LCFLX) THEN CALL SDISSIP (KIJS, KIJL, FL1 ,FLD, SL, & - & WAVNUM, CGROUP, XK2CG, & + & WSWAVE, WAVNUM, CGROUP, XK2CG,& & EMEAN, F1MEAN, XKMEAN, & & UFRIC, COSWDIF, RAORW) diff --git a/src/ecwam/yowphys.F90 b/src/ecwam/yowphys.F90 index 6e25332d4..249b33738 100644 --- a/src/ecwam/yowphys.F90 +++ b/src/ecwam/yowphys.F90 @@ -23,6 +23,8 @@ MODULE YOWPHYS REAL(KIND=JWRB) :: RNU ! *RNUM* REDUCED KINEMATIC AIR VISCOSITY FOR MOMENTUM TRANSFER (as RNU) REAL(KIND=JWRB) :: RNUM +! *RNU* WATER VISCOSITY + REAL(KIND=JWRB), PARAMETER :: RNU_WATER=1.31E-6_JWRB ! consistent with DWAT=1000 (assumes 10degC), estimates for this vary ! *PRCHAR* DEFAULT VALUE FOR CHARNOCK REAL(KIND=JWRB) :: PRCHAR diff --git a/src/ecwam/yowstat.F90 b/src/ecwam/yowstat.F90 index dc48eba90..17f0aedd9 100644 --- a/src/ecwam/yowstat.F90 +++ b/src/ecwam/yowstat.F90 @@ -89,6 +89,7 @@ MODULE YOWSTAT LOGICAL :: LSMSSIG_WAM LOGICAL :: LUPDATE_GPU_GLOBALS = .TRUE. LOGICAL :: LUPDATE_GPU_GLOBALS_OUTBS = .TRUE. + LOGICAL :: IPHYS2_LOWWINDS REAL(KIND=JWRB) :: TIME_PROPAG = 0._JWRB REAL(KIND=JWRB) :: TIME_PHYS = 0._JWRB From baefb1cbf62dc7c70e44528f2f1841cd1e869ad4 Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Wed, 15 Oct 2025 09:20:20 +0000 Subject: [PATCH 25/89] rename IPHYS2_LOWWINDS to LLLOWWINDS --- src/ecwam/mpuserin.F90 | 4 ++-- src/ecwam/sdissip_zbry.F90 | 4 ++-- src/ecwam/sinflx_zbry.F90 | 4 ++-- src/ecwam/yowstat.F90 | 1 + 4 files changed, 7 insertions(+), 6 deletions(-) diff --git a/src/ecwam/mpuserin.F90 b/src/ecwam/mpuserin.F90 index 0f5e7889a..aa18d424c 100644 --- a/src/ecwam/mpuserin.F90 +++ b/src/ecwam/mpuserin.F90 @@ -98,7 +98,7 @@ SUBROUTINE MPUSERIN & IDELWO ,IDELALT ,IREST ,IDELRES ,IDELINT , & & IDELBC , & & ICASE ,ISHALLO , & - & IPHYS ,IPHYS2_AIRSEA,IPHYS2_LOWWINDS, & + & IPHYS ,IPHYS2_AIRSEA,LLLOWWINDS, & & ISNONLIN , & & IDAMPING , & & LBIWBK , & @@ -606,7 +606,7 @@ SUBROUTINE MPUSERIN ISHALLO = 0 !! depricated IPHYS = 1 IPHYS2_AIRSEA = 2 !0=~ST6, 1=iterative, 2=based only on wind! - IPHYS2_LOWWINDS = .TRUE. ! .TRUE. if low winds are treated differently + LLLOWWINDS = .TRUE. ! .TRUE. if low winds are treated differently ISNONLIN = 1 IDAMPING = 1 IPROPAGS = 0 diff --git a/src/ecwam/sdissip_zbry.F90 b/src/ecwam/sdissip_zbry.F90 index 39cdc74d1..f2d409e66 100644 --- a/src/ecwam/sdissip_zbry.F90 +++ b/src/ecwam/sdissip_zbry.F90 @@ -82,7 +82,7 @@ SUBROUTINE SDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & & SSDSC2 , SSDSC4, SSDSC6, MICHE, SSDSC3, SSDSBRF1, & & BRKPBCOEF ,SSDSC5, NSDSNTH, & & INDICESSAT, SATWEIGHTS - USE YOWSTAT , ONLY : IPHYS2_LOWWINDS + USE YOWSTAT , ONLY : LLLOWWINDS USE YOMHOOK , ONLY : LHOOK ,DR_HOOK, JPHOOK @@ -234,7 +234,7 @@ SUBROUTINE SDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & !/T6 270 FORMAT (' TEST W3SDS6 : ',A,'(',A,')',':',70E11.3) !/T6 271 FORMAT (' TEST W3SDS6 : Total SDS =',E13.5) - IF (.NOT. (IPHYS2_LOWWINDS .AND. WSWAVE(IJ)<=5._JWRB)) THEN + IF (.NOT. (LLLOWWINDS .AND. WSWAVE(IJ)<=5._JWRB)) THEN ! no dissipation for U10<5m/s (following Muhammad Yasrab's work) ! i.e. don't update SL and FLD for low winds DDS = RESHAPE(D,(/NANG,NFRE/)) diff --git a/src/ecwam/sinflx_zbry.F90 b/src/ecwam/sinflx_zbry.F90 index fe9b765a1..ba7f62943 100644 --- a/src/ecwam/sinflx_zbry.F90 +++ b/src/ecwam/sinflx_zbry.F90 @@ -106,7 +106,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, KIJS, KIJL, & & ABMIN ,ABMAX, CDFAC, DTHRN_A ,DTHRN_U, RNU_WATER USE YOWTEST , ONLY : IU06 USE YOWTABL , ONLY : IAB ,SWELLFT - USE YOWSTAT , ONLY : IPHYS2_AIRSEA, IPHYS2_LOWWINDS + USE YOWSTAT , ONLY : IPHYS2_AIRSEA, LLLOWWINDS USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK @@ -466,7 +466,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, KIJS, KIJL, & (2.8_JWRB-(1.0_JWRB+TANH(10.0_JWRB*SQRTBN2*W1(:,IGST)-11.0_JWRB)))*& & SQRTBN2*W1(:,IGST) ! - IF (IPHYS2_LOWWINDS .AND. UABSGST(IJ,IGST)<=1.5_JWRB) THEN + IF (LLLOWWINDS .AND. UABSGST(IJ,IGST)<=1.5_JWRB) THEN ! Reduce growth rates for low winds (following Muhammad Yasrab's work) D(:,IGST) = D(:,IGST) - (4._JWRB*(RNU_WATER)*(WAVNUM(IJ,:)**2)) S(:,IGST) = D(:,IGST) * A diff --git a/src/ecwam/yowstat.F90 b/src/ecwam/yowstat.F90 index 17f0aedd9..75fe02682 100644 --- a/src/ecwam/yowstat.F90 +++ b/src/ecwam/yowstat.F90 @@ -90,6 +90,7 @@ MODULE YOWSTAT LOGICAL :: LUPDATE_GPU_GLOBALS = .TRUE. LOGICAL :: LUPDATE_GPU_GLOBALS_OUTBS = .TRUE. LOGICAL :: IPHYS2_LOWWINDS + LOGICAL :: LLLOWWINDS REAL(KIND=JWRB) :: TIME_PROPAG = 0._JWRB REAL(KIND=JWRB) :: TIME_PHYS = 0._JWRB From 6ce3296c5edec2cf96b40bf032acaf69acf591c8 Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Wed, 15 Oct 2025 11:51:25 +0000 Subject: [PATCH 26/89] small tidy --- src/ecwam/airsea_zbry.F90 | 10 +++------- src/ecwam/frcutindex_zbry.F90 | 6 ++++-- src/ecwam/mpuserin.F90 | 5 ++++- src/ecwam/outbeta.F90 | 2 +- src/ecwam/sdissip_zbry.F90 | 8 +++----- src/ecwam/setwavphys.F90 | 24 +++++++++++++++--------- src/ecwam/sinflx.F90 | 9 +++++++-- src/ecwam/sinflx_zbry.F90 | 9 +++++---- src/ecwam/swldissip_zbry.F90 | 8 +++----- 9 files changed, 45 insertions(+), 36 deletions(-) diff --git a/src/ecwam/airsea_zbry.F90 b/src/ecwam/airsea_zbry.F90 index 801001d9c..ca80a338f 100644 --- a/src/ecwam/airsea_zbry.F90 +++ b/src/ecwam/airsea_zbry.F90 @@ -14,13 +14,9 @@ SUBROUTINE AIRSEA_ZBRY (KIJS, KIJL, & ! ---------------------------------------------------------------------- !**** *AIRSEA_ZBRY* - DETERMINE TOTAL STRESS IN SURFACE LAYER. - -! P.A.E.M. JANSSEN KNMI AUGUST 1990 -! JEAN BIDLOT ECMWF FEBRUARY 1999 : TAUT is already -! SQRT(TAUT) -! JEAN BIDLOT ECMWF OCTOBER 2004: QUADRATIC STEP FOR -! TAUW - +! +! JOSH KOUSAL & JEAN BIDLOT ECMWF 2023 +! !* PURPOSE. ! -------- diff --git a/src/ecwam/frcutindex_zbry.F90 b/src/ecwam/frcutindex_zbry.F90 index ade10e9e3..2add07b6c 100644 --- a/src/ecwam/frcutindex_zbry.F90 +++ b/src/ecwam/frcutindex_zbry.F90 @@ -5,7 +5,9 @@ SUBROUTINE FRCUTINDEX_ZBRY (KIJS, KIJL, FM, UFRIC, CICOVER, & !**** *FRCUTINDEX_ZBRY* - RETURNS THE LAST FREQUENCY INDEX OF ! PROGNOSTIC PART OF SPECTRUM. - +! +! JOSH KOUSAL & JEAN BIDLOT ECMWF 2023 +! !** INTERFACE. ! ---------- @@ -78,7 +80,7 @@ SUBROUTINE FRCUTINDEX_ZBRY (KIJS, KIJL, FM, UFRIC, CICOVER, & FXFM = SIN6FC FXFM = FXFM * ZPI FXPM = 4.0_JWRB !TODO: 4.0_JWRB is the factor for the tail (is this right) - FXPM = FXPM * G / 28.0_JWRB !TODO: should this be FRIC? + FXPM = FXPM * G / FRIC SIGNK = ZPI*FR(NFRE) DO IJ=KIJS,KIJL diff --git a/src/ecwam/mpuserin.F90 b/src/ecwam/mpuserin.F90 index aa18d424c..37f97bb79 100644 --- a/src/ecwam/mpuserin.F90 +++ b/src/ecwam/mpuserin.F90 @@ -336,6 +336,9 @@ SUBROUTINE MPUSERIN ! IREST: 1 FOR THE PRODUCTION OF RESTART FILE(S). ! IASSI: 1 ASSIMILATION IS DONE IF ANALYSIS RUN. ! IPHYS: WAVE PHYSICS PACKAGE (0 or 1) +! IPHYS2_AIRSEA: 0: AS CLOSE TO WW3-ST6 AS POSSIBLE +! IPHYS2_AIRSEA: 1: ITERATIVE METHOD FOR THE AIR-SEA INTERACTION (U10, USTAR, CHARN, Z0) +! IPHYS2_AIRSEA: 2: USE U10 DIRECTLY TO DRIVE THE WIND INPUT ! ISNONLIN : 0 FOR OLD SNONLIN, 1 FOR NEW SNONLIN, 2 FOR LATEST BASED ON JANSSEN 2018 (ECMWF TM 813). ! IDAMPING : 0 NO WAVE DAMPING, 1 WAVE DAMPING ON. ! ONLY MEANINGFUl FOR IPHYS=0 @@ -605,7 +608,7 @@ SUBROUTINE MPUSERIN ICASE = 1 ISHALLO = 0 !! depricated IPHYS = 1 - IPHYS2_AIRSEA = 2 !0=~ST6, 1=iterative, 2=based only on wind! + IPHYS2_AIRSEA = 2 LLLOWWINDS = .TRUE. ! .TRUE. if low winds are treated differently ISNONLIN = 1 IDAMPING = 1 diff --git a/src/ecwam/outbeta.F90 b/src/ecwam/outbeta.F90 index 15760aafa..5160d343f 100644 --- a/src/ecwam/outbeta.F90 +++ b/src/ecwam/outbeta.F90 @@ -126,7 +126,7 @@ SUBROUTINE OUTBETA (KIJS, KIJL, & ENDDO IF( PRESENT(CD) ) THEN - IF (IPHYS==2 .AND. IPHYS2_AIRSEA==0) THEN ! TODO: implement module for Hwang instead of duplicating it here + IF (IPHYS==2 .AND. IPHYS2_AIRSEA==0) THEN DO IJ = KIJS,KIJL CD(IJ) = (USTAR(IJ)/U10(IJ))**2 ENDDO diff --git a/src/ecwam/sdissip_zbry.F90 b/src/ecwam/sdissip_zbry.F90 index f2d409e66..c9a03b07a 100644 --- a/src/ecwam/sdissip_zbry.F90 +++ b/src/ecwam/sdissip_zbry.F90 @@ -13,11 +13,9 @@ SUBROUTINE SDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & ! ---------------------------------------------------------------------- !**** *SDISSIP_ZBRY* - COMPUTATION OF DISSIPATION SOURCE FUNCTION. - -! LOTFI AOUF METEO FRANCE 2013 -! FABRICE ARDHUIN IFREMER 2013 - - +! +! JOSH KOUSAL & JEAN BIDLOT ECMWF 2023 +! !* PURPOSE. ! -------- ! Observation-based source term for dissipation after Babanin et al. diff --git a/src/ecwam/setwavphys.F90 b/src/ecwam/setwavphys.F90 index ffe588a6d..6058fc11e 100644 --- a/src/ecwam/setwavphys.F90 +++ b/src/ecwam/setwavphys.F90 @@ -27,7 +27,7 @@ SUBROUTINE SETWAVPHYS & ANG_GC_A, ANG_GC_B, ANG_GC_C, & & SWELLF4, SWELLF7, SWELLF7M1, Z0TUBMAX, Z0RAT, & & SSDSC5, CDFAC -USE YOWSTAT , ONLY : IPHYS +USE YOWSTAT , ONLY : IPHYS, IPHYS2_AIRSEA USE YOWTEST , ONLY : IU06 USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK @@ -217,16 +217,22 @@ SUBROUTINE SETWAVPHYS BSWKM=0.425_JWRB + IF (IPHYS2_AIRSEA==0) THEN + ! NGST=1 (handled in SINFLX) + ALPHAPMAX = 1.0_JWRB ! i.e. no cap on max spectral steepness + ELSE IF (IPHYS2_AIRSEA==1 .OR. IPHYS2_AIRSEA==2) THEN + ! NGST=2 (handled in SINFLX) + ALPHAPMAX = 0.031_JWRB ! cap on spectral steepness as in ARD + END IF + ! Not ALL necessarily used in ZBRY physics (TODO: change any others?) ALPHA = 0.0065_JWRB - BETAMAX = 1.40_JWRB - ZALP = 0.008_JWRB - ALPHAPMAX = 0.031_JWRB ! cap on spectral steepness as in ARD -! ALPHAPMAX = 1.0_JWRB ! i.e. no cap on max spectral steepness - TAUWSHELTER=0.25_JWRB - TAILFACTOR=2.5_JWRB - TAILFACTOR_PM=3.0_JWRB - CDFAC=1.0_JWRB + CDFAC = 1.0_JWRB + ! BETAMAX = 1.40_JWRB + ! ZALP = 0.008_JWRB + ! TAUWSHELTER=0.25_JWRB + TAILFACTOR=6.0_JWRB ! SIN6FC = 6.0 from WW3-ST6 + TAILFACTOR_PM=4.0_JWRB ! FXPM = 4.0 from WW3-ST6 ELSE WRITE (IU06,*) '*************************************' diff --git a/src/ecwam/sinflx.F90 b/src/ecwam/sinflx.F90 index 6e93f4d68..e9ab80b91 100644 --- a/src/ecwam/sinflx.F90 +++ b/src/ecwam/sinflx.F90 @@ -33,7 +33,7 @@ SUBROUTINE SINFLX (ICALL, NCALL, KIJS, KIJL, & USE YOWPARAM , ONLY : NANG ,NFRE USE YOWPHYS , ONLY : DTHRN_A ,DTHRN_U USE YOWWNDG , ONLY : ICODE ,ICODE_CPL - USE YOWSTAT , ONLY : IPHYS + USE YOWSTAT , ONLY : IPHYS ,IPHYS2_AIRSEA USE YOMHOOK , ONLY : LHOOK ,DR_HOOK, JPHOOK @@ -116,7 +116,12 @@ SUBROUTINE SINFLX (ICALL, NCALL, KIJS, KIJL, & & FLD, SL, SPOS, & & MIJ, RHOWGDFTH, XLLWS) CASE(2) - CALL SINFLX_ZBRY (ICALL, NCALL, KIJS, KIJL, & + IF (IPHYS2_AIRSEA==0) THEN + NGST=1 + ELSE IF (IPHYS2_AIRSEA==1 .OR. IPHYS2_AIRSEA==2) THEN + NGST=2 + END IF + CALL SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & & LUPDTUS, & & FL1, & & WAVNUM,CGROUP, CINV, XK2CG,& diff --git a/src/ecwam/sinflx_zbry.F90 b/src/ecwam/sinflx_zbry.F90 index ba7f62943..f86ad11d4 100644 --- a/src/ecwam/sinflx_zbry.F90 +++ b/src/ecwam/sinflx_zbry.F90 @@ -7,7 +7,7 @@ ! nor does it submit to any jurisdiction. ! -SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, KIJS, KIJL, & +SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & & LUPDTUS, & & FL1, & & WAVNUM,CGROUP, CINV, XK2CG,& @@ -24,8 +24,9 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, KIJS, KIJL, & ! ---------------------------------------------------------------------- !**** *SINFLX_ZBRY* - COMPUTATION OF INPUT SOURCE FUNCTION AND STRESSES - - +! +! JOSH KOUSAL & JEAN BIDLOT ECMWF 2023 +! !* PURPOSE. ! --------- @@ -127,6 +128,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, KIJS, KIJL, & INTEGER(KIND=JWIM), INTENT(IN) :: ICALL !! CALL NUMBER. INTEGER(KIND=JWIM), INTENT(IN) :: NCALL !! TOTAL NUMBER OF CALLS. +INTEGER(KIND=JWIM), INTENT(IN) :: NGST !! GUSTINESS PARAMETERIZATION INTEGER(KIND=JWIM), INTENT(IN) :: KIJS, KIJL !! GRID POINT INDEXES. LOGICAL, INTENT(IN) :: LUPDTUS !! IF TRUE UFRIC AND Z0M WILL BE UPDATED (CALLING AIRSEA). @@ -168,7 +170,6 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, KIJS, KIJL, & REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(OUT) :: XLLWS !! TOTAL WINDSEA MASK FROM INPUT SOURCE TERM. INTEGER(KIND=JWIM) :: IUSFG, ICODE_WND -INTEGER(KIND=JWIM), PARAMETER :: NGST=2 REAL(KIND=JPHOOK) :: ZHOOK_HANDLE REAL(KIND=JWRB), DIMENSION(KIJL) :: RNFAC diff --git a/src/ecwam/swldissip_zbry.F90 b/src/ecwam/swldissip_zbry.F90 index 39d39c929..eefab3bd0 100644 --- a/src/ecwam/swldissip_zbry.F90 +++ b/src/ecwam/swldissip_zbry.F90 @@ -13,11 +13,9 @@ SUBROUTINE SWLDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & ! ---------------------------------------------------------------------- !**** *SWLDISSIP_ZBRY* - COMPUTATION OF DISSIPATION SOURCE FUNCTION. - -! LOTFI AOUF METEO FRANCE 2013 -! FABRICE ARDHUIN IFREMER 2013 - - +! +! JOSH KOUSAL & JEAN BIDLOT ECMWF 2023 +! !* PURPOSE. ! -------- ! Turbulent dissipation of narrow-banded swell as described in From bb20eb02bbe280d4b0f2ad8613e78bcdeca5fadf Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Wed, 15 Oct 2025 13:52:41 +0000 Subject: [PATCH 27/89] bring IJ loops within (SINFLX_ZBRY) --- src/ecwam/setwavphys.F90 | 8 +- src/ecwam/sinflx_zbry.F90 | 289 ++++++++++++++++++++++---------------- src/ecwam/yowphys.F90 | 3 + 3 files changed, 172 insertions(+), 128 deletions(-) diff --git a/src/ecwam/setwavphys.F90 b/src/ecwam/setwavphys.F90 index 6058fc11e..f36f741c0 100644 --- a/src/ecwam/setwavphys.F90 +++ b/src/ecwam/setwavphys.F90 @@ -26,7 +26,7 @@ SUBROUTINE SETWAVPHYS & DELTA_THETA_RN, RN1_RN, DTHRN_A, DTHRN_U, & & ANG_GC_A, ANG_GC_B, ANG_GC_C, & & SWELLF4, SWELLF7, SWELLF7M1, Z0TUBMAX, Z0RAT, & - & SSDSC5, CDFAC + & SSDSC5, CDFAC, ZSIN6A0 USE YOWSTAT , ONLY : IPHYS, IPHYS2_AIRSEA USE YOWTEST , ONLY : IU06 @@ -216,7 +216,6 @@ SUBROUTINE SETWAVPHYS ASWKM=0.0981_JWRB BSWKM=0.425_JWRB - IF (IPHYS2_AIRSEA==0) THEN ! NGST=1 (handled in SINFLX) ALPHAPMAX = 1.0_JWRB ! i.e. no cap on max spectral steepness @@ -225,14 +224,11 @@ SUBROUTINE SETWAVPHYS ALPHAPMAX = 0.031_JWRB ! cap on spectral steepness as in ARD END IF - ! Not ALL necessarily used in ZBRY physics (TODO: change any others?) ALPHA = 0.0065_JWRB CDFAC = 1.0_JWRB - ! BETAMAX = 1.40_JWRB - ! ZALP = 0.008_JWRB - ! TAUWSHELTER=0.25_JWRB TAILFACTOR=6.0_JWRB ! SIN6FC = 6.0 from WW3-ST6 TAILFACTOR_PM=4.0_JWRB ! FXPM = 4.0 from WW3-ST6 + ZSIN6A0 = 9.0E-2_JWRB ELSE WRITE (IU06,*) '*************************************' diff --git a/src/ecwam/sinflx_zbry.F90 b/src/ecwam/sinflx_zbry.F90 index f86ad11d4..faa665621 100644 --- a/src/ecwam/sinflx_zbry.F90 +++ b/src/ecwam/sinflx_zbry.F90 @@ -104,7 +104,8 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & & RNU ,RNUM, & & SWELLF ,SWELLF2 ,SWELLF3 ,SWELLF4 , SWELLF5, & & SWELLF6 ,SWELLF7 ,SWELLF7M1, Z0RAT ,Z0TUBMAX , & - & ABMIN ,ABMAX, CDFAC, DTHRN_A ,DTHRN_U, RNU_WATER + & ABMIN ,ABMAX, CDFAC, DTHRN_A ,DTHRN_U, RNU_WATER, & + & ZSIN6A0 USE YOWTEST , ONLY : IU06 USE YOWTABL , ONLY : IAB ,SWELLFT USE YOWSTAT , ONLY : IPHYS2_AIRSEA, LLLOWWINDS @@ -180,26 +181,27 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & INTEGER(KIND=JWIM), DIMENSION(NANG) :: ITHN INTEGER(KIND=JWIM), DIMENSION(NFRE) :: IKN -REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: CG2, ECOS2, ESIN2, DSII2 -REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: WN2, SIG2 -REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: SQRTBN2, CINV2, A -REAL(KIND=JWRB), DIMENSION(NFRE) :: DSII, SIG, CINV1, DF -REAL(KIND=JWRB), DIMENSION(NFRE) :: ADENSIG, KMAX, ANAR, SQRTBN -REAL(KIND=JWRB), DIMENSION(NANG,NFRE) :: KK +REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: ECOS2, ESIN2, SIG2 +REAL(KIND=JWRB), DIMENSION(NFRE) :: DSII, SIG, DF REAL(KIND=JWRB), DIMENSION(NANG,NFRE) :: SPOSDENSIG, SNEGDENSIG -REAL(KIND=JWRB), DIMENSION(NANG*NFRE,NGST) :: W1, W2, S, D -REAL(KIND=JWRB), DIMENSION(NFRE,NGST) :: LFACT -REAL(KIND=JWRB), DIMENSION(NANG,NFRE,NGST) :: SDENSIG, DINPOS, DINTOT +REAL(KIND=JWRB), DIMENSION(KIJL,NANG*NFRE) :: CG2, WN2 +REAL(KIND=JWRB), DIMENSION(KIJL,NANG*NFRE) :: SQRTBN2, CINV2, A +REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: ADENSIG, KMAX, ANAR, SQRTBN, CINV1 +REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE) :: KK +REAL(KIND=JWRB), DIMENSION(KIJL,NANG*NFRE,NGST) :: W1, W2, S, D +REAL(KIND=JWRB), DIMENSION(KIJL,NFRE,NGST) :: LFACT +REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE,NGST) :: SDENSIG, DINPOS, DINTOT -REAL(KIND=JWRB), PARAMETER :: SIN6A0 = 9.0E-2_JWRB ! ST6 PARAM -REAL(KIND=JWRB), DIMENSION(NGST) :: TAUWX, TAUWY ! Component of the wave-supported stress -REAL(KIND=JWRB), DIMENSION(NGST) :: TAUNWX, TAUNWY ! Component of the neg. wave-supported stress -REAL(KIND=JWRB) :: COSU, SINU -REAL(KIND=JWRB), DIMENSION(NGST) :: UPROXYGST + +! REAL(KIND=JWRB), PARAMETER :: SIN6A0 = 9.0E-2_JWRB ! ST6 PARAM ! TODO, move to PHYS +REAL(KIND=JWRB), DIMENSION(KIJL,NGST) :: TAUWX, TAUWY ! Component of the wave-supported stress +REAL(KIND=JWRB), DIMENSION(KIJL,NGST) :: TAUNWX, TAUNWY ! Component of the neg. wave-supported stress +REAL(KIND=JWRB), DIMENSION(KIJL) :: COSU, SINU +REAL(KIND=JWRB), DIMENSION(KIJL,NGST) :: UPROXYGST REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: XK, CGG_WAM, CM -REAL(KIND=JWRB), DIMENSION(NFRE) :: SIGP2, SIGM1 +REAL(KIND=JWRB), DIMENSION(NFRE) :: SIGM1 ! For USTAR, Z0, CHNK REAL(KIND=JWRB), DIMENSION(KIJL,NGST) :: TAU @@ -303,11 +305,8 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & SIG(M) = ZPI*FR(M) DSII(M) = ZPI*DF(M) SIGM1(M) = 1.0_JWRB/SIG(M) - SIGP2(M) = SIG(M)**2 END DO -! TODO: clean up stuff in/out of IJ loops (sdissip_zbry + swldissip ) - DO M=1,NFRE DO IJ=KIJS,KIJL CM(IJ,M) = WAVNUM(IJ,M)*SIGM1(M) @@ -325,7 +324,6 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & ! ! such that e.g. SIG(1:NFRE) = SIG2(IKN). DO K = 1, NANG ! Apply to all directions - DSII2 (IKN+(K-1)) = DSII SIG2 (IKN+(K-1)) = SIG END DO @@ -377,27 +375,33 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & ! LOOP OVER LOCATIONS -DO IJ = KIJS,KIJL - - DO K = 1, NANG ! Apply to all directions - WN2 (IKN+(K-1)) = WAVNUM(IJ,:) ! using WAM native WN,CG - CG2 (IKN+(K-1)) = CGROUP(IJ,:) +DO K = 1, NANG + DO IJ = KIJS,KIJL + WN2 (IJ,IKN+(K-1)) = WAVNUM(IJ,:) ! using WAM native WN,CG + CG2 (IJ,IKN+(K-1)) = CGROUP(IJ,:) END DO +END DO - CINV2 = WN2 / SIG2 ! inverse phase speed +DO IJ = KIJS,KIJL + CINV2(IJ,:) = WN2(IJ,:) / SIG2(:) ! inverse phase speed + CINV1(IJ,:) = CINV2(IJ,IKN) +END DO !/ 0) --- set up a basic variables ----------------------------------- / - - COSU = COS(WDWAVE(IJ)) - SINU = SIN(WDWAVE(IJ)) +DO IJ = KIJS,KIJL + COSU(IJ) = COS(WDWAVE(IJ)) + SINU(IJ) = SIN(WDWAVE(IJ)) +END DO ! - DO IGST=1,NGST - TAUNWX(IGST) = 0.0_JWRB - TAUNWY(IGST) = 0.0_JWRB - TAUWX(IGST) = 0.0_JWRB - TAUWY(IGST) = 0.0_JWRB +DO IGST=1,NGST + DO IJ = KIJS,KIJL + TAUNWX(IJ,IGST) = 0.0_JWRB + TAUNWY(IJ,IGST) = 0.0_JWRB + TAUWX(IJ,IGST) = 0.0_JWRB + TAUWY(IJ,IGST) = 0.0_JWRB TAU(IJ,IGST) = 0.0_JWRB ENDDO +END DO ! !/ --- scale friction velocity to wind speed (10m) in @@ -411,98 +415,116 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & !/ SIN6WS = FRIC = 28.0 following Komen et al. (1984) (developed seas) !/ SIN6WS = 32.0 suggested by E. Rogers (2014) (young seas) ! - DO IGST=1,NGST - SELECT CASE (IPHYS2_AIRSEA) - CASE(0) - UPROXYGST(IGST) = 32.0_JWRB * CDFAC * USTARGST(IJ,IGST) ! original, suggested by E. Rogers (2014) (young seas) - CASE(1) - UPROXYGST(IGST) = FRIC * CDFAC * USTARGST(IJ,IGST) ! following Komen et al. (1984) (developed seas) (FRIC=28) - CASE(2) - UPROXYGST(IGST) = UABSGST(IJ,IGST) * CDFAC ! because FRIC=1/sqrt(CD), then this turns to purely a wind dependence (USTARGST cancels out) - END SELECT - ENDDO +DO IGST=1,NGST + SELECT CASE (IPHYS2_AIRSEA) + CASE(0) + DO IJ = KIJS,KIJL + UPROXYGST(IJ,IGST) = 32.0_JWRB * CDFAC * USTARGST(IJ,IGST) ! original, suggested by E. Rogers (2014) (young seas) + END DO + CASE(1) + DO IJ = KIJS,KIJL + UPROXYGST(IJ,IGST) = FRIC * CDFAC * USTARGST(IJ,IGST) ! following Komen et al. (1984) (developed seas) (FRIC=28) + END DO + CASE(2) + DO IJ = KIJS,KIJL + UPROXYGST(IJ,IGST) = UABSGST(IJ,IGST) * CDFAC ! because FRIC=1/sqrt(CD), then this turns to purely a wind dependence (USTARGST cancels out) + ENDDO + END SELECT +END DO ! ! To reshape from 1D to 2D: ! K = RESHAPE( A , (/ NANG, NFRE /)) ! To reshape from 2D to 1D: ! A = RESHAPE( F(IJ,:,:) , (/NSPEC/) ) - A = RESHAPE( FL1(IJ,:,:) , (/NSPEC/)) * CG2 / ( ZPI * SIG2 )! ACTION DENSITY SPECTRUM +DO IJ = KIJS,KIJL + A(IJ,:) = RESHAPE( FL1(IJ,:,:) , (/NSPEC/)) * CG2(IJ,:) / ( ZPI * SIG2(:) )! ACTION DENSITY SPECTRUM ! !/ 1) --- calculate 1d action density spectrum (A(sigma)) and !/ zero-out values less than 1.0E-32 to avoid NaNs when !/ computing directional narrowness in step 4). --------------- / - KK = RESHAPE(A,(/ NANG, NFRE /)) - - ADENSIG = SUM(KK,1) * SIG * DELTH ! Integrate over directions. + KK(IJ,:,:) = RESHAPE(A,(/ NANG, NFRE /)) + + ADENSIG(IJ,:) = SUM(KK(IJ,:,:),1) * SIG(:) * DELTH ! Integrate over directions. + + KMAX(IJ,:) = MAXVAL(KK(IJ,:,:),1) +END DO ! !/ 2) --- calculate normalised directional spectrum K(theta,sigma) --- / - KMAX = MAXVAL(KK,1) - DO M = 1,NFRE - IF (KMAX(M).LT.1.0E-34_JWRB) THEN - KK(1:NANG,M) = 1.0_JWRB +DO M = 1,NFRE + DO IJ = KIJS,KIJL + IF (KMAX(IJ,M).LT.1.0E-34_JWRB) THEN + KK(IJ,1:NANG,M) = 1.0_JWRB ELSE - KK(1:NANG,M) = KK(1:NANG,M)/KMAX(M) + KK(IJ,1:NANG,M) = KK(IJ,1:NANG,M)/KMAX(IJ,M) END IF END DO +END DO ! !/ 3) --- calculate normalised spectral saturation BN(M) ------------ / - ANAR = 1.0_JWRB/( SUM(KK,1) * DELTH ) ! directional narrowness -! -! SQRTBN = SQRT( ANAR * ADENSIG * WN(IJ,:)**3 ) - SQRTBN = SQRT( ANAR * ADENSIG * WAVNUM(IJ,:)**3 ) +DO IJ = KIJS,KIJL + ANAR(IJ,:) = 1.0_JWRB/( SUM(KK(IJ,:,:),1) * DELTH ) ! directional narrowness + ! + ! SQRTBN = SQRT( ANAR * ADENSIG * WN(IJ,:)**3 ) + SQRTBN(IJ,:) = SQRT( ANAR(IJ,:) * ADENSIG(IJ,:) * WAVNUM(IJ,:)**3 ) +END DO - DO K = 1, NANG - SQRTBN2(IKN+(K-1)) = SQRTBN ! Calculate SQRTBN for +DO K = 1, NANG + DO IJ = KIJS,KIJL + SQRTBN2(IJ,IKN+(K-1)) = SQRTBN(IJ,:) ! Calculate SQRTBN for END DO ! the entire spectrum. +END DO ! the entire spectrum. ! !/ 4) --- calculate growth rate GAMMA and S for all directions for !/ following winds (U10/c - 1 is positive; W1) and in 7) for !/ adverse winds (U10/c -1 is negative, W2). W1 and W2 !/ complement one another. ------------------------------------ / - DO IGST=1,NGST - W1(:,IGST)= MAX(0.0_JWRB, & - & UPROXYGST(IGST)*CINV2*(ECOS2*COSU + ESIN2*SINU) - 1.0_JWRB)**2 +DO IGST=1,NGST + DO IJ = KIJS,KIJL + W1(IJ,:,IGST)= MAX(0.0_JWRB, & + & UPROXYGST(IJ,IGST)*CINV2(IJ,:)*(ECOS2(:)*COSU(IJ) + ESIN2(:)*SINU(IJ)) - 1.0_JWRB)**2 ! - D(:,IGST) = (RAORW(IJ) ) * SIG2 * & - (2.8_JWRB-(1.0_JWRB+TANH(10.0_JWRB*SQRTBN2*W1(:,IGST)-11.0_JWRB)))*& - & SQRTBN2*W1(:,IGST) + D(IJ,:,IGST) = (RAORW(IJ) ) * SIG2(:) * & + (2.8_JWRB-(1.0_JWRB+TANH(10.0_JWRB*SQRTBN2(IJ,:)*W1(IJ,:,IGST)-11.0_JWRB)))*& + & SQRTBN2(IJ,:)*W1(IJ,:,IGST) ! IF (LLLOWWINDS .AND. UABSGST(IJ,IGST)<=1.5_JWRB) THEN ! Reduce growth rates for low winds (following Muhammad Yasrab's work) - D(:,IGST) = D(:,IGST) - (4._JWRB*(RNU_WATER)*(WAVNUM(IJ,:)**2)) - S(:,IGST) = D(:,IGST) * A + D(IJ,:,IGST) = D(IJ,:,IGST) - (4._JWRB*(RNU_WATER)*(WAVNUM(IJ,:)**2)) + S(IJ,:,IGST) = D(IJ,:,IGST) * A(IJ,:) ELSE - S(:,IGST) = D(:,IGST) * A - END IF + S(IJ,:,IGST) = D(IJ,:,IGST) * A(IJ,:) + END IF ENDDO +ENDDO ! !/ 5) --- calculate reduction factor LFACT using non-directional ! spectral density of the wind input ------------------------- / - CINV1 = CINV2(IKN) - DO IGST=1,NGST - SDENSIG(:,:,IGST) = RESHAPE(S(:,IGST)*SIG2/CG2,(/ NANG, NFRE /)) +DO IGST=1,NGST + DO IJ = KIJS,KIJL + SDENSIG(IJ,:,:,IGST) = RESHAPE(S(IJ,:,IGST)*SIG2(:)/CG2(IJ,:),(/ NANG, NFRE /)) - CALL LFACTOR(SDENSIG(:,:,IGST), CINV1, UABSGST(IJ,IGST), USTARGST(IJ,IGST), WDWAVE(IJ), & -& ROAIRN(IJ), SIG, DSII, LFACT(:,IGST), TAUWX(IGST), TAUWY(IGST), TAU(IJ,IGST)) + CALL LFACTOR(SDENSIG(IJ,:,:,IGST), CINV1(IJ,:), UABSGST(IJ,IGST), USTARGST(IJ,IGST), WDWAVE(IJ), & +& ROAIRN(IJ), SIG, DSII, LFACT(IJ,:,IGST), TAUWX(IJ,IGST), TAUWY(IJ,IGST), TAU(IJ,IGST)) ENDDO +ENDDO ! !/ 6) --- apply reduction (LFACT) to the entire spectrum ------------- / LLFACT = .TRUE. - ! TODO: if this shows to make a big difference, then I can make this logical more rigorous - ! (and also implement it to save costs in LFACTOR) IF (LLFACT) THEN DO IGST=1,NGST - IF (SUM(LFACT(:,IGST)) .LT. NFRE) THEN - DO K = 1, NANG - D(IKN+K-1,IGST) = D(IKN+K-1,IGST) * LFACT(:,IGST) - END DO - S(:,IGST) = D(:,IGST) * A - END IF - DINPOS(:,:,IGST) = RESHAPE(D(:,IGST),(/ NANG, NFRE /)) + DO IJ = KIJS,KIJL ! TODO: how to make more efficient? is difficult... + IF (SUM(LFACT(IJ,:,IGST)) .LT. NFRE) THEN + DO K = 1, NANG + D(IJ,IKN+K-1,IGST) = D(IJ,IKN+K-1,IGST) * LFACT(IJ,:,IGST) + END DO + S(IJ,:,IGST) = D(IJ,:,IGST) * A(IJ,:) + END IF + DINPOS(IJ,:,:,IGST) = RESHAPE(D(IJ,:,IGST),(/ NANG, NFRE /)) + ENDDO ENDDO END IF @@ -512,70 +534,94 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & !/ than those for the favourable winds [Donelan, 2006, Eq. (7)]. !/ the factor is adjustable with NAMELIST parameter in !/ ww3_grid.inp: '&SIN6 SINA0 = 0.04 /' ----------------------- / - DO IGST=1,NGST - IF (SIN6A0.GT.0.0_JWRB) THEN - W2(:,IGST) = MIN( 0.0_JWRB,UPROXYGST(IGST) * CINV2* & - & (ECOS2*COSU + ESIN2*SINU) - 1.0_JWRB )**2 - D(:,IGST) = D(:,IGST) - ( RAORW(IJ) * SIG2 * SIN6A0 * & - (2.8_JWRB-(1.0_JWRB+TANH(10.0_JWRB*SQRTBN2*W2(:,IGST) - 11.0_JWRB)))& - & *SQRTBN2*W2(:,IGST) ) +DO IGST=1,NGST + IF (ZSIN6A0.GT.0.0_JWRB) THEN + DO IJ = KIJS,KIJL + W2(IJ,:,IGST) = MIN( 0.0_JWRB,UPROXYGST(IJ,IGST) * CINV2(IJ,:) * & + & (ECOS2(:)*COSU(IJ) + ESIN2(:)*SINU(IJ)) - 1.0_JWRB )**2 + D(IJ,:,IGST) = D(IJ,:,IGST) - ( RAORW(IJ) * SIG2(:) * ZSIN6A0 * & + (2.8_JWRB-(1.0_JWRB+TANH(10.0_JWRB*SQRTBN2(IJ,:)*W2(IJ,:,IGST) - 11.0_JWRB)))& + & *SQRTBN2(IJ,:)*W2(IJ,:,IGST) ) - DINTOT(:,:,IGST)= RESHAPE(D(:,IGST),(/NANG,NFRE/)) - S(:,IGST) = D(:,IGST) * A + DINTOT(IJ,:,:,IGST)= RESHAPE(D(IJ,:,IGST),(/NANG,NFRE/)) + S(IJ,:,IGST) = D(IJ,:,IGST) * A(IJ,:) ! ! --- compute negative component of the wave supported stresses ! ! from negative part of the wind input ---------------------- / - SDENSIG(:,:,IGST) = RESHAPE(S(:,IGST)*SIG2/CG2,(/ NANG, NFRE /)) - CALL TAU_WAVE_ATMOS(SDENSIG(:,:,IGST), CINV1, SIG, DSII, TAUNWX(IGST), TAUNWY(IGST) ) - ELSE - DINTOT(:,:,IGST)=DINPOS(:,:,IGST) - END IF - ENDDO + SDENSIG(IJ,:,:,IGST) = RESHAPE(S(IJ,:,IGST)*SIG2/CG2(IJ,:),(/ NANG, NFRE /)) + CALL TAU_WAVE_ATMOS(SDENSIG(IJ,:,:,IGST), CINV1(IJ,:), SIG, DSII, TAUNWX(IJ,IGST), TAUNWY(IJ,IGST) ) + ENDDO + ELSE + DO IJ = KIJS,KIJL + DINTOT(IJ,:,:,IGST)=DINPOS(IJ,:,:,IGST) + ENDDO + END IF +ENDDO ! +DO IGST=1,NGST + DO IJ = KIJS,KIJL + TAUWGST(IJ,IGST) = SQRT(TAUWX(IJ,IGST)**2+TAUWY(IJ,IGST)**2) / ROAIRN(IJ) ! KINEMATIC TAUW + TAUWDIRGST(IJ,IGST) = ATAN2(TAUWX(IJ,IGST),TAUWY(IJ,IGST)) + TAUNWGST(IJ,IGST) = SQRT(TAUNWX(IJ,IGST)**2+TAUNWY(IJ,IGST)**2) / ROAIRN(IJ) ! KINEMATIC TAUNW + ENDDO + ENDDO + +SELECT CASE (IPHYS2_AIRSEA) + ! CASE(0) + ! USTARGST(IJ,IGST) = USTARGST(IJ,IGST) ! i.e. do nothing here, don't update USTAR because it is not true to WW3_ST6 + CASE(1,2) DO IGST=1,NGST - TAUWGST(IJ,IGST) = SQRT(TAUWX(IGST)**2+TAUWY(IGST)**2) / ROAIRN(IJ) ! KINEMATIC TAUW - TAUWDIRGST(IJ,IGST) = ATAN2(TAUWX(IGST),TAUWY(IGST)) - TAUNWGST(IJ,IGST) = SQRT(TAUNWX(IGST)**2+TAUNWY(IGST)**2) / ROAIRN(IJ) ! KINEMATIC TAUNW - SELECT CASE (IPHYS2_AIRSEA) - ! CASE(0) - ! USTARGST(IJ,IGST) = USTARGST(IJ,IGST) ! i.e. do nothing here, don't update USTAR because it is not true to WW3_ST6 - CASE(1,2) - USTARGST(IJ,IGST) = SQRT(TAU(IJ,IGST) / ROAIRN(IJ) ) - END SELECT + DO IJ = KIJS,KIJL + USTARGST(IJ,IGST) = SQRT(TAU(IJ,IGST) / ROAIRN(IJ) ) + ENDDO ENDDO +END SELECT ! 8) --- Calculate SL, FL and SPOS needed for ecWAM ------------- / - DO IGST=1,NGST - DO M = 1,NFRE - DO K = 1, NANG - SLGST(IJ,K,M,IGST) = DINTOT(K,M,IGST)*FL1(IJ,K,M) - SPOSGST(IJ,K,M,IGST) = DINPOS(K,M,IGST)*FL1(IJ,K,M) +DO IGST=1,NGST + DO M = 1,NFRE + DO K = 1, NANG + DO IJ = KIJS,KIJL + SLGST(IJ,K,M,IGST) = DINTOT(IJ,K,M,IGST)*FL1(IJ,K,M) + SPOSGST(IJ,K,M,IGST) = DINPOS(IJ,K,M,IGST)*FL1(IJ,K,M) END DO END DO - FLGST(IJ,:,:,IGST) = DINTOT(:,:,IGST) END DO +END DO + +DO IGST=1,NGST + DO IJ = KIJS,KIJL + FLGST(IJ,:,:,IGST) = DINTOT(IJ,:,:,IGST) + ENDDO +END DO ! 9) --- Averaging over gust components ------------- / - IGST=1 +IGST=1 + DO IJ = KIJS,KIJL TAUWGST_AVG(IJ) = TAUWGST(IJ,IGST) TAUWDIRGST_AVG(IJ) = TAUWDIRGST(IJ,IGST) TAUNWGST_AVG(IJ) = TAUNWGST(IJ,IGST) USTARGST_AVG(IJ) = USTARGST(IJ,IGST) - UPROXYGST_AVG(IJ) = UPROXYGST(IGST) + UPROXYGST_AVG(IJ) = UPROXYGST(IJ,IGST) SLGST_AVG(IJ,:,:) = SLGST(IJ,:,:,IGST) SPOSGST_AVG(IJ,:,:) = SPOSGST(IJ,:,:,IGST) FLGST_AVG(IJ,:,:) = FLGST(IJ,:,:,IGST) - DO IGST=2,NGST + END DO +DO IGST=2,NGST + DO IJ = KIJS,KIJL TAUWGST_AVG(IJ) = TAUWGST_AVG(IJ) + TAUWGST(IJ,IGST) TAUWDIRGST_AVG(IJ) = TAUWDIRGST_AVG(IJ) + TAUWDIRGST(IJ,IGST) TAUNWGST_AVG(IJ) = TAUNWGST_AVG(IJ) + TAUNWGST(IJ,IGST) USTARGST_AVG(IJ) = USTARGST_AVG(IJ) + USTARGST(IJ,IGST) - UPROXYGST_AVG(IJ) = UPROXYGST_AVG(IJ) + UPROXYGST(IGST) + UPROXYGST_AVG(IJ) = UPROXYGST_AVG(IJ) + UPROXYGST(IJ,IGST) SLGST_AVG(IJ,:,:) = SLGST_AVG(IJ,:,:) + SLGST(IJ,:,:,IGST) SPOSGST_AVG(IJ,:,:) = SPOSGST_AVG(IJ,:,:) + SPOSGST(IJ,:,:,IGST) FLGST_AVG(IJ,:,:) = FLGST_AVG(IJ,:,:) + FLGST(IJ,:,:,IGST) ENDDO +END DO + +DO IJ = KIJS,KIJL TAUW(IJ) = AVG_GST*TAUWGST_AVG(IJ) TAUWDIR(IJ) = AVG_GST*TAUWDIRGST_AVG(IJ) TAUNW(IJ) = AVG_GST*TAUNWGST_AVG(IJ) @@ -611,16 +657,15 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & SPOSDENSIG = SPOS(IJ,:,:) SNEGDENSIG = SL(IJ,:,:) - SPOS(IJ,:,:) - PHIWA(IJ) = CALCPHIWA(SPOSDENSIG,SNEGDENSIG,DSII) ! TODO: add the HiFreq contribution - + PHIWA(IJ) = CALCPHIWA(SPOSDENSIG,SNEGDENSIG,DSII) END DO ! END LOOP OVER LOC ! --------------------- ! XLLWS based on SL (mask for neg. input) -DO IJ=KIJS,KIJL - DO M = 1,NFRE - DO K = 1, NANG +DO M = 1,NFRE + DO K = 1, NANG + DO IJ=KIJS,KIJL IF (SL(IJ,K,M)>0.0_JWRB) THEN XLLWS(IJ,K,M)=1.0_JWRB ELSE diff --git a/src/ecwam/yowphys.F90 b/src/ecwam/yowphys.F90 index 249b33738..2b07c2e55 100644 --- a/src/ecwam/yowphys.F90 +++ b/src/ecwam/yowphys.F90 @@ -37,6 +37,9 @@ MODULE YOWPHYS ! *CDFAC* PARAMETER FOR WIND INPUT FOR ZBRY PHYS. REAL(KIND=JWRB) :: CDFAC + +! *SIN6A0* PARAMETER FOR NEGATIVE WIND INPUT (a0) FOR ZBRY PHYS + REAL(KIND=JWRB) :: ZSIN6A0 ! *BETAMAXOXKAPPA2* BETAMAX/XKAPPA**2 REAL(KIND=JWRB) :: BETAMAXOXKAPPA2 From 3e7e13958e6f60e755f1173035001254004fbd34 Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Thu, 16 Oct 2025 08:54:15 +0000 Subject: [PATCH 28/89] bring IJ loops within (S*DISSIP_ZBRY); bring zbry wave phys vars into setwavephys --- src/ecwam/sdissip.F90 | 12 +-- src/ecwam/sdissip_zbry.F90 | 176 ++++++++++++++++++----------------- src/ecwam/setwavphys.F90 | 14 ++- src/ecwam/sinflx.F90 | 2 +- src/ecwam/sinflx_zbry.F90 | 6 +- src/ecwam/swldissip_zbry.F90 | 153 ++++++++++++++---------------- src/ecwam/yowphys.F90 | 21 +++++ 7 files changed, 204 insertions(+), 180 deletions(-) diff --git a/src/ecwam/sdissip.F90 b/src/ecwam/sdissip.F90 index a8f0f5a7b..668b937e1 100644 --- a/src/ecwam/sdissip.F90 +++ b/src/ecwam/sdissip.F90 @@ -89,12 +89,12 @@ SUBROUTINE SDISSIP (KIJS, KIJL, FL1, FLD, SL, & & UFRIC, COSWDIF, RAORW) CASE(2) !$loki inline - CALL SDISSIP_ZBRY (KIJS, KIJL, FL1 ,FLD, SL, & - & WSWAVE, WAVNUM, CGROUP, XK2CG, & - & UFRIC, COSWDIF, RAORW) - CALL SWLDISSIP_ZBRY(KIJS, KIJL, FL1 ,FLD, SL, & - & WAVNUM, CGROUP, XK2CG, & - & UFRIC, COSWDIF, RAORW) + CALL SDISSIP_ZBRY (KIJS, KIJL, FL1 ,FLD, SL, & + & WSWAVE, WAVNUM, CGROUP, & + & UFRIC, COSWDIF, RAORW) + CALL SWLDISSIP_ZBRY(KIJS, KIJL, FL1 ,FLD, SL, & + & WAVNUM, CGROUP, & + & UFRIC, COSWDIF, RAORW) END SELECT IF (LHOOK) CALL DR_HOOK('SDISSIP',1,ZHOOK_HANDLE) diff --git a/src/ecwam/sdissip_zbry.F90 b/src/ecwam/sdissip_zbry.F90 index c9a03b07a..ad92ce95a 100644 --- a/src/ecwam/sdissip_zbry.F90 +++ b/src/ecwam/sdissip_zbry.F90 @@ -8,7 +8,7 @@ ! SUBROUTINE SDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & - & WSWAVE, WAVNUM, CGROUP, XK2CG, & + & WSWAVE, WAVNUM, CGROUP, & & UFRIC, COSWDIF, RAORW) ! ---------------------------------------------------------------------- @@ -30,7 +30,7 @@ SUBROUTINE SDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & ! ---------- ! *CALL* *SDISSIP_ZBRY (KIJS, KIJL, FL1, FLD,SL,* -! WAVNUM, CGROUP, XK2CG, +! WAVNUM, CGROUP, ! UFRIC, COSWDIF, RAORW)* ! *KIJS* - INDEX OF FIRST GRIDPOINT ! *KIJL* - INDEX OF LAST GRIDPOINT @@ -39,7 +39,6 @@ SUBROUTINE SDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & ! *SL* - TOTAL SOURCE FUNCTION ARRAY ! *WAVNUM* - WAVE NUMBER ! *CGROUP* - GROUP SPEED -! *XK2CG* - (WAVE NUMBER)**2 * GROUP SPEED ! *UFRIC* - FRICTION VELOCITY IN M/S. ! *RAORW* - RATIO AIR DENSITY TO WATER DENSITY ! *COSWDIF*- COS(TH(K)-WDWAVE(IJ)) @@ -76,11 +75,8 @@ SUBROUTINE SDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & USE YOWFRED , ONLY : FR , TH ,ZPIFR ,FRATIO ,DELTH, DFIM USE YOWPCONS , ONLY : G ,ZPI USE YOWPARAM , ONLY : NANG ,NFRE - USE YOWPHYS , ONLY : SDSBR ,ISDSDTH ,ISB ,IPSAT , & -& SSDSC2 , SSDSC4, SSDSC6, MICHE, SSDSC3, SSDSBRF1, & -& BRKPBCOEF ,SSDSC5, NSDSNTH, & -& INDICESSAT, SATWEIGHTS - USE YOWSTAT , ONLY : LLLOWWINDS + USE YOWSTAT , ONLY : LLLOWWINDS + USE YOWPHYS , ONLY : LLSDS6ET, ISDS6P1, ISDS6P2, ZSDS6A1, ZSDS6A2 USE YOMHOOK , ONLY : LHOOK ,DR_HOOK, JPHOOK @@ -93,45 +89,35 @@ SUBROUTINE SDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(IN) :: FL1 REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(INOUT) :: FLD, SL - REAL(KIND=JWRB), DIMENSION(KIJL,NFRE), INTENT(IN) :: WAVNUM, CGROUP, XK2CG + REAL(KIND=JWRB), DIMENSION(KIJL,NFRE), INTENT(IN) :: WAVNUM, CGROUP REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: WSWAVE, UFRIC, RAORW REAL(KIND=JWRB), DIMENSION(KIJL, NANG), INTENT(IN) :: COSWDIF - INTEGER(KIND=JWIM) :: IJ, K, M, I, J, M2, K2, NANGD + INTEGER(KIND=JWIM) :: IJ, K, M, I, J INTEGER(KIND=JWIM) :: NSPEC !num. of freqs, dirs, spec. bins INTEGER(KIND=JWIM), DIMENSION(NANG) :: ITHN INTEGER(KIND=JWIM), DIMENSION(NFRE) :: IKN - REAL(KIND=JWRB), PARAMETER :: SDS6A1 = 4.75E-6_JWRB ! ST6 PARAM - REAL(KIND=JWRB), PARAMETER :: SDS6A2 = 7.00E-5_JWRB ! ST6 PARAM - INTEGER(KIND=JWIM), PARAMETER :: SDS6P1 = 4 ! ST6 PARAM - INTEGER(KIND=JWIM), PARAMETER :: SDS6P2 = 4 ! ST6 PARAM - LOGICAL, PARAMETER :: SDS6ET = .TRUE. ! ST6 PARAM - REAL(KIND=JWRB), DIMENSION(NFRE) :: FREQ ! frequencies [Hz] REAL(KIND=JWRB), DIMENSION(NFRE) :: SIG ! frequencies [RAD] REAL(KIND=JWRB), DIMENSION(NFRE) :: DFII ! frequency bandwiths [Hz] - REAL(KIND=JWRB), DIMENSION(NFRE) :: ANAR ! directional narrowness - REAL(KIND=JWRB), DIMENSION(NFRE) :: EDENS ! spectral density E(f) - REAL(KIND=JWRB), DIMENSION(NFRE) :: ETDENS ! threshold spec. density ET(f) - REAL(KIND=JWRB), DIMENSION(NFRE) :: EXDENS ! excess spectral density EX(f) - REAL(KIND=JWRB), DIMENSION(NFRE) :: NEXDENS! normalised excess spec.dens. - REAL(KIND=JWRB), DIMENSION(NFRE) :: T1 ! inherent breaking term - REAL(KIND=JWRB), DIMENSION(NFRE) :: T2 ! forced dissipation term - REAL(KIND=JWRB), DIMENSION(NFRE) :: T12 ! =T1+T2 or combined dissipation - REAL(KIND=JWRB), DIMENSION(NFRE) :: ADF ! temporary variable + REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: ANAR ! directional narrowness + REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: EDENS ! spectral density E(f) + REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: ETDENS ! threshold spec. density ET(f) + REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: EXDENS ! excess spectral density EX(f) + REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: NEXDENS! normalised excess spec.dens. + REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: T1 ! inherent breaking term + REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: T2 ! forced dissipation term + REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: T12 ! =T1+T2 or combined dissipation + REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: ADF ! temporary variable REAL(KIND=JWRB), DIMENSION(NFRE) :: DF ! FREQUENCY INTERVALS REAL(KIND=JWRB) :: BNT ! empirical constant for wave breaking probability REAL(KIND=JWRB) :: XFAC, EDENSMAX ! temporary variableis - REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: S, D, A - REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: SIG2, CG2 - REAL(KIND=JWRB), DIMENSION(NANG,NFRE) :: DDS - - - REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: XK, CGG_WAM - REAL(KIND=JWRB), DIMENSION(NFRE) :: SIGP2 - + REAL(KIND=JWRB), DIMENSION(KIJL,NANG*NFRE) :: S, D, A + REAL(KIND=JWRB), DIMENSION(KIJL,NANG*NFRE) :: CG2 + REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: SIG2 + REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE) :: DDS REAL(KIND=JPHOOK) :: ZHOOK_HANDLE @@ -143,7 +129,6 @@ SUBROUTINE SDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & DO M = 1,NFRE SIG(M) = ZPI*FR(M) - SIGP2(M) = SIG(M)**2 END DO ! COMPUTE FREQUENCY INTERVALLS (borrowed from Wam_others/f4spec.F) @@ -156,72 +141,88 @@ SUBROUTINE SDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & DO K = 1, NANG ! Apply to all directions SIG2 (IKN+(K-1)) = SIG END DO - - - ! LOOP OVER LOCATIONS - DO IJ = KIJS,KIJL - - DO K = 1, NANG ! Apply to all directions - CG2 (IKN+(K-1)) = CGROUP(IJ,:) + + DO K = 1, NANG ! Apply to all directions + DO IJ = KIJS,KIJL + CG2 (IJ,IKN+(K-1)) = CGROUP(IJ,:) END DO - - A = RESHAPE( FL1(IJ,:,:) , (/NSPEC/)) * CG2 / ( ZPI * SIG2 )! ACTION DENSITY SPECTRUM + END DO + + DO IJ = KIJS,KIJL + A(IJ,:) = RESHAPE( FL1(IJ,:,:) , (/NSPEC/)) * CG2(IJ,:) / ( ZPI * SIG2(:) )! ACTION DENSITY SPECTRUM ! WAM E(f,theta) to WW3 A(k,theta) conversion factor: CG2 / ( ZPI *SIG2 ) + END DO !/ 0) --- Initialize essential parameters ---------------------------- / - IKN = IRANGE(1,NSPEC,NANG) ! Index vector for elements of 1, + IKN = IRANGE(1,NSPEC,NANG) ! Index vector for elements of 1, ! ! 2,..., NFRE such that for example ! ! SIG(1:NFRE) = SIG2(IKN). - FREQ = FR(1:NFRE) - ANAR = 1.0_JWRB - BNT = 0.035_JWRB**2 - T1 = 0.0_JWRB - T2 = 0.0_JWRB - NEXDENS = 0.0_JWRB + FREQ = FR(1:NFRE) + BNT = 0.035_JWRB**2 + DO IJ = KIJS,KIJL + ANAR(IJ,:) = 1.0_JWRB + T1(IJ,:) = 0.0_JWRB + T2(IJ,:) = 0.0_JWRB + NEXDENS(IJ,:) = 0.0_JWRB + END DO ! !/ 1) --- Calculate threshold spectral density, spectral density, and !/ the level of exceedence EXDENS(f) -------------------------- / -! ETDENS = ( ZPI * BNT ) / ( ANAR * CGG(IJ,:) * WN(IJ,:)**3 ) - ETDENS = ( ZPI * BNT ) / ( ANAR * CGROUP(IJ,:) * WAVNUM(IJ,:)**3 ) - !EDENS = SUM(FL1(IJ,:,:),1) * ZPI * SIG * DELTH / CGG(IJ,:) !E(f) - EDENS = SUM(FL1(IJ,:,:),1) * DELTH !E(f) - EXDENS = MAX(0.0_JWRB,EDENS-ETDENS) + DO IJ = KIJS,KIJL + ETDENS(IJ,:) = ( ZPI * BNT ) / ( ANAR(IJ,:) * CGROUP(IJ,:) * WAVNUM(IJ,:)**3 ) + EDENS(IJ,:) = SUM(FL1(IJ,:,:),1) * DELTH !E(f) + EXDENS(IJ,:) = MAX(0.0_JWRB,EDENS(IJ,:)-ETDENS(IJ,:)) + END DO ! !/ --- normalise by a generic spectral density -------------------- / - IF (SDS6ET) THEN ! ww3_grid.inp: &SDS6 SDSET = T or F - NEXDENS = EXDENS / ETDENS ! normalise by threshold spectral density + DO IJ = KIJS,KIJL + IF (LLSDS6ET) THEN ! ww3_grid.inp: &SDS6 SDSET = T or F + NEXDENS(IJ,:) = EXDENS(IJ,:) / ETDENS(IJ,:) ! normalise by threshold spectral density ELSE ! normalise by spectral density - EDENSMAX = MAXVAL(EDENS)*1.0E-5_JWRB - IF (ALL(EDENS .GT. EDENSMAX)) THEN - NEXDENS = EXDENS / EDENS + EDENSMAX = MAXVAL(EDENS(IJ,:))*1.0E-5_JWRB + IF (ALL(EDENS(IJ,:) .GT. EDENSMAX)) THEN + NEXDENS(IJ,:) = EXDENS(IJ,:) / EDENS(IJ,:) ELSE DO M = 1,NFRE - IF (EDENS(M) .GT. EDENSMAX) NEXDENS(M) = EXDENS(M) / EDENS(M) + IF (EDENS(IJ,M) .GT. EDENSMAX) THEN + NEXDENS(IJ,M) = EXDENS(IJ,M) / EDENS(IJ,M) + END IF END DO END IF END IF ! !/ 2) --- Calculate inherent breaking component T1 ------------------- / - T1 = SDS6A1 * ANAR * FREQ * (NEXDENS**SDS6P1) + T1(IJ,:) = ZSDS6A1 * ANAR(IJ,:) * FREQ * (NEXDENS(IJ,:)**ISDS6P1) ! !/ 3) --- Calculate T2, the dissipation of waves induced by !/ the breaking of longer waves T2 ---------------------------- / - ADF = ANAR * (NEXDENS**SDS6P2) - XFAC = (1.0_JWRB-1.0_JWRB/FRATIO)/(FRATIO-1.0_JWRB/FRATIO) - DO M = 1,NFRE - DFII(M) = DF(M) ! bug fix (spotted by Heinz): brought init into loc loop -! IF (M .GT. 1) DFII(M) = DFII(M) * XFAC - IF (M .GT. 1 .AND. M .LT. NFRE) DFII(M) = DFII(M) * XFAC - T2(M) = SDS6A2 * SUM( ADF(1:M)*DFII(1:M) ) - END DO + ADF(IJ,:) = ANAR(IJ,:) * (NEXDENS(IJ,:)**ISDS6P2) + END DO + + XFAC = (1.0_JWRB-1.0_JWRB/FRATIO)/(FRATIO-1.0_JWRB/FRATIO) + DO M = 1,NFRE + DFII(M) = DF(M) + IF (M .GT. 1 .AND. M .LT. NFRE) THEN + DFII(M) = DFII(M) * XFAC + END IF + DO IJ = KIJS,KIJL + T2(IJ,M) = ZSDS6A2 * SUM( ADF(IJ,1:M)*DFII(1:M) ) + END DO + END DO !/ 4) --- Sum up dissipation terms and apply to all directions ------- / - T12 = -1.0_JWRB * ( MAX(0.0_JWRB,T1)+MAX(0.0_JWRB,T2) ) - DO K = 1, NANG - D(IKN+(K-1)) = T12 - END DO + DO M = 1,NFRE + DO IJ = KIJS,KIJL + T12(IJ,M) = -1.0_JWRB * ( MAX(0.0_JWRB,T1(IJ,M))+MAX(0.0_JWRB,T2(IJ,M)) ) + END DO + END DO + + DO K = 1, NANG + DO IJ = KIJS,KIJL + D(IJ,IKN+(K-1)) = T12(IJ,:) + END DO + END DO ! - !S = D * A ! !/ 5) --- Diagnostic output (switch !/T6) ---------------------------- / !/T6 CALL STME21 ( TIME , IDTIME ) @@ -232,21 +233,22 @@ SUBROUTINE SDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & !/T6 270 FORMAT (' TEST W3SDS6 : ',A,'(',A,')',':',70E11.3) !/T6 271 FORMAT (' TEST W3SDS6 : Total SDS =',E13.5) - IF (.NOT. (LLLOWWINDS .AND. WSWAVE(IJ)<=5._JWRB)) THEN - ! no dissipation for U10<5m/s (following Muhammad Yasrab's work) - ! i.e. don't update SL and FLD for low winds - DDS = RESHAPE(D,(/NANG,NFRE/)) - DO M = 1,NFRE - DO K = 1, NANG - SL(IJ,K,M) = SL(IJ,K,M) + DDS(K,M)*FL1(IJ,K,M) - FLD(IJ,K,M) = FLD(IJ,K,M) + DDS(K,M) + DO IJ = KIJS,KIJL + DDS(IJ,:,:) = RESHAPE(D(IJ,:),(/NANG,NFRE/)) + END DO + + DO M = 1,NFRE + DO K = 1, NANG + DO IJ = KIJS,KIJL + IF (.NOT. (LLLOWWINDS .AND. WSWAVE(IJ)<=5._JWRB)) THEN + ! "no dissipation" option for low winds (following Muhammad Yasrab's work) + SL(IJ,K,M) = SL(IJ,K,M) + DDS(IJ,K,M)*FL1(IJ,K,M) + FLD(IJ,K,M) = FLD(IJ,K,M) + DDS(IJ,K,M) + END IF END DO END DO - END IF - END DO - ! END LOOP OVER LOC - + IF (LHOOK) CALL DR_HOOK('SDISSIP_ZBRY',1,ZHOOK_HANDLE) END SUBROUTINE SDISSIP_ZBRY diff --git a/src/ecwam/setwavphys.F90 b/src/ecwam/setwavphys.F90 index f36f741c0..337f07692 100644 --- a/src/ecwam/setwavphys.F90 +++ b/src/ecwam/setwavphys.F90 @@ -26,7 +26,9 @@ SUBROUTINE SETWAVPHYS & DELTA_THETA_RN, RN1_RN, DTHRN_A, DTHRN_U, & & ANG_GC_A, ANG_GC_B, ANG_GC_C, & & SWELLF4, SWELLF7, SWELLF7M1, Z0TUBMAX, Z0RAT, & - & SSDSC5, CDFAC, ZSIN6A0 + & SSDSC5, CDFAC, ZSIN6A0, LLSWL6CSTB1, ZSWL6B1, & + & ZSDS6A1, ZSDS6A2, ISDS6P1, ISDS6P2, LLSDS6ET + USE YOWSTAT , ONLY : IPHYS, IPHYS2_AIRSEA USE YOWTEST , ONLY : IU06 @@ -228,7 +230,17 @@ SUBROUTINE SETWAVPHYS CDFAC = 1.0_JWRB TAILFACTOR=6.0_JWRB ! SIN6FC = 6.0 from WW3-ST6 TAILFACTOR_PM=4.0_JWRB ! FXPM = 4.0 from WW3-ST6 + ZSIN6A0 = 9.0E-2_JWRB + ZSWL6B1 = 0.0041_JWRB + LLSWL6CSTB1 = .FALSE. + + ZSDS6A1 = 4.75E-6_JWRB + ZSDS6A2 = 7.00E-5_JWRB + ISDS6P1 = 4 + ISDS6P2 = 4 + LLSDS6ET = .TRUE. + ELSE WRITE (IU06,*) '*************************************' diff --git a/src/ecwam/sinflx.F90 b/src/ecwam/sinflx.F90 index e9ab80b91..5d9d96b51 100644 --- a/src/ecwam/sinflx.F90 +++ b/src/ecwam/sinflx.F90 @@ -124,7 +124,7 @@ SUBROUTINE SINFLX (ICALL, NCALL, KIJS, KIJL, & CALL SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & & LUPDTUS, & & FL1, & - & WAVNUM,CGROUP, CINV, XK2CG,& + & WAVNUM,CGROUP, CINV, & & WSWAVE, WDWAVE, AIRD, & & RAORW, WSTAR, CICOVER, & & COSWDIF, SINWDIF2, & diff --git a/src/ecwam/sinflx_zbry.F90 b/src/ecwam/sinflx_zbry.F90 index faa665621..60aa3f98f 100644 --- a/src/ecwam/sinflx_zbry.F90 +++ b/src/ecwam/sinflx_zbry.F90 @@ -10,7 +10,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & & LUPDTUS, & & FL1, & - & WAVNUM,CGROUP, CINV, XK2CG,& + & WAVNUM,CGROUP, CINV, & & WSWAVE, WDWAVE, AIRD, & & RAORW, WSTAR, CICOVER, & & COSWDIF, SINWDIF2, & @@ -38,7 +38,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & ! ---------- ! *CALL* *SINFLX_ZBRY (NGST, LLSNEG, KIJS, KIJL, FL1, -! & WAVNUM, CGROUP, CINV, XK2CG, +! & WAVNUM, CGROUP, CINV, ! & WSWAVE, WDWAVE, UFRIC, Z0M, ! & COSWDIF, SINWDIF2, ! & RAORW, WSTAR, RNFAC, @@ -52,7 +52,6 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & ! *WAVNUM* - WAVE NUMBER. ! *CGROUP* - GROUP SPEED ! *CINV* - INVERSE PHASE VELOCITY. -! *XK2CG* - (WAVNUM)**2 * GROUP SPPED. ! *WDWAVE* - WIND DIRECTION IN RADIANS IN OCEANOGRAPHIC ! NOTATION (POINTING ANGLE OF WIND VECTOR, ! CLOCKWISE FROM NORTH). @@ -138,7 +137,6 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & REAL(KIND=JWRB), DIMENSION(KIJL,NFRE), INTENT(IN) :: WAVNUM !! WAVE NUMBER. REAL(KIND=JWRB), DIMENSION(KIJL,NFRE), INTENT(IN) :: CGROUP !! GROUP VELOCITY. REAL(KIND=JWRB), DIMENSION(KIJL,NFRE), INTENT(IN) :: CINV !! INVERSE PHASE VELOCITY. -REAL(KIND=JWRB), DIMENSION(KIJL,NFRE), INTENT(IN) :: XK2CG !! (WAVNUM)**2 * GROUP SPPED. REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: WSWAVE !! WIND SPEED IN M/S. REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: WDWAVE !! WIND DIRECTION IN RADIANS IN OCEANOGRAPHIC NOTATION. REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: AIRD !! AIR DENSITY (KG/M**3). diff --git a/src/ecwam/swldissip_zbry.F90 b/src/ecwam/swldissip_zbry.F90 index eefab3bd0..84100268b 100644 --- a/src/ecwam/swldissip_zbry.F90 +++ b/src/ecwam/swldissip_zbry.F90 @@ -8,7 +8,7 @@ ! SUBROUTINE SWLDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & - & WAVNUM, CGROUP, XK2CG, & + & WAVNUM, CGROUP, & & UFRIC, COSWDIF, RAORW) ! ---------------------------------------------------------------------- @@ -25,7 +25,7 @@ SUBROUTINE SWLDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & ! ---------- ! *CALL* *SWLDISSIP_ZBRY (KIJS, KIJL, FL1, FLD,SL,* -! WAVNUM, CGROUP, XK2CG, +! WAVNUM, CGROUP, ! UFRIC, COSWDIF, RAORW)* ! *KIJS* - INDEX OF FIRST GRIDPOINT ! *KIJL* - INDEX OF LAST GRIDPOINT @@ -34,7 +34,6 @@ SUBROUTINE SWLDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & ! *SL* - TOTAL SOURCE FUNCTION ARRAY ! *WAVNUM* - WAVE NUMBER ! *CGROUP* - GROUP SPEED -! *XK2CG* - (WAVE NUMBER)**2 * GROUP SPEED ! *UFRIC* - FRICTION VELOCITY IN M/S. ! *RAORW* - RATIO AIR DENSITY TO WATER DENSITY ! *COSWDIF*- COS(TH(K)-WDWAVE(IJ)) @@ -70,10 +69,7 @@ SUBROUTINE SWLDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & USE YOWFRED , ONLY : FR , TH ,ZPIFR ,FRATIO ,DELTH, DFIM USE YOWPCONS , ONLY : G ,ZPI USE YOWPARAM , ONLY : NANG ,NFRE - USE YOWPHYS , ONLY : SDSBR ,ISDSDTH ,ISB ,IPSAT , & -& SSDSC2 , SSDSC4, SSDSC6, MICHE, SSDSC3, SSDSBRF1, & -& BRKPBCOEF ,SSDSC5, NSDSNTH, & -& INDICESSAT, SATWEIGHTS + USE YOWPHYS , ONLY : LLSWL6CSTB1, ZSWL6B1 USE YOMHOOK , ONLY : LHOOK ,DR_HOOK, JPHOOK @@ -86,30 +82,22 @@ SUBROUTINE SWLDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(IN) :: FL1 REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(INOUT) :: FLD, SL - REAL(KIND=JWRB), DIMENSION(KIJL,NFRE), INTENT(IN) :: WAVNUM, CGROUP, XK2CG + REAL(KIND=JWRB), DIMENSION(KIJL,NFRE), INTENT(IN) :: WAVNUM, CGROUP REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: UFRIC, RAORW REAL(KIND=JWRB), DIMENSION(KIJL, NANG), INTENT(IN) :: COSWDIF INTEGER(KIND=JWIM) :: IJ, M, I, J, M2, K2, K, NANGD INTEGER(KIND=JWIM) :: NSPEC !num. of freqs, dirs, spec. bins - INTEGER(KIND=JWIM), DIMENSION(NANG) :: KKD INTEGER(KIND=JWIM), DIMENSION(NANG) :: ITHN INTEGER(KIND=JWIM), DIMENSION(NFRE) :: IKN - REAL(KIND=JWRB), PARAMETER :: SWL6B1 = 0.0041_JWRB ! ST6 PARAM - LOGICAL, PARAMETER :: SWL6CSTB1 = .FALSE. ! ST6 PARAM - - REAL(KIND=JWRB), DIMENSION(NFRE) :: ABAND, KMAX, ANAR, BN, AORB, DDIS + REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: ABAND, KMAX, ANAR, BN, DDIS + REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE) :: KK + REAL(KIND=JWRB), DIMENSION(KIJL,NANG*NFRE) :: S, D, A, CG2 + REAL(KIND=JWRB), DIMENSION(KIJL) :: B1 REAL(KIND=JWRB), DIMENSION(NFRE) :: SIG, DDEN - REAL(KIND=JWRB), DIMENSION(NANG,NFRE) :: KK - REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: S, D, A - REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: SIG2, CG2 - REAL(KIND=JWRB) :: B1 - REAL(KIND=JWRB), DIMENSION(NANG,NFRE) :: DSWL - - REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: XK, CGG_WAM - REAL(KIND=JWRB), DIMENSION(NFRE) :: SIGP2 - REAL(KIND=JWRB), DIMENSION(NFRE) :: DF ! FREQUENCY INTERVALS + REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: SIG2 + REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE) :: DSWL REAL(KIND=JPHOOK) :: ZHOOK_HANDLE @@ -121,87 +109,88 @@ SUBROUTINE SWLDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & DO M = 1,NFRE SIG(M) = ZPI*FR(M) - SIGP2(M) = SIG(M)**2 DDEN(M) = ZPI*DFIM(M)*SIG(M) END DO -! COMPUTE FREQUENCY INTERVALLS (borrowed from Wam_others/f4spec.F) - DO M = 1,NFRE - DF(M) = FR(M)*( FRATIO - 1.0_JWRB ) - ENDDO - IKN = IRANGE(1,NSPEC,NANG) ! Index vector for elements of 1 ... NFRE ! ! such that e.g. SIG(1:NFRE) = SIG2(IKN). DO K = 1, NANG ! Apply to all directions SIG2 (IKN+(K-1)) = SIG END DO - - - ! LOOP OVER LOCATIONS - DO IJ = KIJS,KIJL - - DO K = 1, NANG ! Apply to all directions - CG2 (IKN+(K-1)) = CGROUP(IJ,:) + + DO K = 1, NANG + DO IJ = KIJS,KIJL + CG2 (IJ,IKN+(K-1)) = CGROUP(IJ,:) END DO + END DO - A = RESHAPE( FL1(IJ,:,:) , (/NSPEC/)) * CG2 / ( ZPI * SIG2 )! ACTION DENSITY SPECTRUM + DO IJ = KIJS,KIJL + A(IJ,:) = RESHAPE( FL1(IJ,:,:) , (/NSPEC/)) * CG2(IJ,:) / ( ZPI * SIG2(:) )! ACTION DENSITY SPECTRUM ! WAM E(f,theta) to WW3 A(k,theta) conversion factor: CG2 / ( ZPI *SIG2 ) + END DO + + !/ 0) --- Initialize parameters -------------------------------------- / + IKN = IRANGE(1,NSPEC,NANG) ! Index vector for array access, e.g. + ! in form of WN(1:NFRE) == WN2(IKN). -!/ 0) --- Initialize parameters -------------------------------------- / - IKN = IRANGE(1,NSPEC,NANG) ! Index vector for array access, e.g. - ! in form of WN(1:NFRE) == WN2(IKN). - ABAND = SUM(RESHAPE(A,(/ NANG,NFRE /)),1) ! action density as function of wavenumber - DDIS = 0.0_JWRB - D = 0.0_JWRB - B1 = SWL6B1 ! empirical constant from NAMELIST + DO IJ = KIJS,KIJL + ABAND(IJ,:) = SUM(RESHAPE(A(IJ,:),(/ NANG,NFRE /)),1) ! action density as function of wavenumber + DDIS(IJ,:) = 0.0_JWRB + D(IJ,:) = 0.0_JWRB + END DO !/ 1) --- Choose calculation of steepness a*k ------------------------ / !/ Replace the measure of steepness with the spectral ! saturation after Banner et al. (2002) ---------------------- / - KK = RESHAPE(A,(/ NANG,NFRE /)) - KMAX = MAXVAL(KK,1) - DO M = 1,NFRE - IF (KMAX(M).LT.1.0E-34_JWRB) THEN - KK(1:NANG,M) = 1.0_JWRB + DO IJ = KIJS,KIJL + KK(IJ,:,:) = RESHAPE(A(IJ,:),(/ NANG,NFRE /)) + KMAX(IJ,:) = MAXVAL(KK(IJ,:,:),1) + END DO + + DO M = 1,NFRE + DO IJ = KIJS,KIJL + IF (KMAX(IJ,M).LT.1.0E-34_JWRB) THEN + KK(IJ,1:NANG,M) = 1.0_JWRB ELSE - KK(1:NANG,M) = KK(1:NANG,M)/KMAX(M) + KK(IJ,1:NANG,M) = KK(IJ,1:NANG,M)/KMAX(IJ,M) END IF END DO - ANAR = 1.0_JWRB/( SUM(KK,1) * DELTH ) -! BN = ANAR * ( ABAND * SIG * DELTH ) * WN(IJ,:)**3 - BN = ANAR * ( ABAND * SIG * DELTH ) * WAVNUM(IJ,:)**3 + END DO + + DO IJ = KIJS,KIJL + ANAR(IJ,:) = 1.0_JWRB/( SUM(KK(IJ,:,:),1) * DELTH ) + BN(IJ,:) = ANAR(IJ,:) * ( ABAND(IJ,:) * SIG * DELTH ) * WAVNUM(IJ,:)**3 + END DO ! - IF (.NOT.SWL6CSTB1) THEN -! + IF (.NOT.LLSWL6CSTB1) THEN !/ --- A constant value for B1 attenuates swell too strong in the !/ western central Pacific (i.e. cross swell less than 1.0m). !/ Workaround is to scale B1 with steepness a*kp, where kp is -!/ the peak wavenumber. SWL6B1 remains a scaling constant, but +!/ the peak wavenumber. ZSWL6B1 remains a scaling constant, but !/ with different magnitude. --------------------------------- / - M = MAXLOC(ABAND,1) ! Index for peak -! EMEAN = SUM(ABAND * DDEN / CG) ! Total sea surface variance -! B1 = SWL6B1*(2.0_JWRB*SQRT(SUM(ABAND*DDEN/CGG(IJ,:)))*& -! & WN(IJ,M)) - B1 = SWL6B1*(2.0_JWRB*SQRT(SUM(ABAND*DDEN/CGROUP(IJ,:)))*& - & WAVNUM(IJ,M)) - -! - END IF + DO IJ = KIJS,KIJL + M = MAXLOC(ABAND(IJ,:),1) ! Index for peak + B1(IJ) = ZSWL6B1*(2.0_JWRB*SQRT(SUM(ABAND(IJ,:)*DDEN/CGROUP(IJ,:)))*& + & WAVNUM(IJ,M)) + END DO + END IF ! !/ 2) --- Calculate the derivative term only (in units of 1/s) ------- / - DO M = 1,NFRE - IF (ABAND(M) .GT. 1.0E-30_JWRB) THEN - DDIS(M) = -(2.0_JWRB/3.0_JWRB) * B1 * SIG(M) * SQRT(BN(M)) - END IF + DO M = 1,NFRE + DO IJ = KIJS,KIJL + IF (ABAND(IJ,M) .GT. 1.0E-30_JWRB) THEN + DDIS(IJ,M) = -(2.0_JWRB/3.0_JWRB) * B1(IJ) * SIG(M) * SQRT(BN(IJ,M)) + END IF END DO + END DO ! !/ 3) --- Apply dissipation term of derivative to all directions ----- / - DO K = 1, NANG - D(IKN+(K-1)) = DDIS + DO K = 1, NANG + DO IJ = KIJS,KIJL + D(IJ,IKN+(K-1)) = DDIS(IJ,M) END DO -! - !S = D * A + END DO ! ! WRITE(*,*) ' B1 =',B1 ! WRITE(*,*) ' DDIS_tot =',SUM(DDIS*ABAND*DDEN/CG) @@ -209,17 +198,19 @@ SUBROUTINE SWLDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & ! WRITE(*,*) ' EDENS_tot=',sum(aband*sig*dth*dsii/cg) ! WRITE(*,*) ' ' ! WRITE(*,*) ' SWL6_tot =',sum(SUM(RESHAPE(S,(/ NANG,NFRE /)),1)*DDEN/CG) - - DSWL = RESHAPE(D,(/NANG,NFRE/)) - DO M = 1,NFRE - DO K = 1, NANG - SL(IJ,K,M) = SL(IJ,K,M) + DSWL(K,M)*FL1(IJ,K,M) - FLD(IJ,K,M) = FLD(IJ,K,M) + DSWL(K,M) - END DO + DO IJ = KIJS,KIJL + DSWL(IJ,:,:) = RESHAPE(D(IJ,:),(/NANG,NFRE/)) + END DO + + DO M = 1,NFRE + DO K = 1, NANG + DO IJ = KIJS,KIJL + SL(IJ,K,M) = SL(IJ,K,M) + DSWL(IJ,K,M)*FL1(IJ,K,M) + FLD(IJ,K,M) = FLD(IJ,K,M) + DSWL(IJ,K,M) + END DO END DO - END DO - ! END LOOP OVER LOC + IF (LHOOK) CALL DR_HOOK('SWLDISSIP_ZBRY',1,ZHOOK_HANDLE) diff --git a/src/ecwam/yowphys.F90 b/src/ecwam/yowphys.F90 index 2b07c2e55..fc6d67fde 100644 --- a/src/ecwam/yowphys.F90 +++ b/src/ecwam/yowphys.F90 @@ -156,6 +156,27 @@ MODULE YOWPHYS ! Wave-turbulence interaction coefficient REAL(KIND=JWRB) :: SSDSC5 !! See *SETWAVPHYS* +! Swell attenuation logical for ZBRY physics + LOGICAL :: LLSWL6CSTB1 + +! Swell attenuation coefficient for ZBRY physics + REAL(KIND=JWRB) :: ZSWL6B1 + +! Dissipation coefficient for inherent breaking term for ZBRY physics (T1,a1) + REAL(KIND=JWRB) :: ZSDS6A1 + +! Dissipation coefficient for forced dissipation term for ZBRY physics (T1,a2) + REAL(KIND=JWRB) :: ZSDS6A2 + +! Dissipation exponent for inherent breaking term for ZBRY physics (T1,p1) + INTEGER(KIND=JWIM) :: ISDS6P1 + +! Dissipation exponent for forced dissipation term for ZBRY physics (T2,p2) + INTEGER(KIND=JWIM) :: ISDS6P2 + +! Dissipation, logical to normalise by **threshold** spectral density + LOGICAL :: LLSDS6ET + ! NSDSNTH is the number of directions on both used to compute the spectral saturation INTEGER(KIND=JWIM) :: NSDSNTH From d51792b191a6ec03fd3c02a14c792e5cf5bc1ced Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Thu, 16 Oct 2025 12:57:17 +0000 Subject: [PATCH 29/89] iron out a bug in IJ looping; clean up --- src/ecwam/mpuserin.F90 | 2 +- src/ecwam/sdissip_zbry.F90 | 46 +++++++++++++++++++++++------------- src/ecwam/sinflx_zbry.F90 | 43 +++++++++++++++++---------------- src/ecwam/swldissip_zbry.F90 | 4 ++-- 4 files changed, 55 insertions(+), 40 deletions(-) diff --git a/src/ecwam/mpuserin.F90 b/src/ecwam/mpuserin.F90 index 37f97bb79..cdcdc348f 100644 --- a/src/ecwam/mpuserin.F90 +++ b/src/ecwam/mpuserin.F90 @@ -609,7 +609,7 @@ SUBROUTINE MPUSERIN ISHALLO = 0 !! depricated IPHYS = 1 IPHYS2_AIRSEA = 2 - LLLOWWINDS = .TRUE. ! .TRUE. if low winds are treated differently + LLLOWWINDS = .FALSE. ! .TRUE. if low winds are treated differently ISNONLIN = 1 IDAMPING = 1 IPROPAGS = 0 diff --git a/src/ecwam/sdissip_zbry.F90 b/src/ecwam/sdissip_zbry.F90 index ad92ce95a..b4cd5277c 100644 --- a/src/ecwam/sdissip_zbry.F90 +++ b/src/ecwam/sdissip_zbry.F90 @@ -112,7 +112,8 @@ SUBROUTINE SDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: ADF ! temporary variable REAL(KIND=JWRB), DIMENSION(NFRE) :: DF ! FREQUENCY INTERVALS REAL(KIND=JWRB) :: BNT ! empirical constant for wave breaking probability - REAL(KIND=JWRB) :: XFAC, EDENSMAX ! temporary variableis + REAL(KIND=JWRB) :: XFAC ! temporary variableis + REAL(KIND=JWRB), DIMENSION(KIJL) :: EDENSMAX ! temporary variable REAL(KIND=JWRB), DIMENSION(KIJL,NANG*NFRE) :: S, D, A REAL(KIND=JWRB), DIMENSION(KIJL,NANG*NFRE) :: CG2 @@ -149,7 +150,7 @@ SUBROUTINE SDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & END DO DO IJ = KIJS,KIJL - A(IJ,:) = RESHAPE( FL1(IJ,:,:) , (/NSPEC/)) * CG2(IJ,:) / ( ZPI * SIG2(:) )! ACTION DENSITY SPECTRUM + A(IJ,:) = RESHAPE( FL1(IJ,:,:) , (/NSPEC/)) * CG2(IJ,:) / ( ZPI * SIG2 )! ACTION DENSITY SPECTRUM ! WAM E(f,theta) to WW3 A(k,theta) conversion factor: CG2 / ( ZPI *SIG2 ) END DO @@ -179,23 +180,27 @@ SUBROUTINE SDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & IF (LLSDS6ET) THEN ! ww3_grid.inp: &SDS6 SDSET = T or F NEXDENS(IJ,:) = EXDENS(IJ,:) / ETDENS(IJ,:) ! normalise by threshold spectral density ELSE ! normalise by spectral density - EDENSMAX = MAXVAL(EDENS(IJ,:))*1.0E-5_JWRB - IF (ALL(EDENS(IJ,:) .GT. EDENSMAX)) THEN + EDENSMAX(IJ) = MAXVAL(EDENS(IJ,:))*1.0E-5_JWRB + IF (ALL(EDENS(IJ,:) .GT. EDENSMAX(IJ))) THEN NEXDENS(IJ,:) = EXDENS(IJ,:) / EDENS(IJ,:) ELSE DO M = 1,NFRE - IF (EDENS(IJ,M) .GT. EDENSMAX) THEN + IF (EDENS(IJ,M) .GT. EDENSMAX(IJ)) THEN NEXDENS(IJ,M) = EXDENS(IJ,M) / EDENS(IJ,M) END IF END DO END IF END IF + END DO ! !/ 2) --- Calculate inherent breaking component T1 ------------------- / + DO IJ = KIJS,KIJL T1(IJ,:) = ZSDS6A1 * ANAR(IJ,:) * FREQ * (NEXDENS(IJ,:)**ISDS6P1) + END DO ! !/ 3) --- Calculate T2, the dissipation of waves induced by !/ the breaking of longer waves T2 ---------------------------- / + DO IJ = KIJS,KIJL ADF(IJ,:) = ANAR(IJ,:) * (NEXDENS(IJ,:)**ISDS6P2) END DO @@ -211,10 +216,8 @@ SUBROUTINE SDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & END DO !/ 4) --- Sum up dissipation terms and apply to all directions ------- / - DO M = 1,NFRE - DO IJ = KIJS,KIJL - T12(IJ,M) = -1.0_JWRB * ( MAX(0.0_JWRB,T1(IJ,M))+MAX(0.0_JWRB,T2(IJ,M)) ) - END DO + DO IJ = KIJS,KIJL + T12(IJ,:) = -1.0_JWRB * ( MAX(0.0_JWRB,T1(IJ,:))+MAX(0.0_JWRB,T2(IJ,:)) ) END DO DO K = 1, NANG @@ -237,17 +240,28 @@ SUBROUTINE SDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & DDS(IJ,:,:) = RESHAPE(D(IJ,:),(/NANG,NFRE/)) END DO - DO M = 1,NFRE - DO K = 1, NANG - DO IJ = KIJS,KIJL - IF (.NOT. (LLLOWWINDS .AND. WSWAVE(IJ)<=5._JWRB)) THEN - ! "no dissipation" option for low winds (following Muhammad Yasrab's work) + IF (LLLOWWINDS) THEN + DO M = 1,NFRE + DO K = 1, NANG + DO IJ = KIJS,KIJL + IF ( WSWAVE(IJ)>=5._JWRB) THEN + ! no dissipation for winds<5m/s (following Muhammad Yasrab's work) + SL(IJ,K,M) = SL(IJ,K,M) + DDS(IJ,K,M)*FL1(IJ,K,M) + FLD(IJ,K,M) = FLD(IJ,K,M) + DDS(IJ,K,M) + END IF + END DO + END DO + END DO + ELSE + DO M = 1,NFRE + DO K = 1, NANG + DO IJ = KIJS,KIJL SL(IJ,K,M) = SL(IJ,K,M) + DDS(IJ,K,M)*FL1(IJ,K,M) FLD(IJ,K,M) = FLD(IJ,K,M) + DDS(IJ,K,M) - END IF + END DO END DO END DO - END DO + END IF IF (LHOOK) CALL DR_HOOK('SDISSIP_ZBRY',1,ZHOOK_HANDLE) diff --git a/src/ecwam/sinflx_zbry.F90 b/src/ecwam/sinflx_zbry.F90 index 60aa3f98f..0960bcc74 100644 --- a/src/ecwam/sinflx_zbry.F90 +++ b/src/ecwam/sinflx_zbry.F90 @@ -381,7 +381,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & END DO DO IJ = KIJS,KIJL - CINV2(IJ,:) = WN2(IJ,:) / SIG2(:) ! inverse phase speed + CINV2(IJ,:) = WN2(IJ,:) / SIG2 ! inverse phase speed CINV1(IJ,:) = CINV2(IJ,IKN) END DO @@ -435,14 +435,14 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & ! To reshape from 2D to 1D: ! A = RESHAPE( F(IJ,:,:) , (/NSPEC/) ) DO IJ = KIJS,KIJL - A(IJ,:) = RESHAPE( FL1(IJ,:,:) , (/NSPEC/)) * CG2(IJ,:) / ( ZPI * SIG2(:) )! ACTION DENSITY SPECTRUM + A(IJ,:) = RESHAPE( FL1(IJ,:,:) , (/NSPEC/)) * CG2(IJ,:) / ( ZPI * SIG2 )! ACTION DENSITY SPECTRUM ! !/ 1) --- calculate 1d action density spectrum (A(sigma)) and !/ zero-out values less than 1.0E-32 to avoid NaNs when !/ computing directional narrowness in step 4). --------------- / KK(IJ,:,:) = RESHAPE(A,(/ NANG, NFRE /)) - ADENSIG(IJ,:) = SUM(KK(IJ,:,:),1) * SIG(:) * DELTH ! Integrate over directions. + ADENSIG(IJ,:) = SUM(KK(IJ,:,:),1) * SIG * DELTH ! Integrate over directions. KMAX(IJ,:) = MAXVAL(KK(IJ,:,:),1) END DO @@ -479,9 +479,9 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & DO IGST=1,NGST DO IJ = KIJS,KIJL W1(IJ,:,IGST)= MAX(0.0_JWRB, & - & UPROXYGST(IJ,IGST)*CINV2(IJ,:)*(ECOS2(:)*COSU(IJ) + ESIN2(:)*SINU(IJ)) - 1.0_JWRB)**2 + & UPROXYGST(IJ,IGST)*CINV2(IJ,:)*(ECOS2*COSU(IJ) + ESIN2*SINU(IJ)) - 1.0_JWRB)**2 ! - D(IJ,:,IGST) = (RAORW(IJ) ) * SIG2(:) * & + D(IJ,:,IGST) = (RAORW(IJ) ) * SIG2 * & (2.8_JWRB-(1.0_JWRB+TANH(10.0_JWRB*SQRTBN2(IJ,:)*W1(IJ,:,IGST)-11.0_JWRB)))*& & SQRTBN2(IJ,:)*W1(IJ,:,IGST) ! @@ -490,6 +490,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & D(IJ,:,IGST) = D(IJ,:,IGST) - (4._JWRB*(RNU_WATER)*(WAVNUM(IJ,:)**2)) S(IJ,:,IGST) = D(IJ,:,IGST) * A(IJ,:) ELSE + ! Update spectrum as per normal S(IJ,:,IGST) = D(IJ,:,IGST) * A(IJ,:) END IF @@ -501,7 +502,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & DO IGST=1,NGST DO IJ = KIJS,KIJL - SDENSIG(IJ,:,:,IGST) = RESHAPE(S(IJ,:,IGST)*SIG2(:)/CG2(IJ,:),(/ NANG, NFRE /)) + SDENSIG(IJ,:,:,IGST) = RESHAPE(S(IJ,:,IGST)*SIG2/CG2(IJ,:),(/ NANG, NFRE /)) CALL LFACTOR(SDENSIG(IJ,:,:,IGST), CINV1(IJ,:), UABSGST(IJ,IGST), USTARGST(IJ,IGST), WDWAVE(IJ), & & ROAIRN(IJ), SIG, DSII, LFACT(IJ,:,IGST), TAUWX(IJ,IGST), TAUWY(IJ,IGST), TAU(IJ,IGST)) @@ -511,20 +512,20 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & ! !/ 6) --- apply reduction (LFACT) to the entire spectrum ------------- / - LLFACT = .TRUE. - IF (LLFACT) THEN - DO IGST=1,NGST - DO IJ = KIJS,KIJL ! TODO: how to make more efficient? is difficult... - IF (SUM(LFACT(IJ,:,IGST)) .LT. NFRE) THEN - DO K = 1, NANG - D(IJ,IKN+K-1,IGST) = D(IJ,IKN+K-1,IGST) * LFACT(IJ,:,IGST) - END DO - S(IJ,:,IGST) = D(IJ,:,IGST) * A(IJ,:) - END IF - DINPOS(IJ,:,:,IGST) = RESHAPE(D(IJ,:,IGST),(/ NANG, NFRE /)) - ENDDO +LLFACT = .TRUE. +IF (LLFACT) THEN + DO IGST=1,NGST + DO IJ = KIJS,KIJL ! TODO: how to make more efficient? is difficult... + IF (SUM(LFACT(IJ,:,IGST)) .LT. NFRE) THEN + DO K = 1, NANG + D(IJ,IKN+K-1,IGST) = D(IJ,IKN+K-1,IGST) * LFACT(IJ,:,IGST) + END DO + S(IJ,:,IGST) = D(IJ,:,IGST) * A(IJ,:) + END IF + DINPOS(IJ,:,:,IGST) = RESHAPE(D(IJ,:,IGST),(/ NANG, NFRE /)) ENDDO - END IF + ENDDO +END IF ! !/ 7) --- compute negative wind input for adverse winds. negative @@ -536,8 +537,8 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & IF (ZSIN6A0.GT.0.0_JWRB) THEN DO IJ = KIJS,KIJL W2(IJ,:,IGST) = MIN( 0.0_JWRB,UPROXYGST(IJ,IGST) * CINV2(IJ,:) * & - & (ECOS2(:)*COSU(IJ) + ESIN2(:)*SINU(IJ)) - 1.0_JWRB )**2 - D(IJ,:,IGST) = D(IJ,:,IGST) - ( RAORW(IJ) * SIG2(:) * ZSIN6A0 * & + & (ECOS2*COSU(IJ) + ESIN2*SINU(IJ)) - 1.0_JWRB )**2 + D(IJ,:,IGST) = D(IJ,:,IGST) - ( RAORW(IJ) * SIG2 * ZSIN6A0 * & (2.8_JWRB-(1.0_JWRB+TANH(10.0_JWRB*SQRTBN2(IJ,:)*W2(IJ,:,IGST) - 11.0_JWRB)))& & *SQRTBN2(IJ,:)*W2(IJ,:,IGST) ) diff --git a/src/ecwam/swldissip_zbry.F90 b/src/ecwam/swldissip_zbry.F90 index 84100268b..4bd16d17a 100644 --- a/src/ecwam/swldissip_zbry.F90 +++ b/src/ecwam/swldissip_zbry.F90 @@ -125,7 +125,7 @@ SUBROUTINE SWLDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & END DO DO IJ = KIJS,KIJL - A(IJ,:) = RESHAPE( FL1(IJ,:,:) , (/NSPEC/)) * CG2(IJ,:) / ( ZPI * SIG2(:) )! ACTION DENSITY SPECTRUM + A(IJ,:) = RESHAPE( FL1(IJ,:,:) , (/NSPEC/)) * CG2(IJ,:) / ( ZPI * SIG2 )! ACTION DENSITY SPECTRUM ! WAM E(f,theta) to WW3 A(k,theta) conversion factor: CG2 / ( ZPI *SIG2 ) END DO @@ -188,7 +188,7 @@ SUBROUTINE SWLDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & !/ 3) --- Apply dissipation term of derivative to all directions ----- / DO K = 1, NANG DO IJ = KIJS,KIJL - D(IJ,IKN+(K-1)) = DDIS(IJ,M) + D(IJ,IKN+(K-1)) = DDIS(IJ,:) END DO END DO ! From f5f3a9e2e8ebcd964bf3befb769661283a6ce897 Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Thu, 16 Oct 2025 14:02:34 +0000 Subject: [PATCH 30/89] forgot to index A (action) spectrum --- src/ecwam/sinflx_zbry.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/ecwam/sinflx_zbry.F90 b/src/ecwam/sinflx_zbry.F90 index 0960bcc74..3bfca7878 100644 --- a/src/ecwam/sinflx_zbry.F90 +++ b/src/ecwam/sinflx_zbry.F90 @@ -440,7 +440,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & !/ 1) --- calculate 1d action density spectrum (A(sigma)) and !/ zero-out values less than 1.0E-32 to avoid NaNs when !/ computing directional narrowness in step 4). --------------- / - KK(IJ,:,:) = RESHAPE(A,(/ NANG, NFRE /)) + KK(IJ,:,:) = RESHAPE(A(IJ,:),(/ NANG, NFRE /)) ADENSIG(IJ,:) = SUM(KK(IJ,:,:),1) * SIG * DELTH ! Integrate over directions. From 014024a81823a9b8f4cf376178f3534f9316b6ea Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Fri, 17 Oct 2025 11:31:05 +0000 Subject: [PATCH 31/89] set FRIC=32 to keep equivalency with ST6-WW3 --- src/ecwam/sinflx_zbry.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/ecwam/sinflx_zbry.F90 b/src/ecwam/sinflx_zbry.F90 index 3bfca7878..f8ef4d00f 100644 --- a/src/ecwam/sinflx_zbry.F90 +++ b/src/ecwam/sinflx_zbry.F90 @@ -421,7 +421,8 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & END DO CASE(1) DO IJ = KIJS,KIJL - UPROXYGST(IJ,IGST) = FRIC * CDFAC * USTARGST(IJ,IGST) ! following Komen et al. (1984) (developed seas) (FRIC=28) + ! UPROXYGST(IJ,IGST) = FRIC * CDFAC * USTARGST(IJ,IGST) ! following Komen et al. (1984) (developed seas) (FRIC=28) + UPROXYGST(IJ,IGST) = 32.0_JWRB * CDFAC * USTARGST(IJ,IGST) ! following Komen et al. (1984) (developed seas) (FRIC=28) END DO CASE(2) DO IJ = KIJS,KIJL From 1a0944f046e666d3b489fc52b5be9d307ae02a1a Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Fri, 17 Oct 2025 12:19:47 +0000 Subject: [PATCH 32/89] merge frcutindex routines --- src/ecwam/CMakeLists.txt | 2 - src/ecwam/airsea_zbry.F90 | 1 + src/ecwam/frcutindex.F90 | 31 +++++--- src/ecwam/frcutindex_default.F90 | 97 ------------------------- src/ecwam/frcutindex_zbry.F90 | 121 ------------------------------- src/ecwam/setwavphys.F90 | 2 +- 6 files changed, 22 insertions(+), 232 deletions(-) delete mode 100644 src/ecwam/frcutindex_default.F90 delete mode 100644 src/ecwam/frcutindex_zbry.F90 diff --git a/src/ecwam/CMakeLists.txt b/src/ecwam/CMakeLists.txt index 3582a0c48..76daa75b1 100644 --- a/src/ecwam/CMakeLists.txt +++ b/src/ecwam/CMakeLists.txt @@ -82,8 +82,6 @@ list( APPEND ecwam_srcs fldinter.F90 fndprt.F90 frcutindex.F90 - frcutindex_default.F90 - frcutindex_zbry.F90 gc_dispersion.h get_preset_wgrib_template.F90 getbobstrct.F90 diff --git a/src/ecwam/airsea_zbry.F90 b/src/ecwam/airsea_zbry.F90 index ca80a338f..5b3a245a4 100644 --- a/src/ecwam/airsea_zbry.F90 +++ b/src/ecwam/airsea_zbry.F90 @@ -136,6 +136,7 @@ SUBROUTINE AIRSEA_ZBRY (KIJS, KIJL, & ! implementation of iterative scheme CASE(1,2) + !TODO: is this really needed for IPHYS2_AIRSEA=2? It drives from wind directly DO IJ=KIJS,KIJL ! -------------------------------------------- diff --git a/src/ecwam/frcutindex.F90 b/src/ecwam/frcutindex.F90 index cc4b5749e..0a9c866e6 100644 --- a/src/ecwam/frcutindex.F90 +++ b/src/ecwam/frcutindex.F90 @@ -53,15 +53,12 @@ SUBROUTINE FRCUTINDEX (KIJS, KIJL, FM, FMWS, UFRIC, CICOVER, & USE YOWPARAM , ONLY : NFRE USE YOWPCONS , ONLY : G ,EPSMIN USE YOWPHYS , ONLY : TAILFACTOR, TAILFACTOR_PM - USE YOWSTAT , ONLY : IPHYS USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK ! ---------------------------------------------------------------------- IMPLICIT NONE -#include "frcutindex_default.intfb.h" -#include "frcutindex_zbry.intfb.h" INTEGER(KIND=JWIM), INTENT(IN) :: KIJS, KIJL INTEGER(KIND=JWIM), INTENT(OUT) :: MIJ(KIJL) @@ -78,14 +75,26 @@ SUBROUTINE FRCUTINDEX (KIJS, KIJL, FM, FMWS, UFRIC, CICOVER, & IF (LHOOK) CALL DR_HOOK('FRCUTINDEX',0,ZHOOK_HANDLE) - SELECT CASE (IPHYS) - CASE(0,1) - CALL FRCUTINDEX_DEFAULT(KIJS, KIJL, FM, FMWS, UFRIC, CICOVER, & - & MIJ) - CASE(2) - CALL FRCUTINDEX_ZBRY (KIJS, KIJL, FM, UFRIC, CICOVER, & - & MIJ) - END SELECT +!* COMPUTE LAST FREQUENCY INDEX OF PROGNOSTIC PART OF SPECTRUM. +!* FREQUENCIES LE MAX(TAILFACTOR*MAX(FMNWS,FM),TAILFACTOR_PM*FPM), +!* WHERE FPM IS THE PIERSON-MOSKOWITZ FREQUENCY BASED ON FRICTION +!* VELOCITY. (FPM=G/(FRIC*ZPI*USTAR)) +! ------------------------------------------------------------ + + FPMH = TAILFACTOR/FR(1) + FPPM = TAILFACTOR_PM*G/(FRIC*ZPIFR(1)) + + DO IJ=KIJS,KIJL + IF (CICOVER(IJ) <= CITHRSH_TAIL) THEN + FM2 = MAX(FMWS(IJ),FM(IJ))*FPMH + FPM = FPPM/MAX(UFRIC(IJ),EPSMIN) + FPM4 = MAX(FM2,FPM) + MIJ(IJ) = NINT(LOG10(FPM4)*FLOGSPRDM1)+1 + MIJ(IJ) = MIN(MAX(1,MIJ(IJ)),NFRE) + ELSE + MIJ(IJ) = NFRE + ENDIF + ENDDO ! SET RHOWGDFTH DO IJ=KIJS,KIJL diff --git a/src/ecwam/frcutindex_default.F90 b/src/ecwam/frcutindex_default.F90 deleted file mode 100644 index 639bad59c..000000000 --- a/src/ecwam/frcutindex_default.F90 +++ /dev/null @@ -1,97 +0,0 @@ -! (C) Copyright 1989- ECMWF. -! -! This software is licensed under the terms of the Apache Licence Version 2.0 -! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. -! In applying this licence, ECMWF does not waive the privileges and immunities -! granted to it by virtue of its status as an intergovernmental organisation -! nor does it submit to any jurisdiction. -! - - SUBROUTINE FRCUTINDEX_DEFAULT (KIJS, KIJL, FM, FMWS, UFRIC, CICOVER, & - & MIJ) - -! ---------------------------------------------------------------------- - -!**** *FRCUTINDEX_DEFAULT* - RETURNS THE LAST FREQUENCY INDEX OF -! PROGNOSTIC PART OF SPECTRUM. - -!** INTERFACE. -! ---------- - -! *CALL* *FRCUTINDEX_DEFAULT (KIJS, KIJL, FM, FMWS, CICOVER, MIJ) -! *KIJS* - INDEX OF FIRST GRIDPOINT -! *KIJL* - INDEX OF LAST GRIDPOINT -! *FM* - MEAN FREQUENCY -! *FMWS* - MEAN FREQUENCY OF WINDSEA -! *UFRIC* - FRICTION VELOCITY IN M/S -! *CICOVER*- CICOVER -! *MIJ* - LAST FREQUENCY INDEX for imposing high frequency tail - - -! METHOD. -! ------- - -!* COMPUTES LAST FREQUENCY INDEX OF PROGNOSTIC PART OF SPECTRUM. -!* FREQUENCIES LE 2.5*MAX(FMWS,FM). - - -!!! be aware that if this is NOT used, for iphys=1, the cumulative dissipation has to be -!!! re-activated (see module yowphys) !!! - - -! ---------------------------------------------------------------------- - - USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU - - USE YOWFRED , ONLY : FR ,DFIM ,FRATIO ,FLOGSPRDM1, & - & ZPIFR, & - & DELTH ,RHOWG_DFIM ,FRIC - USE YOWICE , ONLY : CITHRSH_TAIL - USE YOWPARAM , ONLY : NFRE - USE YOWPCONS , ONLY : G ,EPSMIN - USE YOWPHYS , ONLY : TAILFACTOR, TAILFACTOR_PM - - USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK - -! ---------------------------------------------------------------------- - - IMPLICIT NONE - - INTEGER(KIND=JWIM), INTENT(IN) :: KIJS, KIJL - INTEGER(KIND=JWIM), INTENT(OUT) :: MIJ(KIJL) - REAL(KIND=JWRB),DIMENSION(KIJL), INTENT(IN) :: FM, FMWS, UFRIC, CICOVER - - - INTEGER(KIND=JWIM) :: IJ, M - - REAL(KIND=JWRB) :: FPMH, FPPM, FM2, FPM, FPM4 - REAL(KIND=JPHOOK) :: ZHOOK_HANDLE - -! ---------------------------------------------------------------------- - - IF (LHOOK) CALL DR_HOOK('FRCUTINDEX_DEFAULT',0,ZHOOK_HANDLE) - -!* COMPUTE LAST FREQUENCY INDEX OF PROGNOSTIC PART OF SPECTRUM. -!* FREQUENCIES LE MAX(TAILFACTOR*MAX(FMNWS,FM),TAILFACTOR_PM*FPM), -!* WHERE FPM IS THE PIERSON-MOSKOWITZ FREQUENCY BASED ON FRICTION -!* VELOCITY. (FPM=G/(FRIC*ZPI*USTAR)) -! ------------------------------------------------------------ - - FPMH = TAILFACTOR/FR(1) - FPPM = TAILFACTOR_PM*G/(FRIC*ZPIFR(1)) - - DO IJ=KIJS,KIJL - IF (CICOVER(IJ) <= CITHRSH_TAIL) THEN - FM2 = MAX(FMWS(IJ),FM(IJ))*FPMH - FPM = FPPM/MAX(UFRIC(IJ),EPSMIN) - FPM4 = MAX(FM2,FPM) - MIJ(IJ) = NINT(LOG10(FPM4)*FLOGSPRDM1)+1 - MIJ(IJ) = MIN(MAX(1,MIJ(IJ)),NFRE) - ELSE - MIJ(IJ) = NFRE - ENDIF - ENDDO - - IF (LHOOK) CALL DR_HOOK('FRCUTINDEX_DEFAULT',1,ZHOOK_HANDLE) - - END SUBROUTINE FRCUTINDEX_DEFAULT diff --git a/src/ecwam/frcutindex_zbry.F90 b/src/ecwam/frcutindex_zbry.F90 deleted file mode 100644 index 2add07b6c..000000000 --- a/src/ecwam/frcutindex_zbry.F90 +++ /dev/null @@ -1,121 +0,0 @@ - SUBROUTINE FRCUTINDEX_ZBRY (KIJS, KIJL, FM, UFRIC, CICOVER, & - & MIJ) - -! ---------------------------------------------------------------------- - -!**** *FRCUTINDEX_ZBRY* - RETURNS THE LAST FREQUENCY INDEX OF -! PROGNOSTIC PART OF SPECTRUM. -! -! JOSH KOUSAL & JEAN BIDLOT ECMWF 2023 -! -!** INTERFACE. -! ---------- - -! *CALL* *FRCUTINDEX_ZBRY (KIJS, KIJL, FM, UFRIC, CICOVER,MIJ) -! *KIJS* - INDEX OF FIRST GRIDPOINT -! *KIJL* - INDEX OF LAST GRIDPOINT -! *FM* - MEAN FREQUENCY -! *UFRIC* - FRICTION VELOCITY IN M/S -! *CICOVER*- CICOVER -! *MIJ* - LAST FREQUENCY INDEX for imposing high frequency tail - - - -! METHOD. -! ------- - -!* COMPUTES LAST FREQUENCY INDEX OF PROGNOSTIC PART OF SPECTRUM -! ACCORDING TO ZBRY - -! EXTERNALS. -! --------- - -! REFERENCE. -! ---------- - -! ORIGIN. -! ---------- -! Adapted from Babanin Young Donelan & Banner (ZBRY) physics -! as implemented as ST6 in WAVEWATCH-III -! WW3 module: W3SRCEMD -! WW3 subroutine: -! Implementation into ECWAM DECEMBER 2021 by J. Kousal - -! ---------------------------------------------------------------------- - - USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU - - USE YOWPHYS , ONLY : TAILFACTOR, TAILFACTOR_PM - USE YOWFRED , ONLY : FR ,DFIM ,FRATIO ,FLOGSPRDM1, & - & DELTH ,RHOWG_DFIM ,FRIC - USE YOWICE , ONLY : CITHRSH_TAIL - USE YOWPARAM , ONLY : NANG ,NFRE - USE YOWPCONS , ONLY : G ,ZPI ,EPSMIN, EPSUS - USE YOMHOOK , ONLY : LHOOK, DR_HOOK - -! ---------------------------------------------------------------------- - - IMPLICIT NONE - - INTEGER(KIND=JWIM), INTENT(IN) :: KIJS, KIJL - INTEGER(KIND=JWIM), INTENT(OUT) :: MIJ(KIJL) - - REAL(KIND=JWRB),DIMENSION(KIJL), INTENT(IN) :: FM, UFRIC, CICOVER - - REAL(KIND=JWRB) :: ZHOOK_HANDLE - - INTEGER(KIND=JWIM) :: IJ, NK, NKH, NKH1, M - REAL(KIND=JWRB), PARAMETER :: SIN6FC = 6.0_JWRB - REAL(KIND=JWRB) :: FXFM, FXPM, FACTI1, FACTI2 ! constants - REAL(KIND=JWRB) :: FHIGH ! Cut-off frequency in integration (rad/s) - REAL(KIND=JWRB) :: SIGNK ! LAST FREQUENCY [RAD] - REAL(KIND=JWRB) :: USTM1 - - -! ---------------------------------------------------------------------- - - IF (LHOOK) CALL DR_HOOK('FRCUTINDEX_ZBRY',0,ZHOOK_HANDLE) - - NK = NFRE - FXFM = SIN6FC - FXFM = FXFM * ZPI - FXPM = 4.0_JWRB !TODO: 4.0_JWRB is the factor for the tail (is this right) - FXPM = FXPM * G / FRIC - SIGNK = ZPI*FR(NFRE) - - DO IJ=KIJS,KIJL - IF (CICOVER(IJ) <= CITHRSH_TAIL) THEN - - USTM1 = 1.0_JWRB/MAX(UFRIC(IJ),EPSUS) ! Protect the code - - IF (FXFM .LE. 0) THEN - FHIGH = SIGNK ! LAST FREQ i.e. let tail evolve freely - ELSE - FHIGH = MAX (FXFM * FM(IJ), FXPM * USTM1 ) - ENDIF - - - FACTI1 = 1.0_JWRB / LOG(FRATIO) - FACTI2 = 1.0_JWRB - LOG(ZPI*FR(1)) * FACTI1 - - NKH = MIN ( NK , INT(FACTI2+FACTI1*LOG(MAX(1.0E-7_JWRB,FHIGH))) ) - NKH1 = MIN ( NK , NKH+1 ) - - - IF (FXFM .LE. 0) THEN - FHIGH = SIGNK - ELSE - FHIGH = MIN ( SIGNK, MAX(FXFM * FM(IJ), FXPM * USTM1) ) - ENDIF - NKH = MAX ( 2 , MIN ( NKH1 , & - INT ( FACTI2 + FACTI1*LOG(MAX(1.0E-7_JWRB,FHIGH)) ) ) ) - - MIJ(IJ) = NKH - ELSE - MIJ(IJ) = NFRE - ENDIF - END DO - - IF (LHOOK) CALL DR_HOOK('FRCUTINDEX_ZBRY',1,ZHOOK_HANDLE) - - END SUBROUTINE FRCUTINDEX_ZBRY diff --git a/src/ecwam/setwavphys.F90 b/src/ecwam/setwavphys.F90 index 337f07692..bfa076c38 100644 --- a/src/ecwam/setwavphys.F90 +++ b/src/ecwam/setwavphys.F90 @@ -229,7 +229,7 @@ SUBROUTINE SETWAVPHYS ALPHA = 0.0065_JWRB CDFAC = 1.0_JWRB TAILFACTOR=6.0_JWRB ! SIN6FC = 6.0 from WW3-ST6 - TAILFACTOR_PM=4.0_JWRB ! FXPM = 4.0 from WW3-ST6 + TAILFACTOR_PM=4.0_JWRB ! FXPM = 4.0 from WW3 (all) ZSIN6A0 = 9.0E-2_JWRB ZSWL6B1 = 0.0041_JWRB From e7d28f14290b49b8a84e3becfe7b165c57032cd2 Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Fri, 17 Oct 2025 12:24:16 +0000 Subject: [PATCH 33/89] tidy up some comments --- src/ecwam/sdissip_zbry.F90 | 18 +++++------------- src/ecwam/sinflx_zbry.F90 | 12 ++++-------- src/ecwam/swldissip_zbry.F90 | 8 +------- 3 files changed, 10 insertions(+), 28 deletions(-) diff --git a/src/ecwam/sdissip_zbry.F90 b/src/ecwam/sdissip_zbry.F90 index b4cd5277c..15c877f9c 100644 --- a/src/ecwam/sdissip_zbry.F90 +++ b/src/ecwam/sdissip_zbry.F90 @@ -132,13 +132,14 @@ SUBROUTINE SDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & SIG(M) = ZPI*FR(M) END DO -! COMPUTE FREQUENCY INTERVALLS (borrowed from Wam_others/f4spec.F) +! COMPUTE FREQUENCY INTERVALLS DO M = 1,NFRE DF(M) = FR(M)*( FRATIO - 1.0_JWRB ) ENDDO IKN = IRANGE(1,NSPEC,NANG) ! Index vector for elements of 1 ... NFRE -! ! such that e.g. SIG(1:NFRE) = SIG2(IKN). +! ! such that e.g. SIG(1:NFRE) = SIG2(IKN). + DO K = 1, NANG ! Apply to all directions SIG2 (IKN+(K-1)) = SIG END DO @@ -156,8 +157,8 @@ SUBROUTINE SDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & !/ 0) --- Initialize essential parameters ---------------------------- / IKN = IRANGE(1,NSPEC,NANG) ! Index vector for elements of 1, -! ! 2,..., NFRE such that for example -! ! SIG(1:NFRE) = SIG2(IKN). +! ! 2,..., NFRE such that for example +! ! SIG(1:NFRE) = SIG2(IKN). FREQ = FR(1:NFRE) BNT = 0.035_JWRB**2 DO IJ = KIJS,KIJL @@ -227,15 +228,6 @@ SUBROUTINE SDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & END DO ! ! -!/ 5) --- Diagnostic output (switch !/T6) ---------------------------- / -!/T6 CALL STME21 ( TIME , IDTIME ) -!/T6 WRITE (NDST,270) 'T1*E',IDTIME(1:19),(T1*EDENS) -!/T6 WRITE (NDST,270) 'T2*E',IDTIME(1:19),(T2*EDENS) -!/T6 WRITE (NDST,271) SUM(SUM(RESHAPE(S,(/ NANG,NFRE /)),1)*DDEN/CG) -! -!/T6 270 FORMAT (' TEST W3SDS6 : ',A,'(',A,')',':',70E11.3) -!/T6 271 FORMAT (' TEST W3SDS6 : Total SDS =',E13.5) - DO IJ = KIJS,KIJL DDS(IJ,:,:) = RESHAPE(D(IJ,:),(/NANG,NFRE/)) END DO diff --git a/src/ecwam/sinflx_zbry.F90 b/src/ecwam/sinflx_zbry.F90 index f8ef4d00f..914885788 100644 --- a/src/ecwam/sinflx_zbry.F90 +++ b/src/ecwam/sinflx_zbry.F90 @@ -294,7 +294,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & ! Wind height ZNLEV = 10._JWRB -! COMPUTE FREQUENCY INTERVALLS (borrowed from Wam_others/f4spec.F) +! COMPUTE FREQUENCY INTERVALLS DO M = 1,NFRE DF(M) = FR(M)*( FRATIO - 1.0_JWRB ) ENDDO @@ -319,7 +319,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & END DO ! IKN = IRANGE(1,NSPEC,NANG) ! Index vector for elements of 1 ... NFRE -! ! such that e.g. SIG(1:NFRE) = SIG2(IKN). +! ! such that e.g. SIG(1:NFRE) = SIG2(IKN). DO K = 1, NANG ! Apply to all directions SIG2 (IKN+(K-1)) = SIG @@ -366,13 +366,11 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & Z0CH = PCHAROG*UST**2 Z0VIS = ZRN/UST Z0GST(IJ,IGST) = Z0CH+Z0VIS - ENDDO ! IJ loop ENDDO -ENDDO ! NGST loop ENDDO + ENDDO +ENDDO !/ --- Main loop over LOC ----------------------------------- / - -! LOOP OVER LOCATIONS DO K = 1, NANG DO IJ = KIJS,KIJL WN2 (IJ,IKN+(K-1)) = WAVNUM(IJ,:) ! using WAM native WN,CG @@ -659,8 +657,6 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & SNEGDENSIG = SL(IJ,:,:) - SPOS(IJ,:,:) PHIWA(IJ) = CALCPHIWA(SPOSDENSIG,SNEGDENSIG,DSII) END DO -! END LOOP OVER LOC -! --------------------- ! XLLWS based on SL (mask for neg. input) DO M = 1,NFRE diff --git a/src/ecwam/swldissip_zbry.F90 b/src/ecwam/swldissip_zbry.F90 index 4bd16d17a..85a966fc7 100644 --- a/src/ecwam/swldissip_zbry.F90 +++ b/src/ecwam/swldissip_zbry.F90 @@ -113,7 +113,7 @@ SUBROUTINE SWLDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & END DO IKN = IRANGE(1,NSPEC,NANG) ! Index vector for elements of 1 ... NFRE -! ! such that e.g. SIG(1:NFRE) = SIG2(IKN). +! ! such that e.g. SIG(1:NFRE) = SIG2(IKN). DO K = 1, NANG ! Apply to all directions SIG2 (IKN+(K-1)) = SIG END DO @@ -192,12 +192,6 @@ SUBROUTINE SWLDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & END DO END DO ! -! WRITE(*,*) ' B1 =',B1 -! WRITE(*,*) ' DDIS_tot =',SUM(DDIS*ABAND*DDEN/CG) -! WRITE(*,*) ' EDENS_tot=',sum(aband*dden/cg) -! WRITE(*,*) ' EDENS_tot=',sum(aband*sig*dth*dsii/cg) -! WRITE(*,*) ' ' -! WRITE(*,*) ' SWL6_tot =',sum(SUM(RESHAPE(S,(/ NANG,NFRE /)),1)*DDEN/CG) DO IJ = KIJS,KIJL DSWL(IJ,:,:) = RESHAPE(D(IJ,:),(/NANG,NFRE/)) END DO From 1065e24b99b40bc073484077aa2985adb155ff1b Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Fri, 17 Oct 2025 12:27:53 +0000 Subject: [PATCH 34/89] small reorganization --- src/ecwam/yowphys.F90 | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/src/ecwam/yowphys.F90 b/src/ecwam/yowphys.F90 index fc6d67fde..d270f0d12 100644 --- a/src/ecwam/yowphys.F90 +++ b/src/ecwam/yowphys.F90 @@ -35,12 +35,6 @@ MODULE YOWPHYS ! *BETAMAX* PARAMETER FOR WIND INPUT. REAL(KIND=JWRB) :: BETAMAX -! *CDFAC* PARAMETER FOR WIND INPUT FOR ZBRY PHYS. - REAL(KIND=JWRB) :: CDFAC - -! *SIN6A0* PARAMETER FOR NEGATIVE WIND INPUT (a0) FOR ZBRY PHYS - REAL(KIND=JWRB) :: ZSIN6A0 - ! *BETAMAXOXKAPPA2* BETAMAX/XKAPPA**2 REAL(KIND=JWRB) :: BETAMAXOXKAPPA2 @@ -156,6 +150,15 @@ MODULE YOWPHYS ! Wave-turbulence interaction coefficient REAL(KIND=JWRB) :: SSDSC5 !! See *SETWAVPHYS* +! ZBRY PHYS :: +! ========== + +! *CDFAC* PARAMETER FOR WIND INPUT FOR ZBRY PHYS. + REAL(KIND=JWRB) :: CDFAC + +! *SIN6A0* PARAMETER FOR NEGATIVE WIND INPUT (a0) FOR ZBRY PHYS + REAL(KIND=JWRB) :: ZSIN6A0 + ! Swell attenuation logical for ZBRY physics LOGICAL :: LLSWL6CSTB1 From 7de500d609625eafc6c3e751187a728e35fb614d Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Mon, 20 Oct 2025 14:31:42 +0000 Subject: [PATCH 35/89] reorganize NGST, CDFAC --- src/ecwam/mpuserin.F90 | 2 +- src/ecwam/setwavphys.F90 | 30 +++++++++++++++++++++--------- src/ecwam/sinflx.F90 | 8 +------- src/ecwam/sinflx_zbry.F90 | 18 +++++------------- src/ecwam/yowphys.F90 | 3 +++ 5 files changed, 31 insertions(+), 30 deletions(-) diff --git a/src/ecwam/mpuserin.F90 b/src/ecwam/mpuserin.F90 index cdcdc348f..230156c39 100644 --- a/src/ecwam/mpuserin.F90 +++ b/src/ecwam/mpuserin.F90 @@ -608,7 +608,7 @@ SUBROUTINE MPUSERIN ICASE = 1 ISHALLO = 0 !! depricated IPHYS = 1 - IPHYS2_AIRSEA = 2 + IPHYS2_AIRSEA = 1 LLLOWWINDS = .FALSE. ! .TRUE. if low winds are treated differently ISNONLIN = 1 IDAMPING = 1 diff --git a/src/ecwam/setwavphys.F90 b/src/ecwam/setwavphys.F90 index bfa076c38..832bbaea6 100644 --- a/src/ecwam/setwavphys.F90 +++ b/src/ecwam/setwavphys.F90 @@ -27,7 +27,7 @@ SUBROUTINE SETWAVPHYS & ANG_GC_A, ANG_GC_B, ANG_GC_C, & & SWELLF4, SWELLF7, SWELLF7M1, Z0TUBMAX, Z0RAT, & & SSDSC5, CDFAC, ZSIN6A0, LLSWL6CSTB1, ZSWL6B1, & - & ZSDS6A1, ZSDS6A2, ISDS6P1, ISDS6P2, LLSDS6ET + & ZSDS6A1, ZSDS6A2, ISDS6P1, ISDS6P2, LLSDS6ET, NGST USE YOWSTAT , ONLY : IPHYS, IPHYS2_AIRSEA USE YOWTEST , ONLY : IU06 @@ -218,18 +218,30 @@ SUBROUTINE SETWAVPHYS ASWKM=0.0981_JWRB BSWKM=0.425_JWRB - IF (IPHYS2_AIRSEA==0) THEN - ! NGST=1 (handled in SINFLX) + SELECT CASE (IPHYS2_AIRSEA) + CASE(0) + NGST=1 ALPHAPMAX = 1.0_JWRB ! i.e. no cap on max spectral steepness - ELSE IF (IPHYS2_AIRSEA==1 .OR. IPHYS2_AIRSEA==2) THEN - ! NGST=2 (handled in SINFLX) + TAILFACTOR=6.0_JWRB ! SIN6FC = 6.0 from WW3-ST6 + TAILFACTOR_PM=4.0_JWRB ! FXPM = 4.0 from WW3 (all) + CASE(1,2) + NGST=2 ALPHAPMAX = 0.031_JWRB ! cap on spectral steepness as in ARD - END IF + TAILFACTOR=2.5_JWRB + TAILFACTOR_PM=3.0_JWRB ! as in ARD + CASE DEFAULT + WRITE (IU06,*) '*************************************' + WRITE (IU06,*) '* *' + WRITE (IU06,*) '* ERROR IN SETWAVPHYS *' + WRITE (IU06,*) '* UKNOWN PHYSICS SELECTION : *' + WRITE (IU06,*) '* IPHYS2_AIRSEA =' , IPHYS2_AIRSEA + WRITE (IU06,*) '* *' + WRITE (IU06,*) '*************************************' + CALL ABORT1 + END SELECT ALPHA = 0.0065_JWRB - CDFAC = 1.0_JWRB - TAILFACTOR=6.0_JWRB ! SIN6FC = 6.0 from WW3-ST6 - TAILFACTOR_PM=4.0_JWRB ! FXPM = 4.0 from WW3 (all) + CDFAC = 1.143_JWRB ! differing FRIC values used between WW3-ST6 and ecWAM (32/28=1.143) ZSIN6A0 = 9.0E-2_JWRB ZSWL6B1 = 0.0041_JWRB diff --git a/src/ecwam/sinflx.F90 b/src/ecwam/sinflx.F90 index 5d9d96b51..a069384a0 100644 --- a/src/ecwam/sinflx.F90 +++ b/src/ecwam/sinflx.F90 @@ -31,7 +31,7 @@ SUBROUTINE SINFLX (ICALL, NCALL, KIJS, KIJL, & USE YOWCOUP , ONLY : LWCOU ,LLCAPCHNK , LLGCBZ0, LLNORMAGAM USE YOWPARAM , ONLY : NANG ,NFRE - USE YOWPHYS , ONLY : DTHRN_A ,DTHRN_U + USE YOWPHYS , ONLY : DTHRN_A ,DTHRN_U, NGST USE YOWWNDG , ONLY : ICODE ,ICODE_CPL USE YOWSTAT , ONLY : IPHYS ,IPHYS2_AIRSEA @@ -89,7 +89,6 @@ SUBROUTINE SINFLX (ICALL, NCALL, KIJS, KIJL, & INTEGER(KIND=JWIM) :: IJ, K INTEGER(KIND=JWIM) :: IUSFG, ICODE_WND -INTEGER(KIND=JWIM) :: NGST REAL(KIND=JPHOOK) :: ZHOOK_HANDLE REAL(KIND=JWRB), DIMENSION(KIJL) :: RNFAC @@ -116,11 +115,6 @@ SUBROUTINE SINFLX (ICALL, NCALL, KIJS, KIJL, & & FLD, SL, SPOS, & & MIJ, RHOWGDFTH, XLLWS) CASE(2) - IF (IPHYS2_AIRSEA==0) THEN - NGST=1 - ELSE IF (IPHYS2_AIRSEA==1 .OR. IPHYS2_AIRSEA==2) THEN - NGST=2 - END IF CALL SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & & LUPDTUS, & & FL1, & diff --git a/src/ecwam/sinflx_zbry.F90 b/src/ecwam/sinflx_zbry.F90 index 914885788..485728fa3 100644 --- a/src/ecwam/sinflx_zbry.F90 +++ b/src/ecwam/sinflx_zbry.F90 @@ -92,7 +92,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU - USE YOWCOUP , ONLY : LWCOU ,LLCAPCHNK , LLGCBZ0, LLNORMAGAM + USE YOWCOUP , ONLY : LWCOU ,LLCAPCHNK USE YOWWNDG , ONLY : ICODE ,ICODE_CPL @@ -251,7 +251,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & ICODE_WND = 3 ENDIF -IF(LLNORMAGAM .AND. LLCAPCHNK ) THEN +IF(LLCAPCHNK) THEN RNFAC(KIJS:KIJL) = 1.0_JWRB+DTHRN_A*(1.0_JWRB+TANH(WSWAVE(KIJS:KIJL)-DTHRN_U)) ELSE RNFAC(KIJS:KIJL) = 1.0_JWRB @@ -264,14 +264,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & DO K=1,NANG FL1(KIJS:KIJL,K,NFRE) = MAX(FL1(KIJS:KIJL,K,NFRE),FLM(KIJS:KIJL,K)) ENDDO - - IF (LLGCBZ0) THEN - !$loki inline - CALL HALPHAP(KIJS, KIJL, WAVNUM, COSWDIF, FL1, HALP) - ELSE - HALP(KIJS:KIJL) = 0.0_JWRB - ENDIF - + HALP(KIJS:KIJL) = 0.0_JWRB ENDIF !$loki inline @@ -415,12 +408,11 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & SELECT CASE (IPHYS2_AIRSEA) CASE(0) DO IJ = KIJS,KIJL - UPROXYGST(IJ,IGST) = 32.0_JWRB * CDFAC * USTARGST(IJ,IGST) ! original, suggested by E. Rogers (2014) (young seas) + UPROXYGST(IJ,IGST) = FRIC * CDFAC * USTARGST(IJ,IGST) ! original, suggested by E. Rogers (2014) (young seas) END DO CASE(1) DO IJ = KIJS,KIJL - ! UPROXYGST(IJ,IGST) = FRIC * CDFAC * USTARGST(IJ,IGST) ! following Komen et al. (1984) (developed seas) (FRIC=28) - UPROXYGST(IJ,IGST) = 32.0_JWRB * CDFAC * USTARGST(IJ,IGST) ! following Komen et al. (1984) (developed seas) (FRIC=28) + UPROXYGST(IJ,IGST) = FRIC * CDFAC * USTARGST(IJ,IGST) ! following Komen et al. (1984) (developed seas) (FRIC=28) END DO CASE(2) DO IJ = KIJS,KIJL diff --git a/src/ecwam/yowphys.F90 b/src/ecwam/yowphys.F90 index d270f0d12..8d9c363b0 100644 --- a/src/ecwam/yowphys.F90 +++ b/src/ecwam/yowphys.F90 @@ -180,6 +180,9 @@ MODULE YOWPHYS ! Dissipation, logical to normalise by **threshold** spectral density LOGICAL :: LLSDS6ET +! Number of standard deviations to used for wind dustiness + INTEGER(KIND=JWIM) :: NGST + ! NSDSNTH is the number of directions on both used to compute the spectral saturation INTEGER(KIND=JWIM) :: NSDSNTH From 549f543ef9f71da6971bc018f9fa5890c5e1d480 Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Mon, 20 Oct 2025 14:35:59 +0000 Subject: [PATCH 36/89] fix typo --- src/ecwam/yowphys.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/ecwam/yowphys.F90 b/src/ecwam/yowphys.F90 index 8d9c363b0..0aefcbb8c 100644 --- a/src/ecwam/yowphys.F90 +++ b/src/ecwam/yowphys.F90 @@ -180,7 +180,7 @@ MODULE YOWPHYS ! Dissipation, logical to normalise by **threshold** spectral density LOGICAL :: LLSDS6ET -! Number of standard deviations to used for wind dustiness +! Integer defining whether or not wind gustiness parametrization is used (1=no, 2=yes) INTEGER(KIND=JWIM) :: NGST ! NSDSNTH is the number of directions on both used to compute the spectral saturation From a856eeadb4cd8620fee2439be02cb81940a645fe Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Tue, 21 Oct 2025 10:40:26 +0000 Subject: [PATCH 37/89] revert and tidy CDFAC & FRIC dealings --- src/ecwam/airsea_zbry.F90 | 4 +--- src/ecwam/outbeta.F90 | 2 +- src/ecwam/setwavphys.F90 | 2 +- src/ecwam/sinflx_zbry.F90 | 4 ++-- 4 files changed, 5 insertions(+), 7 deletions(-) diff --git a/src/ecwam/airsea_zbry.F90 b/src/ecwam/airsea_zbry.F90 index 5b3a245a4..386062d5f 100644 --- a/src/ecwam/airsea_zbry.F90 +++ b/src/ecwam/airsea_zbry.F90 @@ -135,9 +135,7 @@ SUBROUTINE AIRSEA_ZBRY (KIJS, KIJL, & ENDDO ! implementation of iterative scheme - CASE(1,2) - !TODO: is this really needed for IPHYS2_AIRSEA=2? It drives from wind directly - + CASE(1,2) DO IJ=KIJS,KIJL ! -------------------------------------------- ! Iterative method diff --git a/src/ecwam/outbeta.F90 b/src/ecwam/outbeta.F90 index 5160d343f..acaf73db1 100644 --- a/src/ecwam/outbeta.F90 +++ b/src/ecwam/outbeta.F90 @@ -126,7 +126,7 @@ SUBROUTINE OUTBETA (KIJS, KIJL, & ENDDO IF( PRESENT(CD) ) THEN - IF (IPHYS==2 .AND. IPHYS2_AIRSEA==0) THEN + IF (IPHYS==2) THEN ! Don't use this for coupled, only for diagnosing DO IJ = KIJS,KIJL CD(IJ) = (USTAR(IJ)/U10(IJ))**2 ENDDO diff --git a/src/ecwam/setwavphys.F90 b/src/ecwam/setwavphys.F90 index 832bbaea6..21501577b 100644 --- a/src/ecwam/setwavphys.F90 +++ b/src/ecwam/setwavphys.F90 @@ -241,7 +241,7 @@ SUBROUTINE SETWAVPHYS END SELECT ALPHA = 0.0065_JWRB - CDFAC = 1.143_JWRB ! differing FRIC values used between WW3-ST6 and ecWAM (32/28=1.143) + CDFAC = 1.0_JWRB ZSIN6A0 = 9.0E-2_JWRB ZSWL6B1 = 0.0041_JWRB diff --git a/src/ecwam/sinflx_zbry.F90 b/src/ecwam/sinflx_zbry.F90 index 485728fa3..ad9a750bf 100644 --- a/src/ecwam/sinflx_zbry.F90 +++ b/src/ecwam/sinflx_zbry.F90 @@ -408,11 +408,11 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & SELECT CASE (IPHYS2_AIRSEA) CASE(0) DO IJ = KIJS,KIJL - UPROXYGST(IJ,IGST) = FRIC * CDFAC * USTARGST(IJ,IGST) ! original, suggested by E. Rogers (2014) (young seas) + UPROXYGST(IJ,IGST) = 32.0_JWRB * CDFAC * USTARGST(IJ,IGST) ! original, suggested by E. Rogers (2014) (young seas) END DO CASE(1) DO IJ = KIJS,KIJL - UPROXYGST(IJ,IGST) = FRIC * CDFAC * USTARGST(IJ,IGST) ! following Komen et al. (1984) (developed seas) (FRIC=28) + UPROXYGST(IJ,IGST) = 32.0_JWRB * CDFAC * USTARGST(IJ,IGST) ! following Komen et al. (1984) (developed seas) (FRIC=28) END DO CASE(2) DO IJ = KIJS,KIJL From 31dc2c7980ebbd980fc2675734e73cb1f476eb9c Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Tue, 21 Oct 2025 12:07:01 +0000 Subject: [PATCH 38/89] extend CALCPHIWA for high frequencies --- src/ecwam/calcphiwa.F90 | 159 ++++++++++++++++++++++++-------------- src/ecwam/sinflx_zbry.F90 | 2 +- 2 files changed, 104 insertions(+), 57 deletions(-) diff --git a/src/ecwam/calcphiwa.F90 b/src/ecwam/calcphiwa.F90 index 525a61e1e..e4d6630ed 100644 --- a/src/ecwam/calcphiwa.F90 +++ b/src/ecwam/calcphiwa.F90 @@ -1,57 +1,104 @@ -FUNCTION CALCPHIWA(SPOS,SNEG,DSII) RESULT(PHIWA) - - ! ---------------------------------------------------------------------------- - ! - ! 1. Purpose : - ! - ! Calculate energy flux from wind into waves, obtained from wind-energy-input (Sin). - ! - ! / FRMAX - ! tau = g * rho_water * | Sin(f) df - ! / - - !---------------------------------------------------------------------- - ! - ! INTERFACE VARIABLES. - ! -------------------- - - ! ORIGIN. - ! ---------- - ! Adapted from TAUWINDS - ! Implementation into ECWAM DECEMBER 2021 by J. Kousal - - ! ---------------------------------------------------------------------------- - ! - - USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU - USE YOWPCONS , ONLY : G ,ROWATER - USE YOWFRED , ONLY : DELTH - USE YOWPARAM , ONLY : NANG ,NFRE - USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK - - !---------------------------------------------------------------------- - - IMPLICIT NONE - - REAL(KIND=JWRB), DIMENSION(NANG,NFRE), INTENT(IN) :: SPOS ! POS Sin(sigma) in [m2/rad-Hz] - REAL(KIND=JWRB), DIMENSION(NANG,NFRE), INTENT(IN) :: SNEG ! NEG Sin(sigma) in [m2/rad-Hz] - REAL(KIND=JWRB), DIMENSION(NFRE), INTENT(IN) :: DSII ! freq. bandwidths in [radians] - - REAL(KIND=JWRB), DIMENSION(NFRE) :: SPOSDENSIG, SNEGDENSIG - - REAL(KIND=JWRB) :: PHIWA - REAL(KIND=JPHOOK) :: ZHOOK_HANDLE - - ! ---------------------------------------------------------------------------- - ! - - IF (LHOOK) CALL DR_HOOK('CALCPHIWA',0,ZHOOK_HANDLE) - - SPOSDENSIG = SUM(SPOS,1) * DELTH - SNEGDENSIG = SUM(SNEG,1) * DELTH - PHIWA = G * ROWATER * ( SUM(SPOSDENSIG*DSII) + SUM(SNEGDENSIG*DSII) ) - - IF (LHOOK) CALL DR_HOOK('CALCPHIWA',1,ZHOOK_HANDLE) +FUNCTION CALCPHIWA(SPOS,SNEG,DSII,SIG) RESULT(PHIWA) + +! ---------------------------------------------------------------------------- +! +! 1. Purpose : +! +! Calculate energy flux from wind into waves, obtained from wind-energy-input (Sin). +! +! / FRMAX +! tau = g * rho_water * | Sin(f) df +! / + +!---------------------------------------------------------------------- +! +! INTERFACE VARIABLES. +! -------------------- + +! ORIGIN. +! ---------- +! Adapted from TAUWINDS +! Implementation into ECWAM DECEMBER 2021 by J. Kousal + +! ---------------------------------------------------------------------------- +! + + USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU + USE YOWPCONS , ONLY : G ,ROWATER, ZPI + USE YOWFRED , ONLY : DELTH, FRATIO + USE YOWPARAM , ONLY : NANG ,NFRE + USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK + +!---------------------------------------------------------------------- + + IMPLICIT NONE +#include "irange.intfb.h" + + REAL(KIND=JWRB), DIMENSION(NANG,NFRE), INTENT(IN) :: SPOS ! POS Sin(sigma) in [m2/rad-Hz] + REAL(KIND=JWRB), DIMENSION(NANG,NFRE), INTENT(IN) :: SNEG ! NEG Sin(sigma) in [m2/rad-Hz] + REAL(KIND=JWRB), DIMENSION(NFRE), INTENT(IN) :: DSII ! freq. bandwidths in [radians] + REAL(KIND=JWRB), DIMENSION(NFRE), INTENT(IN) :: SIG + + REAL(KIND=JWRB), PARAMETER :: FRQMAX = 10.0_JWRB ! Upper freq. limit to extrap. to + REAL, ALLOCATABLE :: IK10Hz(:), SIG10Hz(:) + REAL, ALLOCATABLE :: SPOSDENS10Hz(:), SNEGDENS10Hz(:), DSII10Hz(:) + + INTEGER(KIND=JWIM) :: NK10Hz + INTEGER(KIND=JWIM) :: NK, NTH + INTEGER(KIND=JWIM), DIMENSION(NANG) :: ITHN + + REAL(KIND=JWRB) :: PHIWA + REAL(KIND=JPHOOK) :: ZHOOK_HANDLE - END FUNCTION CALCPHIWA - \ No newline at end of file +! ---------------------------------------------------------------------------- +! + + IF (LHOOK) CALL DR_HOOK('CALCPHIWA',0,ZHOOK_HANDLE) + + + NTH = NANG ! NUMBER OF DIRS , SAME AS KL + NK = NFRE ! NUMBER OF FREQS, SAME AS ML + +!/ 0) --- Find the number of frequencies required to extend arrays +!/ up to f=10Hz and allocate arrays --------------------------- / + NK10Hz = CEILING(LOG(FRQMAX/(SIG(1)/ZPI))/LOG(FRATIO))+1 + NK10Hz = MAX(NK,NK10Hz) +! + ALLOCATE(IK10Hz(NK10Hz)) + IK10Hz = REAL( IRANGE(1,NK10Hz,1) ) +! + ALLOCATE(SPOSDENS10Hz(NK10Hz)) + ALLOCATE(SNEGDENS10Hz(NK10Hz)) + ALLOCATE(DSII10Hz(NK10Hz)) + ALLOCATE(SIG10Hz(NK10Hz)) +! + ITHN = IRANGE(1,NTH,1) ! Index vector 1:NTH +! +!/ 1) --- Either extrapolate arrays up to 10Hz or use discrete spectral +! grid per se. Limit the constraint to the positive part of the +! wind input only. ---------------------------------------------- / + IF (NK .LT. NK10Hz) THEN + SPOSDENS10Hz(1:NK) = SUM(SPOS,1) * DELTH + SNEGDENS10Hz(1:NK) = SUM(SNEG,1) * DELTH + SIG10Hz = SIG(1)*FRATIO**(IK10Hz-1.0_JWRB) + DSII10Hz = 0.5_JWRB * SIG10Hz * (FRATIO-1.0_JWRB/FRATIO) +! The first and last frequency bin: + DSII10Hz(1) = 0.5_JWRB * SIG10Hz(1) * (FRATIO-1.0_JWRB) + DSII10Hz(NK10Hz) = 0.5_JWRB * SIG10Hz(NK10Hz) * (FRATIO-1.0_JWRB) / FRATIO +! +! --- Spectral slope for S_IN(F) is proportional to F**(-2) ------ / + SPOSDENS10Hz(NK+1:NK10Hz) = SPOSDENS10Hz(NK) * (SIG10Hz(NK)/SIG10Hz(NK+1:NK10Hz))**2 + SNEGDENS10Hz(NK+1:NK10Hz) = SNEGDENS10Hz(NK) * (SIG10Hz(NK)/SIG10Hz(NK+1:NK10Hz))**2 + ELSE + SIG10Hz = SIG + DSII10Hz = DSII + SPOSDENS10Hz(1:NK) = SUM(SPOS,1) * DELTH + SNEGDENS10Hz(1:NK) = SUM(SNEG,1) * DELTH + END IF + +!/ 2) --- Calculate PHIWA from the extended arrays ------------------- / + PHIWA = G * ROWATER * ( SUM(SPOSDENS10Hz*DSII10Hz) + SUM(SNEGDENS10Hz*DSII10Hz) ) + + IF (LHOOK) CALL DR_HOOK('CALCPHIWA',1,ZHOOK_HANDLE) + + END FUNCTION CALCPHIWA diff --git a/src/ecwam/sinflx_zbry.F90 b/src/ecwam/sinflx_zbry.F90 index ad9a750bf..d65a4f0be 100644 --- a/src/ecwam/sinflx_zbry.F90 +++ b/src/ecwam/sinflx_zbry.F90 @@ -647,7 +647,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & SPOSDENSIG = SPOS(IJ,:,:) SNEGDENSIG = SL(IJ,:,:) - SPOS(IJ,:,:) - PHIWA(IJ) = CALCPHIWA(SPOSDENSIG,SNEGDENSIG,DSII) + PHIWA(IJ) = CALCPHIWA(SPOSDENSIG,SNEGDENSIG,DSII,SIG) END DO ! XLLWS based on SL (mask for neg. input) From 4b44f4bafbaa0f5309f76d72fabd4d1214fd9428 Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Tue, 21 Oct 2025 13:30:24 +0000 Subject: [PATCH 39/89] correct ZPI bug --- src/ecwam/calcphiwa.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/ecwam/calcphiwa.F90 b/src/ecwam/calcphiwa.F90 index e4d6630ed..a1eeb50a9 100644 --- a/src/ecwam/calcphiwa.F90 +++ b/src/ecwam/calcphiwa.F90 @@ -97,7 +97,7 @@ FUNCTION CALCPHIWA(SPOS,SNEG,DSII,SIG) RESULT(PHIWA) END IF !/ 2) --- Calculate PHIWA from the extended arrays ------------------- / - PHIWA = G * ROWATER * ( SUM(SPOSDENS10Hz*DSII10Hz) + SUM(SNEGDENS10Hz*DSII10Hz) ) + PHIWA = G * ROWATER * ( SUM(SPOSDENS10Hz*DSII10Hz) + SUM(SNEGDENS10Hz*DSII10Hz) ) / ZPI IF (LHOOK) CALL DR_HOOK('CALCPHIWA',1,ZHOOK_HANDLE) From c5dd1ec1a854a55f6ef6bd6bb69ab4e00acbf190 Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Tue, 21 Oct 2025 14:08:37 +0000 Subject: [PATCH 40/89] IPHYS=2 doesn't need special treatment --- src/ecwam/outbeta.F90 | 18 ++++++------------ 1 file changed, 6 insertions(+), 12 deletions(-) diff --git a/src/ecwam/outbeta.F90 b/src/ecwam/outbeta.F90 index acaf73db1..adee074d4 100644 --- a/src/ecwam/outbeta.F90 +++ b/src/ecwam/outbeta.F90 @@ -126,18 +126,12 @@ SUBROUTINE OUTBETA (KIJS, KIJL, & ENDDO IF( PRESENT(CD) ) THEN - IF (IPHYS==2) THEN ! Don't use this for coupled, only for diagnosing - DO IJ = KIJS,KIJL - CD(IJ) = (USTAR(IJ)/U10(IJ))**2 - ENDDO - ELSE - DO IJ = KIJS,KIJL - !!! we are assuming here that z0 = RNUM/USTAR + Charnock USTAR**2/g - !!! in order to fit with what is used in the IFS. - Z0ATM = RNUM*USM(IJ) + GM1 * BETAM(IJ) * USTAR(IJ)**2 - CD(IJ) = ( XKAPPA / LOG( 1.0_JWRB + XNLEV/Z0ATM) )**2 - ENDDO - ENDIF + DO IJ = KIJS,KIJL +!!! we are assuming here that z0 = RNUM/USTAR + Charnock USTAR**2/g +!!! in order to fit with what is used in the IFS. + Z0ATM = RNUM*USM(IJ) + GM1 * BETAM(IJ) * USTAR(IJ)**2 + CD(IJ) = ( XKAPPA / LOG( 1.0_JWRB + XNLEV/Z0ATM) )**2 + ENDDO ENDIF IF (LHOOK) CALL DR_HOOK('OUTBETA',1,ZHOOK_HANDLE) From a47876a502ee2f3e6617136a6df384cceeb41a82 Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Tue, 21 Oct 2025 14:11:15 +0000 Subject: [PATCH 41/89] update my test cases with handy variables --- tests/etopo1_oper_an_fc_O48_cy50r1.yml | 1 + tests/etopo1_oper_an_fc_O48_cy50r1_zbry.yml | 1 + 2 files changed, 2 insertions(+) diff --git a/tests/etopo1_oper_an_fc_O48_cy50r1.yml b/tests/etopo1_oper_an_fc_O48_cy50r1.yml index 183331a0d..e9a59ff30 100644 --- a/tests/etopo1_oper_an_fc_O48_cy50r1.yml +++ b/tests/etopo1_oper_an_fc_O48_cy50r1.yml @@ -48,6 +48,7 @@ output: - '075' # utauo - '076' # vtauo - '077' # wphio + - '039' # phioc format: grib # (default : grib) or binary at: - timestep: 01:00 diff --git a/tests/etopo1_oper_an_fc_O48_cy50r1_zbry.yml b/tests/etopo1_oper_an_fc_O48_cy50r1_zbry.yml index 28d06c6f8..7ea419157 100644 --- a/tests/etopo1_oper_an_fc_O48_cy50r1_zbry.yml +++ b/tests/etopo1_oper_an_fc_O48_cy50r1_zbry.yml @@ -48,6 +48,7 @@ output: - vst # V-component stokes stress - '075' # utauo - '076' # vtauo + - '039' # phioc - '077' # wphio - '081' # uproxy format: grib # (default : grib) or binary From 8411e1500b0dddd00ad8b5ad1a579b139038e037 Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Tue, 21 Oct 2025 14:32:57 +0000 Subject: [PATCH 42/89] update IPHYS2_AIRSEA cases --- src/ecwam/airsea_zbry.F90 | 6 ++++-- src/ecwam/mpuserin.F90 | 5 +++-- src/ecwam/outbeta.F90 | 1 - src/ecwam/setwavphys.F90 | 4 ++-- src/ecwam/sinflx_zbry.F90 | 18 ++++++++---------- 5 files changed, 17 insertions(+), 17 deletions(-) diff --git a/src/ecwam/airsea_zbry.F90 b/src/ecwam/airsea_zbry.F90 index 386062d5f..64cc0f5a2 100644 --- a/src/ecwam/airsea_zbry.F90 +++ b/src/ecwam/airsea_zbry.F90 @@ -120,7 +120,8 @@ SUBROUTINE AIRSEA_ZBRY (KIJS, KIJL, & SELECT CASE (IPHYS2_AIRSEA) ! implementation of Hwang (2011) as in ST6 - CASE(0) + CASE(0,1) + ! IPHYS2_AIRSEA=0,1 use Hwang (2011) as in ST6 FLX4A0 = CDFAC DO IJ=KIJS,KIJL IF (U10(IJ) .GE. 50.33_JWRB) THEN @@ -135,7 +136,8 @@ SUBROUTINE AIRSEA_ZBRY (KIJS, KIJL, & ENDDO ! implementation of iterative scheme - CASE(1,2) + CASE(2,3) + ! (IPHYS2_AIRSEA=3 only needs this iteration to get USTARGST -> UABSGST , but there is probably a smarter way to do this) DO IJ=KIJS,KIJL ! -------------------------------------------- ! Iterative method diff --git a/src/ecwam/mpuserin.F90 b/src/ecwam/mpuserin.F90 index 230156c39..bd0779534 100644 --- a/src/ecwam/mpuserin.F90 +++ b/src/ecwam/mpuserin.F90 @@ -337,8 +337,9 @@ SUBROUTINE MPUSERIN ! IASSI: 1 ASSIMILATION IS DONE IF ANALYSIS RUN. ! IPHYS: WAVE PHYSICS PACKAGE (0 or 1) ! IPHYS2_AIRSEA: 0: AS CLOSE TO WW3-ST6 AS POSSIBLE -! IPHYS2_AIRSEA: 1: ITERATIVE METHOD FOR THE AIR-SEA INTERACTION (U10, USTAR, CHARN, Z0) -! IPHYS2_AIRSEA: 2: USE U10 DIRECTLY TO DRIVE THE WIND INPUT +! IPHYS2_AIRSEA: 1: AS CLOSE TO WW3-ST6 AS POSSIBLE, BUT ADDITIONALLY USE STRESS BALANCE (LFAC) TO UPDATE USTAR +! IPHYS2_AIRSEA: 2: ITERATIVE METHOD FOR THE AIR-SEA INTERACTION (U10, USTAR, CHARN, Z0) +! IPHYS2_AIRSEA: 3: USE U10 DIRECTLY TO DRIVE THE WIND INPUT ! ISNONLIN : 0 FOR OLD SNONLIN, 1 FOR NEW SNONLIN, 2 FOR LATEST BASED ON JANSSEN 2018 (ECMWF TM 813). ! IDAMPING : 0 NO WAVE DAMPING, 1 WAVE DAMPING ON. ! ONLY MEANINGFUl FOR IPHYS=0 diff --git a/src/ecwam/outbeta.F90 b/src/ecwam/outbeta.F90 index adee074d4..69d1c2418 100644 --- a/src/ecwam/outbeta.F90 +++ b/src/ecwam/outbeta.F90 @@ -69,7 +69,6 @@ SUBROUTINE OUTBETA (KIJS, KIJL, & USE YOWCOUP , ONLY : LLGCBZ0 USE YOWPCONS , ONLY : G , GM1, EPSUS USE YOWPHYS , ONLY : XKAPPA, XNLEV, RNUM , PRCHAR, ALPHAMIN, ALPHAMAX, ALPHA, CDFAC - USE YOWSTAT , ONLY : IPHYS, IPHYS2_AIRSEA USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK diff --git a/src/ecwam/setwavphys.F90 b/src/ecwam/setwavphys.F90 index 21501577b..1b66f536a 100644 --- a/src/ecwam/setwavphys.F90 +++ b/src/ecwam/setwavphys.F90 @@ -219,12 +219,12 @@ SUBROUTINE SETWAVPHYS BSWKM=0.425_JWRB SELECT CASE (IPHYS2_AIRSEA) - CASE(0) + CASE(0,1) NGST=1 ALPHAPMAX = 1.0_JWRB ! i.e. no cap on max spectral steepness TAILFACTOR=6.0_JWRB ! SIN6FC = 6.0 from WW3-ST6 TAILFACTOR_PM=4.0_JWRB ! FXPM = 4.0 from WW3 (all) - CASE(1,2) + CASE(2,3) NGST=2 ALPHAPMAX = 0.031_JWRB ! cap on spectral steepness as in ARD TAILFACTOR=2.5_JWRB diff --git a/src/ecwam/sinflx_zbry.F90 b/src/ecwam/sinflx_zbry.F90 index d65a4f0be..0401ca612 100644 --- a/src/ecwam/sinflx_zbry.F90 +++ b/src/ecwam/sinflx_zbry.F90 @@ -406,15 +406,13 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & ! DO IGST=1,NGST SELECT CASE (IPHYS2_AIRSEA) - CASE(0) + CASE(0,1,2) + ! IPHYS2_AIRSEA=0,1,2 use USTAR DO IJ = KIJS,KIJL - UPROXYGST(IJ,IGST) = 32.0_JWRB * CDFAC * USTARGST(IJ,IGST) ! original, suggested by E. Rogers (2014) (young seas) + UPROXYGST(IJ,IGST) = 32.0_JWRB * CDFAC * USTARGST(IJ,IGST) END DO - CASE(1) - DO IJ = KIJS,KIJL - UPROXYGST(IJ,IGST) = 32.0_JWRB * CDFAC * USTARGST(IJ,IGST) ! following Komen et al. (1984) (developed seas) (FRIC=28) - END DO - CASE(2) + CASE(3) + ! IPHYS2_AIRSEA=3 is based on wind directly DO IJ = KIJS,KIJL UPROXYGST(IJ,IGST) = UABSGST(IJ,IGST) * CDFAC ! because FRIC=1/sqrt(CD), then this turns to purely a wind dependence (USTARGST cancels out) ENDDO @@ -557,9 +555,9 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & ENDDO SELECT CASE (IPHYS2_AIRSEA) - ! CASE(0) - ! USTARGST(IJ,IGST) = USTARGST(IJ,IGST) ! i.e. do nothing here, don't update USTAR because it is not true to WW3_ST6 - CASE(1,2) + ! IPHYS2_AIRSEA=0 DO NOT USE STRESS BALANCE (LFAC) TO UPDATE USTAR + ! IPHYS2_AIRSEA=1,2,3 USE STRESS BALANCE (LFAC) TO UPDATE USTAR + CASE(1,2,3) DO IGST=1,NGST DO IJ = KIJS,KIJL USTARGST(IJ,IGST) = SQRT(TAU(IJ,IGST) / ROAIRN(IJ) ) From 7051269a44919b8a4e380921e6d34cf6e0826e60 Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Tue, 21 Oct 2025 16:16:02 +0000 Subject: [PATCH 43/89] add IPHYS2 nameless options and print statements --- share/ecwam/scripts/ecwam_run_model.sh | 4 ++++ src/ecwam/mpuserin.F90 | 2 +- src/ecwam/setwavphys.F90 | 15 +++++---------- src/ecwam/userin.F90 | 19 ++++++++++++++++--- tests/etopo1_oper_an_fc_O48_cy50r1_zbry.yml | 2 ++ 5 files changed, 28 insertions(+), 14 deletions(-) diff --git a/share/ecwam/scripts/ecwam_run_model.sh b/share/ecwam/scripts/ecwam_run_model.sh index ec9b699ba..977203d7e 100755 --- a/share/ecwam/scripts/ecwam_run_model.sh +++ b/share/ecwam/scripts/ecwam_run_model.sh @@ -83,8 +83,10 @@ wamnfre=$(read_config frequencies) nproma=$(read_config nproma --default=24) iphys=$(read_config iphys --default=1) +iphys2_airsea=$(read_config iphys2_airsea --default=0) llgcbz0=$(read_config llgcbz0 --default=F) llnormagam=$(read_config llnormagam --default=F) +lllowwinds=$(read_config lllowwinds --default=F) irefra=$(read_config irefra --default=0) lciwa1=$(read_config lciwa1 --default=F) lciwa2=$(read_config lciwa2 --default=F) @@ -228,12 +230,14 @@ cat > wam_namelist << EOF LFDBIOOUT = F, LFDB = F, IPHYS = ${iphys}, + IPHYS2_AIRSEA = ${iphys2_airsea}, ISHALLO = 0, ISNONLIN = 0, LBIWBK = T, LLCAPCHNK = T, LLGCBZ0 = ${llgcbz0}, LLNORMAGAM = ${llnormagam}, + LLLOWWINDS = ${lllowwinds}, IPROPAGS = 2, LSUBGRID = F, IREFRA = ${irefra}, diff --git a/src/ecwam/mpuserin.F90 b/src/ecwam/mpuserin.F90 index bd0779534..ec2238f70 100644 --- a/src/ecwam/mpuserin.F90 +++ b/src/ecwam/mpuserin.F90 @@ -609,7 +609,7 @@ SUBROUTINE MPUSERIN ICASE = 1 ISHALLO = 0 !! depricated IPHYS = 1 - IPHYS2_AIRSEA = 1 + IPHYS2_AIRSEA = 0 LLLOWWINDS = .FALSE. ! .TRUE. if low winds are treated differently ISNONLIN = 1 IDAMPING = 1 diff --git a/src/ecwam/setwavphys.F90 b/src/ecwam/setwavphys.F90 index 1b66f536a..878339ea5 100644 --- a/src/ecwam/setwavphys.F90 +++ b/src/ecwam/setwavphys.F90 @@ -239,21 +239,16 @@ SUBROUTINE SETWAVPHYS WRITE (IU06,*) '*************************************' CALL ABORT1 END SELECT - ALPHA = 0.0065_JWRB CDFAC = 1.0_JWRB - - ZSIN6A0 = 9.0E-2_JWRB - ZSWL6B1 = 0.0041_JWRB - LLSWL6CSTB1 = .FALSE. - + LLSDS6ET = .TRUE. ZSDS6A1 = 4.75E-6_JWRB - ZSDS6A2 = 7.00E-5_JWRB ISDS6P1 = 4 + ZSDS6A2 = 7.00E-5_JWRB ISDS6P2 = 4 - LLSDS6ET = .TRUE. - - + LLSWL6CSTB1 = .FALSE. + ZSWL6B1 = 0.0041_JWRB + ZSIN6A0 = 9.0E-2_JWRB ELSE WRITE (IU06,*) '*************************************' WRITE (IU06,*) '* *' diff --git a/src/ecwam/userin.F90 b/src/ecwam/userin.F90 index 96a8eb933..1f90ae7ed 100644 --- a/src/ecwam/userin.F90 +++ b/src/ecwam/userin.F90 @@ -121,7 +121,9 @@ SUBROUTINE USERIN (IFORCA, LWCUR) & CHNKMIN_U, CDIS ,DELTA_SDIS, CDISVIS, & & TAUWSHELTER, TAILFACTOR, TAILFACTOR_PM, & & DELTA_THETA_RN, DTHRN_A, DTHRN_U, & - & SWELLF4, SWELLF7, SSDSC5, CDFAC + & SWELLF4, SWELLF7, SSDSC5, CDFAC, & + & ZSIN6A0, LLSWL6CSTB1, ZSWL6B1, & + & ZSDS6A1, ZSDS6A2, ISDS6P1, ISDS6P2, LLSDS6ET USE YOWSHAL , ONLY : NDEPTH ,DEPTHA ,DEPTHD ,BATHYMAX USE YOWSTAT , ONLY : CDATEE ,CDATEF ,CDATER ,CDATES , & & IFRELFMAX, DELPRO_LF, IDELPRO, IDELT ,IDELWI , & @@ -141,7 +143,8 @@ SUBROUTINE USERIN (IFORCA, LWCUR) & LNSESTART, & & LSMSSIG_WAM,CMETER ,CEVENT , & & LRELWIND , & - & IDELWI_LST, IDELWO_LST, CDTW_LST, NDELW_LST + & IDELWI_LST, IDELWO_LST, CDTW_LST, NDELW_LST, & + & LLLOWWINDS, IPHYS2_AIRSEA USE YOWTEST , ONLY : IU06 USE YOWTEXT , ONLY : LRESTARTED,ICPLEN ,USERID ,RUNID , & & PATH ,CPATH ,CWI @@ -784,7 +787,17 @@ SUBROUTINE USERIN (IFORCA, LWCUR) WRITE(IU06,*) ' SWELLF7 = ...... ', SWELLF7 WRITE(IU06,*) ' SSDSC5 = ....... ', SSDSC5 ELSEIF (IPHYS == 2) THEN - WRITE(IU06,*) ' CDFAC = ...... ', CDFAC + WRITE(IU06,*) ' IPHYS2_AIRSEA = .', IPHYS2_AIRSEA + WRITE(IU06,*) ' CDFAC = ........ ', CDFAC + WRITE(IU06,*) ' LLSDS6ET = ..... ', LLSDS6ET + WRITE(IU06,*) ' ZSDS6A1 = ...... ', ZSDS6A1 + WRITE(IU06,*) ' ISDS6P1 = ...... ', ISDS6P1 + WRITE(IU06,*) ' ZSDS6A2 = ...... ', ZSDS6A2 + WRITE(IU06,*) ' ISDS6P2 = ...... ', ISDS6P2 + WRITE(IU06,*) ' LLSWL6CSTB1 = .. ', LLSWL6CSTB1 + WRITE(IU06,*) ' ZSWL6B1 = ...... ', ZSWL6B1 + WRITE(IU06,*) ' ZSIN6A0 = ...... ', ZSIN6A0 + WRITE(IU06,*) ' LLLOWWINDS = ... ', LLLOWWINDS ENDIF WRITE(IU06,*) '' WRITE(IU06,*) ' THIS IS ALWAYS A SHALLOW WATER RUN ' diff --git a/tests/etopo1_oper_an_fc_O48_cy50r1_zbry.yml b/tests/etopo1_oper_an_fc_O48_cy50r1_zbry.yml index 7ea419157..68566a74d 100644 --- a/tests/etopo1_oper_an_fc_O48_cy50r1_zbry.yml +++ b/tests/etopo1_oper_an_fc_O48_cy50r1_zbry.yml @@ -3,6 +3,7 @@ directions: 12 frequencies: 25 bathymetry: ETOPO1 iphys: 2 +iphys2_airsea: 0 advection: timestep: 900 @@ -20,6 +21,7 @@ end: ${forecast.end} nproma: 32 llgcbz0: T llnormagam: T +lllowwinds: F lciwa3: T lciscal: T From 43b0b6a1ffca5d1d26c224ef7ad14ea457557a0d Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Wed, 22 Oct 2025 10:08:41 +0000 Subject: [PATCH 44/89] add some informative comments --- src/ecwam/airsea.F90 | 2 +- src/ecwam/airsea_zbry.F90 | 8 +++----- src/ecwam/calcphiwa.F90 | 2 +- src/ecwam/sinflx_zbry.F90 | 33 ++++++++++++++------------------- 4 files changed, 19 insertions(+), 26 deletions(-) diff --git a/src/ecwam/airsea.F90 b/src/ecwam/airsea.F90 index e8a3dc2d7..8c3cb1576 100644 --- a/src/ecwam/airsea.F90 +++ b/src/ecwam/airsea.F90 @@ -95,7 +95,7 @@ SUBROUTINE AIRSEA (KIJS, KIJL, & & US, Z0, Z0B, CHRNCK, ICODE_WND, IUSFG) CASE(2) CALL AIRSEA_ZBRY(KIJS, KIJL, & - & HALP, U10, U10DIR, TAUW, TAUWDIR, RNFAC, & + & U10, U10DIR, TAUW, TAUWDIR, & & US, Z0, Z0B, CHRNCK, ICODE_WND, IUSFG) END SELECT diff --git a/src/ecwam/airsea_zbry.F90 b/src/ecwam/airsea_zbry.F90 index 64cc0f5a2..3f7f4f48a 100644 --- a/src/ecwam/airsea_zbry.F90 +++ b/src/ecwam/airsea_zbry.F90 @@ -8,7 +8,7 @@ ! SUBROUTINE AIRSEA_ZBRY (KIJS, KIJL, & -& HALP, U10, U10DIR, TAUW, TAUWDIR, RNFAC, & +& U10, U10DIR, TAUW, TAUWDIR, & & US, Z0, Z0B, CHRNCK, ICODE_WND, IUSFG) ! ---------------------------------------------------------------------- @@ -26,19 +26,17 @@ SUBROUTINE AIRSEA_ZBRY (KIJS, KIJL, & ! ---------- ! *CALL* *AIRSEA_ZBRY (KIJS, KIJL, FL1, WAVNUM, -! HALP, U10, U10DIR, TAUW, TAUWDIR, RNFAC, +! U10, U10DIR, TAUW, TAUWDIR, ! US, Z0, Z0B, CHRNCK, ICODE_WND, IUSFG)* ! *KIJS* - INDEX OF FIRST GRIDPOINT. ! *KIJL* - INDEX OF LAST GRIDPOINT. ! *FL1* - SPECTRA ! *WAVNUM* - WAVE NUMBER -! *HALP* - 1/2 PHILLIPS PARAMETER ! *U10* - WINDSPEED U10. ! *U10DIR* - WINDSPEED DIRECTION. ! *TAUW* - WAVE STRESS. ! *TAUWDIR* - WAVE STRESS DIRECTION. -! *RNFAC* - WIND DEPENDENT FACTOR USED IN THE GROWTH RENORMALISATION. ! *US* - OUTPUT OR OUTPUT BLOCK OF FRICTION VELOCITY. ! *Z0* - OUTPUT BLOCK OF ROUGHNESS LENGTH. ! *Z0B* - BACKGROUND ROUGHNESS LENGTH. @@ -71,7 +69,7 @@ SUBROUTINE AIRSEA_ZBRY (KIJS, KIJL, & #include "z0wave.intfb.h" INTEGER(KIND=JWIM), INTENT(IN) :: KIJS, KIJL, ICODE_WND, IUSFG - REAL(KIND=JWRB), DIMENSION(KIJL), INTENT (IN) :: HALP, U10DIR, TAUW, TAUWDIR, RNFAC + REAL(KIND=JWRB), DIMENSION(KIJL), INTENT (IN) :: U10DIR, TAUW, TAUWDIR REAL(KIND=JWRB), DIMENSION(KIJL), INTENT (INOUT) :: U10, US, CHRNCK REAL(KIND=JWRB), DIMENSION(KIJL), INTENT (OUT) :: Z0, Z0B diff --git a/src/ecwam/calcphiwa.F90 b/src/ecwam/calcphiwa.F90 index a1eeb50a9..97f69e7b2 100644 --- a/src/ecwam/calcphiwa.F90 +++ b/src/ecwam/calcphiwa.F90 @@ -97,7 +97,7 @@ FUNCTION CALCPHIWA(SPOS,SNEG,DSII,SIG) RESULT(PHIWA) END IF !/ 2) --- Calculate PHIWA from the extended arrays ------------------- / - PHIWA = G * ROWATER * ( SUM(SPOSDENS10Hz*DSII10Hz) + SUM(SNEGDENS10Hz*DSII10Hz) ) / ZPI + PHIWA = G * ROWATER * ( SUM(SPOSDENS10Hz*DSII10Hz) + SUM(SNEGDENS10Hz*DSII10Hz) ) / ZPI ! divide by 2*pi to convert from rad/s to Hz IF (LHOOK) CALL DR_HOOK('CALCPHIWA',1,ZHOOK_HANDLE) diff --git a/src/ecwam/sinflx_zbry.F90 b/src/ecwam/sinflx_zbry.F90 index 0401ca612..c6c4a2fe2 100644 --- a/src/ecwam/sinflx_zbry.F90 +++ b/src/ecwam/sinflx_zbry.F90 @@ -251,21 +251,10 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & ICODE_WND = 3 ENDIF -IF(LLCAPCHNK) THEN - RNFAC(KIJS:KIJL) = 1.0_JWRB+DTHRN_A*(1.0_JWRB+TANH(WSWAVE(KIJS:KIJL)-DTHRN_U)) -ELSE - RNFAC(KIJS:KIJL) = 1.0_JWRB -ENDIF - - IF(LUPDTUS) THEN - ! increase noise level in the tail - IF (ICALL == 1 ) THEN - DO K=1,NANG - FL1(KIJS:KIJL,K,NFRE) = MAX(FL1(KIJS:KIJL,K,NFRE),FLM(KIJS:KIJL,K)) - ENDDO - HALP(KIJS:KIJL) = 0.0_JWRB - ENDIF + ! Dummy values for AIRSEA !TODO: implement these as optional arguments in AIRSEA + RNFAC(KIJS:KIJL) = 1.0_JWRB + HALP(KIJS:KIJL) = 0.0_JWRB !$loki inline CALL AIRSEA (KIJS, KIJL, & @@ -418,6 +407,10 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & ENDDO END SELECT END DO + +! ------------------------------------------------------------------- / +! START: using intrinsic frequency spectra + ! ! To reshape from 1D to 2D: ! K = RESHAPE( A , (/ NANG, NFRE /)) @@ -565,6 +558,10 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & ENDDO END SELECT +! END: using intrinsic frequency spectra +! ------------------------------------------------------------------- / +! NOTE: below this line is using frequency (i.e. not intrinsic frequency) + ! 8) --- Calculate SL, FL and SPOS needed for ecWAM ------------- / DO IGST=1,NGST @@ -642,13 +639,11 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & ! 11) --- PHIWA calculation using non-directional ! spectral density of the wind input ---------------------- / - - SPOSDENSIG = SPOS(IJ,:,:) - SNEGDENSIG = SL(IJ,:,:) - SPOS(IJ,:,:) - PHIWA(IJ) = CALCPHIWA(SPOSDENSIG,SNEGDENSIG,DSII,SIG) +! CALCPHIWA(SPOS ,SNEG ,DSII,SIG) + PHIWA(IJ) = CALCPHIWA(SPOS(IJ,:,:),SL(IJ,:,:) - SPOS(IJ,:,:),DSII,SIG) END DO -! XLLWS based on SL (mask for neg. input) +! XLLWS based on SL (mask for pos. input) DO M = 1,NFRE DO K = 1, NANG DO IJ=KIJS,KIJL From a5bce9b5d908bdba9cc7c90c6050ff9f956a8e21 Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Wed, 22 Oct 2025 10:20:32 +0000 Subject: [PATCH 45/89] bugfix on new namelists entries --- src/ecwam/mpuserin.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/ecwam/mpuserin.F90 b/src/ecwam/mpuserin.F90 index ec2238f70..53f152d27 100644 --- a/src/ecwam/mpuserin.F90 +++ b/src/ecwam/mpuserin.F90 @@ -194,7 +194,7 @@ SUBROUTINE MPUSERIN & ICASE, ISHALLO, ITEST, ITESTB, IREST, IASSI, & & IPROPAGS, & & IREFRA, & - & IPHYS, & + & IPHYS, IPHYS2_AIRSEA, & & ISNONLIN, & & IDAMPING, & & LBIWBK , & @@ -238,7 +238,7 @@ SUBROUTINE MPUSERIN & LWNEMOTAUOC, LWNEMOCOURECV, & & LWNEMOCOUCIC, LWNEMOCOUCIT, LWNEMOCOUCUR, LWNEMOCOUIBR, & & LWNEMOCOUDEBUG, & - & LLCAPCHNK, LLGCBZ0, LLNORMAGAM, & + & LLCAPCHNK, LLGCBZ0, LLNORMAGAM, LLLOWWINDS, & & LWAM_USE_IO_SERV, & & LOUTMDLDCP, & & ROAIR, ROWATER, GAM_SURF, & From e956eb1d5af9114683927e0c45f253aaf92e24ea Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Wed, 22 Oct 2025 12:50:35 +0000 Subject: [PATCH 46/89] replace high frequency contribution with analytic solution in CALCPHIWA --- src/ecwam/calcphiwa.F90 | 110 ++++++++++++++++++-------------------- src/ecwam/sinflx_zbry.F90 | 3 +- 2 files changed, 55 insertions(+), 58 deletions(-) diff --git a/src/ecwam/calcphiwa.F90 b/src/ecwam/calcphiwa.F90 index 97f69e7b2..82707ad00 100644 --- a/src/ecwam/calcphiwa.F90 +++ b/src/ecwam/calcphiwa.F90 @@ -1,4 +1,4 @@ -FUNCTION CALCPHIWA(SPOS,SNEG,DSII,SIG) RESULT(PHIWA) +FUNCTION CALCPHIWA(SPOS,SNEG,DF) RESULT(PHIWA) ! ---------------------------------------------------------------------------- ! @@ -25,27 +25,21 @@ FUNCTION CALCPHIWA(SPOS,SNEG,DSII,SIG) RESULT(PHIWA) USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU USE YOWPCONS , ONLY : G ,ROWATER, ZPI - USE YOWFRED , ONLY : DELTH, FRATIO + USE YOWFRED , ONLY : FR ,DELTH USE YOWPARAM , ONLY : NANG ,NFRE USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK !---------------------------------------------------------------------- IMPLICIT NONE -#include "irange.intfb.h" - REAL(KIND=JWRB), DIMENSION(NANG,NFRE), INTENT(IN) :: SPOS ! POS Sin(sigma) in [m2/rad-Hz] - REAL(KIND=JWRB), DIMENSION(NANG,NFRE), INTENT(IN) :: SNEG ! NEG Sin(sigma) in [m2/rad-Hz] - REAL(KIND=JWRB), DIMENSION(NFRE), INTENT(IN) :: DSII ! freq. bandwidths in [radians] - REAL(KIND=JWRB), DIMENSION(NFRE), INTENT(IN) :: SIG + REAL(KIND=JWRB), DIMENSION(NANG,NFRE), INTENT(IN) :: SPOS ! POS Sin(sigma) in [m2/Hz] + REAL(KIND=JWRB), DIMENSION(NANG,NFRE), INTENT(IN) :: SNEG ! NEG Sin(sigma) in [m2/Hz] + REAL(KIND=JWRB), DIMENSION(NFRE), INTENT(IN) :: DF ! freq. bandwidths in [Hz] - REAL(KIND=JWRB), PARAMETER :: FRQMAX = 10.0_JWRB ! Upper freq. limit to extrap. to - REAL, ALLOCATABLE :: IK10Hz(:), SIG10Hz(:) - REAL, ALLOCATABLE :: SPOSDENS10Hz(:), SNEGDENS10Hz(:), DSII10Hz(:) - - INTEGER(KIND=JWIM) :: NK10Hz - INTEGER(KIND=JWIM) :: NK, NTH - INTEGER(KIND=JWIM), DIMENSION(NANG) :: ITHN + REAL(KIND=JWRB), DIMENSION(NANG) :: ZA_SPOS, ZA_SNEG + REAL(KIND=JWRB), DIMENSION(NANG) :: SPOS_HF, SNEG_HF, SPOS_LF, SNEG_LF + REAL(KIND=JWRB), DIMENSION(NANG) :: SPOS_TOTAL, SNEG_TOTAL REAL(KIND=JWRB) :: PHIWA REAL(KIND=JPHOOK) :: ZHOOK_HANDLE @@ -55,49 +49,51 @@ FUNCTION CALCPHIWA(SPOS,SNEG,DSII,SIG) RESULT(PHIWA) IF (LHOOK) CALL DR_HOOK('CALCPHIWA',0,ZHOOK_HANDLE) - - NTH = NANG ! NUMBER OF DIRS , SAME AS KL - NK = NFRE ! NUMBER OF FREQS, SAME AS ML - -!/ 0) --- Find the number of frequencies required to extend arrays -!/ up to f=10Hz and allocate arrays --------------------------- / - NK10Hz = CEILING(LOG(FRQMAX/(SIG(1)/ZPI))/LOG(FRATIO))+1 - NK10Hz = MAX(NK,NK10Hz) -! - ALLOCATE(IK10Hz(NK10Hz)) - IK10Hz = REAL( IRANGE(1,NK10Hz,1) ) -! - ALLOCATE(SPOSDENS10Hz(NK10Hz)) - ALLOCATE(SNEGDENS10Hz(NK10Hz)) - ALLOCATE(DSII10Hz(NK10Hz)) - ALLOCATE(SIG10Hz(NK10Hz)) -! - ITHN = IRANGE(1,NTH,1) ! Index vector 1:NTH -! -!/ 1) --- Either extrapolate arrays up to 10Hz or use discrete spectral -! grid per se. Limit the constraint to the positive part of the -! wind input only. ---------------------------------------------- / - IF (NK .LT. NK10Hz) THEN - SPOSDENS10Hz(1:NK) = SUM(SPOS,1) * DELTH - SNEGDENS10Hz(1:NK) = SUM(SNEG,1) * DELTH - SIG10Hz = SIG(1)*FRATIO**(IK10Hz-1.0_JWRB) - DSII10Hz = 0.5_JWRB * SIG10Hz * (FRATIO-1.0_JWRB/FRATIO) -! The first and last frequency bin: - DSII10Hz(1) = 0.5_JWRB * SIG10Hz(1) * (FRATIO-1.0_JWRB) - DSII10Hz(NK10Hz) = 0.5_JWRB * SIG10Hz(NK10Hz) * (FRATIO-1.0_JWRB) / FRATIO -! -! --- Spectral slope for S_IN(F) is proportional to F**(-2) ------ / - SPOSDENS10Hz(NK+1:NK10Hz) = SPOSDENS10Hz(NK) * (SIG10Hz(NK)/SIG10Hz(NK+1:NK10Hz))**2 - SNEGDENS10Hz(NK+1:NK10Hz) = SNEGDENS10Hz(NK) * (SIG10Hz(NK)/SIG10Hz(NK+1:NK10Hz))**2 - ELSE - SIG10Hz = SIG - DSII10Hz = DSII - SPOSDENS10Hz(1:NK) = SUM(SPOS,1) * DELTH - SNEGDENS10Hz(1:NK) = SUM(SNEG,1) * DELTH - END IF - -!/ 2) --- Calculate PHIWA from the extended arrays ------------------- / - PHIWA = G * ROWATER * ( SUM(SPOSDENS10Hz*DSII10Hz) + SUM(SNEGDENS10Hz*DSII10Hz) ) / ZPI ! divide by 2*pi to convert from rad/s to Hz + !/ 0) --- split integral into low/high frequency contributions ------------- / + ! + ! + ! Th=2pi,f=inf Th=2pi,f=FR(NFRE) Th=2pi,f=inf + ! / / / / / / + ! | | S(f) df dTh = | | S(f) df dTh + | | S(f) df dTh + ! / / / / / / + ! Th=0,f=0 Th=0,f=0 Th=0,f=FR(NFRE) + ! + ! + ! = LF_contribution + HF_contribution + ! + ! + !/ 1) --- low frequency contributions to the integral ---------------------- / + ! -- Direct summation over available freq. bins up to FR(NFRE) + ! + SPOS_LF = SUM(SPOS,1) * DELTH * FR + SNEG_LF = SUM(SNEG,1) * DELTH * FR + + !/ 2) --- high frequency contributions to the integral --------------------- / + ! -- Assume spectral slope for S_IN(F) is proportional to F**(-2), then + ! integral collapses into easy analytic solution + ! + ! + ! Th=2pi,f=inf + ! / / + ! | | S(f) df dTh = ZPI * S(NFRE) / FR(NFRE) + ! / / + ! Th=0,f=FR(NFRE) + ! + ! + ! Determine value of spectrum at NFRE (i.e. at highest frequency). + ! - Note, direction dimension must remain + ZA_SPOS = SPOS(:,NFRE) + ZA_SNEG = SNEG(:,NFRE) + + SPOS_HF = (ZPI*ZA_SPOS)/FR(NFRE) + SNEG_HF = (ZPI*ZA_SNEG)/FR(NFRE) + + !/ 3) --- summate low + high frequency contributions to the integral ------- / + SPOS_TOTAL = SPOS_LF + SPOS_HF + SNEG_TOTAL = SNEG_LF + SNEG_HF + + !/ 4) --- compute the flux ------------------------------------------------- / + PHIWA = G * ROWATER * ( SUM(SPOS_TOTAL) + SUM(SNEG_TOTAL) ) IF (LHOOK) CALL DR_HOOK('CALCPHIWA',1,ZHOOK_HANDLE) diff --git a/src/ecwam/sinflx_zbry.F90 b/src/ecwam/sinflx_zbry.F90 index c6c4a2fe2..7ddd2d5af 100644 --- a/src/ecwam/sinflx_zbry.F90 +++ b/src/ecwam/sinflx_zbry.F90 @@ -640,7 +640,8 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & ! 11) --- PHIWA calculation using non-directional ! spectral density of the wind input ---------------------- / ! CALCPHIWA(SPOS ,SNEG ,DSII,SIG) - PHIWA(IJ) = CALCPHIWA(SPOS(IJ,:,:),SL(IJ,:,:) - SPOS(IJ,:,:),DSII,SIG) +! PHIWA(IJ) = CALCPHIWA(SPOS(IJ,:,:),SL(IJ,:,:) - SPOS(IJ,:,:),DSII,SIG) + PHIWA(IJ) = CALCPHIWA(SPOS(IJ,:,:),SL(IJ,:,:) - SPOS(IJ,:,:),DF) END DO ! XLLWS based on SL (mask for pos. input) From c339a29ec4c910aac6b1aa7e3562723fcc8d76a5 Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Wed, 22 Oct 2025 13:59:56 +0000 Subject: [PATCH 47/89] correct CALCPHIWA calculation? --- src/ecwam/calcphiwa.F90 | 23 ++++++++++++++--------- 1 file changed, 14 insertions(+), 9 deletions(-) diff --git a/src/ecwam/calcphiwa.F90 b/src/ecwam/calcphiwa.F90 index 82707ad00..2c7534b9a 100644 --- a/src/ecwam/calcphiwa.F90 +++ b/src/ecwam/calcphiwa.F90 @@ -25,7 +25,7 @@ FUNCTION CALCPHIWA(SPOS,SNEG,DF) RESULT(PHIWA) USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU USE YOWPCONS , ONLY : G ,ROWATER, ZPI - USE YOWFRED , ONLY : FR ,DELTH + USE YOWFRED , ONLY : FR ,DELTH , DFIM USE YOWPARAM , ONLY : NANG ,NFRE USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK @@ -37,9 +37,12 @@ FUNCTION CALCPHIWA(SPOS,SNEG,DF) RESULT(PHIWA) REAL(KIND=JWRB), DIMENSION(NANG,NFRE), INTENT(IN) :: SNEG ! NEG Sin(sigma) in [m2/Hz] REAL(KIND=JWRB), DIMENSION(NFRE), INTENT(IN) :: DF ! freq. bandwidths in [Hz] + REAL(KIND=JWRB), DIMENSION(NANG) :: ZA_SPOS, ZA_SNEG - REAL(KIND=JWRB), DIMENSION(NANG) :: SPOS_HF, SNEG_HF, SPOS_LF, SNEG_LF - REAL(KIND=JWRB), DIMENSION(NANG) :: SPOS_TOTAL, SNEG_TOTAL + + REAL(KIND=JWRB) :: SPOS_LF, SNEG_LF + REAL(KIND=JWRB) :: SPOS_HF, SNEG_HF + REAL(KIND=JWRB) :: SPOS_TOTAL, SNEG_TOTAL REAL(KIND=JWRB) :: PHIWA REAL(KIND=JPHOOK) :: ZHOOK_HANDLE @@ -65,8 +68,10 @@ FUNCTION CALCPHIWA(SPOS,SNEG,DF) RESULT(PHIWA) !/ 1) --- low frequency contributions to the integral ---------------------- / ! -- Direct summation over available freq. bins up to FR(NFRE) ! - SPOS_LF = SUM(SPOS,1) * DELTH * FR - SNEG_LF = SUM(SNEG,1) * DELTH * FR + ! DFIM = DELTH * DF + ! + SPOS_LF = SUM(SUM(SPOS,1) * DFIM) + SNEG_LF = SUM(SUM(SNEG,1) * DFIM) !/ 2) --- high frequency contributions to the integral --------------------- / ! -- Assume spectral slope for S_IN(F) is proportional to F**(-2), then @@ -85,15 +90,15 @@ FUNCTION CALCPHIWA(SPOS,SNEG,DF) RESULT(PHIWA) ZA_SPOS = SPOS(:,NFRE) ZA_SNEG = SNEG(:,NFRE) - SPOS_HF = (ZPI*ZA_SPOS)/FR(NFRE) - SNEG_HF = (ZPI*ZA_SNEG)/FR(NFRE) + SPOS_HF = SUM((ZPI*ZA_SPOS)/FR(NFRE)) + SNEG_HF = SUM((ZPI*ZA_SNEG)/FR(NFRE)) !/ 3) --- summate low + high frequency contributions to the integral ------- / SPOS_TOTAL = SPOS_LF + SPOS_HF SNEG_TOTAL = SNEG_LF + SNEG_HF - !/ 4) --- compute the flux ------------------------------------------------- / - PHIWA = G * ROWATER * ( SUM(SPOS_TOTAL) + SUM(SNEG_TOTAL) ) + !/ 4) --- compute the flux ------------------------------------------------- / + PHIWA = G * ROWATER * ( SPOS_TOTAL + SNEG_TOTAL ) IF (LHOOK) CALL DR_HOOK('CALCPHIWA',1,ZHOOK_HANDLE) From 4782ea7639ae4cb827b12a9f4c9e443fed5586d5 Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Thu, 23 Oct 2025 11:11:38 +0000 Subject: [PATCH 48/89] correct CALCPHIWA calculation --- src/ecwam/calcphiwa.F90 | 18 +++++++++--------- src/ecwam/sinflx_zbry.F90 | 3 +-- 2 files changed, 10 insertions(+), 11 deletions(-) diff --git a/src/ecwam/calcphiwa.F90 b/src/ecwam/calcphiwa.F90 index 2c7534b9a..5ae028628 100644 --- a/src/ecwam/calcphiwa.F90 +++ b/src/ecwam/calcphiwa.F90 @@ -55,14 +55,14 @@ FUNCTION CALCPHIWA(SPOS,SNEG,DF) RESULT(PHIWA) !/ 0) --- split integral into low/high frequency contributions ------------- / ! ! - ! Th=2pi,f=inf Th=2pi,f=FR(NFRE) Th=2pi,f=inf - ! / / / / / / - ! | | S(f) df dTh = | | S(f) df dTh + | | S(f) df dTh - ! / / / / / / - ! Th=0,f=0 Th=0,f=0 Th=0,f=FR(NFRE) + ! Th=2pi,f=inf Th=2pi,f=FR(NFRE) Th=2pi,f=inf + ! / / / / / / + ! | | S(f,Th) df dTh = | | S(f,Th) df dTh + | | S(f,Th) df dTh + ! / / / / / / + ! Th=0,f=0 Th=0,f=0 Th=0,f=FR(NFRE) ! ! - ! = LF_contribution + HF_contribution + ! = LF_contribution + HF_contribution ! ! !/ 1) --- low frequency contributions to the integral ---------------------- / @@ -80,7 +80,7 @@ FUNCTION CALCPHIWA(SPOS,SNEG,DF) RESULT(PHIWA) ! ! Th=2pi,f=inf ! / / - ! | | S(f) df dTh = ZPI * S(NFRE) / FR(NFRE) + ! | | S(f,Th) df dTh = FR(NFRE) * DELTH * SUM(S(:,NFRE)) ! / / ! Th=0,f=FR(NFRE) ! @@ -90,8 +90,8 @@ FUNCTION CALCPHIWA(SPOS,SNEG,DF) RESULT(PHIWA) ZA_SPOS = SPOS(:,NFRE) ZA_SNEG = SNEG(:,NFRE) - SPOS_HF = SUM((ZPI*ZA_SPOS)/FR(NFRE)) - SNEG_HF = SUM((ZPI*ZA_SNEG)/FR(NFRE)) + SPOS_HF = FR(NFRE) * DELTH * SUM(ZA_SPOS) + SNEG_HF = FR(NFRE) * DELTH * SUM(ZA_SNEG) !/ 3) --- summate low + high frequency contributions to the integral ------- / SPOS_TOTAL = SPOS_LF + SPOS_HF diff --git a/src/ecwam/sinflx_zbry.F90 b/src/ecwam/sinflx_zbry.F90 index 7ddd2d5af..33be3efb8 100644 --- a/src/ecwam/sinflx_zbry.F90 +++ b/src/ecwam/sinflx_zbry.F90 @@ -639,8 +639,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & ! 11) --- PHIWA calculation using non-directional ! spectral density of the wind input ---------------------- / -! CALCPHIWA(SPOS ,SNEG ,DSII,SIG) -! PHIWA(IJ) = CALCPHIWA(SPOS(IJ,:,:),SL(IJ,:,:) - SPOS(IJ,:,:),DSII,SIG) +! CALCPHIWA(SPOS ,SNEG ,DF) PHIWA(IJ) = CALCPHIWA(SPOS(IJ,:,:),SL(IJ,:,:) - SPOS(IJ,:,:),DF) END DO From 5c330d3998f6edb2468353d00a11c641db3b273f Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Thu, 23 Oct 2025 12:18:11 +0000 Subject: [PATCH 49/89] do the same high frequency contribution technique for TAU_WAVE_ATMOS --- src/ecwam/calcphiwa.F90 | 23 +++--- src/ecwam/sinflx_zbry.F90 | 9 +-- src/ecwam/tau_wave_atmos.F90 | 148 +++++++++++++++++++---------------- 3 files changed, 92 insertions(+), 88 deletions(-) diff --git a/src/ecwam/calcphiwa.F90 b/src/ecwam/calcphiwa.F90 index 5ae028628..4fa6a21d7 100644 --- a/src/ecwam/calcphiwa.F90 +++ b/src/ecwam/calcphiwa.F90 @@ -1,4 +1,4 @@ -FUNCTION CALCPHIWA(SPOS,SNEG,DF) RESULT(PHIWA) +FUNCTION CALCPHIWA(SPOS,SNEG) RESULT(PHIWA) ! ---------------------------------------------------------------------------- ! @@ -35,14 +35,13 @@ FUNCTION CALCPHIWA(SPOS,SNEG,DF) RESULT(PHIWA) REAL(KIND=JWRB), DIMENSION(NANG,NFRE), INTENT(IN) :: SPOS ! POS Sin(sigma) in [m2/Hz] REAL(KIND=JWRB), DIMENSION(NANG,NFRE), INTENT(IN) :: SNEG ! NEG Sin(sigma) in [m2/Hz] - REAL(KIND=JWRB), DIMENSION(NFRE), INTENT(IN) :: DF ! freq. bandwidths in [Hz] REAL(KIND=JWRB), DIMENSION(NANG) :: ZA_SPOS, ZA_SNEG REAL(KIND=JWRB) :: SPOS_LF, SNEG_LF REAL(KIND=JWRB) :: SPOS_HF, SNEG_HF - REAL(KIND=JWRB) :: SPOS_TOTAL, SNEG_TOTAL + REAL(KIND=JWRB) :: PHIWA_HF, PHIWA_LF REAL(KIND=JWRB) :: PHIWA REAL(KIND=JPHOOK) :: ZHOOK_HANDLE @@ -73,6 +72,8 @@ FUNCTION CALCPHIWA(SPOS,SNEG,DF) RESULT(PHIWA) SPOS_LF = SUM(SUM(SPOS,1) * DFIM) SNEG_LF = SUM(SUM(SNEG,1) * DFIM) + PHIWA_LF = G * ROWATER * ( SPOS_LF + SNEG_LF ) + !/ 2) --- high frequency contributions to the integral --------------------- / ! -- Assume spectral slope for S_IN(F) is proportional to F**(-2), then ! integral collapses into easy analytic solution @@ -87,18 +88,16 @@ FUNCTION CALCPHIWA(SPOS,SNEG,DF) RESULT(PHIWA) ! ! Determine value of spectrum at NFRE (i.e. at highest frequency). ! - Note, direction dimension must remain - ZA_SPOS = SPOS(:,NFRE) - ZA_SNEG = SNEG(:,NFRE) + ZA_SPOS = SPOS(:,NFRE) + ZA_SNEG = SNEG(:,NFRE) - SPOS_HF = FR(NFRE) * DELTH * SUM(ZA_SPOS) - SNEG_HF = FR(NFRE) * DELTH * SUM(ZA_SNEG) + SPOS_HF = FR(NFRE) * DELTH * SUM(ZA_SPOS) + SNEG_HF = FR(NFRE) * DELTH * SUM(ZA_SNEG) - !/ 3) --- summate low + high frequency contributions to the integral ------- / - SPOS_TOTAL = SPOS_LF + SPOS_HF - SNEG_TOTAL = SNEG_LF + SNEG_HF + PHIWA_HF = G * ROWATER * ( SPOS_HF + SNEG_HF ) - !/ 4) --- compute the flux ------------------------------------------------- / - PHIWA = G * ROWATER * ( SPOS_TOTAL + SNEG_TOTAL ) + !/ 3) --- summate low + high frequency contributions to the integral ------- / + PHIWA = PHIWA_LF + PHIWA_HF IF (LHOOK) CALL DR_HOOK('CALCPHIWA',1,ZHOOK_HANDLE) diff --git a/src/ecwam/sinflx_zbry.F90 b/src/ecwam/sinflx_zbry.F90 index 33be3efb8..0e743830f 100644 --- a/src/ecwam/sinflx_zbry.F90 +++ b/src/ecwam/sinflx_zbry.F90 @@ -229,11 +229,6 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE) :: SLGST_AVG, SPOSGST_AVG, FLGST_AVG REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE,NGST) :: SLGST, SPOSGST, FLGST -! For PHIWA calculation -! REAL(KIND=JWRB),DIMENSION(KIJL,NFRE) :: RHOWGDFTH -! REAL(KIND=JWRB), DIMENSION(KIJL) :: SUMT - - ! ---------------------------------------------------------------------- IF (LHOOK) CALL DR_HOOK('SINFLX',0,ZHOOK_HANDLE) @@ -639,8 +634,8 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & ! 11) --- PHIWA calculation using non-directional ! spectral density of the wind input ---------------------- / -! CALCPHIWA(SPOS ,SNEG ,DF) - PHIWA(IJ) = CALCPHIWA(SPOS(IJ,:,:),SL(IJ,:,:) - SPOS(IJ,:,:),DF) +! CALCPHIWA(SPOS ,SNEG ) + PHIWA(IJ) = CALCPHIWA(SPOS(IJ,:,:),SL(IJ,:,:) - SPOS(IJ,:,:)) END DO ! XLLWS based on SL (mask for pos. input) diff --git a/src/ecwam/tau_wave_atmos.F90 b/src/ecwam/tau_wave_atmos.F90 index be2fc38f7..bde204b00 100644 --- a/src/ecwam/tau_wave_atmos.F90 +++ b/src/ecwam/tau_wave_atmos.F90 @@ -67,18 +67,22 @@ SUBROUTINE TAU_WAVE_ATMOS(S, CINV, SIG, DSII, TAUNWX, TAUNWY ) #include "irange.intfb.h" #include "tauwinds.intfb.h" - REAL(KIND=JWRB), DIMENSION(NANG,NFRE), INTENT(IN) :: S + REAL(KIND=JWRB), DIMENSION(NANG,NFRE), INTENT(IN) :: S ! Sin(sigma) in [m2/rad-Hz] REAL(KIND=JWRB), DIMENSION(NFRE), INTENT(IN) :: CINV, SIG, DSII REAL(KIND=JWRB), INTENT(OUT) :: TAUNWX, TAUNWY - REAL(KIND=JWRB), PARAMETER :: FRQMAX = 10.0_JWRB ! Upper freq. limit to extrapolate to. REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: ECOS2, ESIN2 - REAL, ALLOCATABLE :: IK10Hz(:), SIG10Hz(:), CINV10Hz(:) - REAL, ALLOCATABLE :: SDENSX10Hz(:), SDENSY10Hz(:) - REAL, ALLOCATABLE :: DSII10Hz(:), UCINV10Hz(:) + REAL(KIND=JWRB), DIMENSION(NANG,NFRE) :: SX, SY - INTEGER(KIND=JWIM) :: IK, ITH, NK10Hz + REAL(KIND=JWRB), DIMENSION(NFRE) :: SDENSX_LF, SDENSY_LF + REAL(KIND=JWRB), DIMENSION(NFRE) :: ZA_SX, ZA_SY + + REAL(KIND=JWRB) :: SDENSX_HF, SDENSY_HF + REAL(KIND=JWRB) :: TAUNWX_LF, TAUNWY_LF + REAL(KIND=JWRB) :: TAUNWX_HF, TAUNWY_HF + + INTEGER(KIND=JWIM) :: IK, ITH INTEGER(KIND=JWIM) :: NK, NTH, NSPEC !num. of freqs, dirs, spec. bins INTEGER(KIND=JWIM), DIMENSION(NANG) :: ITHN INTEGER(KIND=JWIM), DIMENSION(NFRE) :: IKN @@ -87,66 +91,72 @@ SUBROUTINE TAU_WAVE_ATMOS(S, CINV, SIG, DSII, TAUNWX, TAUNWY ) ! ---------------------------------------------------------------------- - IF (LHOOK) CALL DR_HOOK('TAU_WAVE_ATMOS',0,ZHOOK_HANDLE) - - NTH = NANG ! NUMBER OF DIRS , SAME AS KL - NK = NFRE ! NUMBER OF FREQS, SAME AS ML - NSPEC = NK * NTH ! NUMBER OF SPECTRAL BINS - -!/ 0) --- Find the number of frequencies required to extend arrays -!/ up to f=10Hz and allocate arrays --------------------------- / - NK10Hz = CEILING(LOG(FRQMAX/(SIG(1)/ZPI))/LOG(FRATIO))+1 - NK10Hz = MAX(NK,NK10Hz) -! - ALLOCATE(IK10Hz(NK10Hz)) - IK10Hz = REAL( IRANGE(1,NK10Hz,1) ) -! - ALLOCATE(SIG10Hz(NK10Hz)) - ALLOCATE(CINV10Hz(NK10Hz)) - ALLOCATE(DSII10Hz(NK10Hz)) - ALLOCATE(SDENSX10Hz(NK10Hz)) - ALLOCATE(SDENSY10Hz(NK10Hz)) - ALLOCATE(UCINV10Hz(NK10Hz)) -! - ITHN = IRANGE(1,NTH,1) ! Index vector 1:NTH - DO IK = 1, NK - ECOS2 (ITHN+(IK-1)*NTH) = COSTH - ESIN2 (ITHN+(IK-1)*NTH) = SINTH - END DO - -! -!/ 1) --- Either extrapolate arrays up to 10Hz or use discrete spectral -! grid per se. Limit the constraint to the positive part of the -! wind input only. ---------------------------------------------- / - IF (NK .LT. NK10Hz) THEN - SDENSX10Hz(1:NK) = SUM(ABS(MIN(0.0_JWRB,S))*RESHAPE(ECOS2,(/NTH,NK/)),1) * DELTH - SDENSY10Hz(1:NK) = SUM(ABS(MIN(0.0_JWRB,S))*RESHAPE(ESIN2,(/NTH,NK/)),1) * DELTH - SIG10Hz = SIG(1)*FRATIO**(IK10Hz-1.0_JWRB) - CINV10Hz(1:NK) = CINV - CINV10Hz(NK+1:NK10Hz) = SIG10Hz(NK+1:NK10Hz)*0.101978_JWRB - DSII10Hz = 0.5_JWRB * SIG10Hz * (FRATIO-1.0_JWRB/FRATIO) -! The first and last frequency bin: - DSII10Hz(1) = 0.5_JWRB * SIG10Hz(1) * (FRATIO-1.0_JWRB) - DSII10Hz(NK10Hz) = 0.5_JWRB * SIG10Hz(NK10Hz) * & - & (FRATIO-1.0_JWRB) / FRATIO -! -! --- Spectral slope for S_IN(F) is proportional to F**(-2) ------ / - SDENSX10Hz(NK+1:NK10Hz) = SDENSX10Hz(NK) * (SIG10Hz(NK)/SIG10Hz(NK+1:NK10Hz))**2 - SDENSY10hz(NK+1:NK10Hz) = SDENSY10Hz(NK) * (SIG10Hz(NK)/SIG10Hz(NK+1:NK10Hz))**2 - ELSE - SIG10Hz = SIG - CINV10Hz = CINV - DSII10Hz = DSII - SDENSX10Hz(1:NK) = SUM(ABS(MIN(0.0_JWRB,S))*RESHAPE(ECOS2,(/NTH,NK/)),1) * DELTH - SDENSY10Hz(1:NK) = SUM(ABS(MIN(0.0_JWRB,S))*RESHAPE(ESIN2,(/NTH,NK/)),1) * DELTH - END IF -! -!/ 2) --- Stress calculation ----------------------------------------- / -! --- The wave supported stress (waves to atmosphere) ------------ / - TAUNWX = TAUWINDS(SDENSX10Hz,CINV10Hz,DSII10Hz) ! x-component - TAUNWY = TAUWINDS(SDENSY10Hz,CINV10Hz,DSII10Hz) ! y-component - - - IF (LHOOK) CALL DR_HOOK('TAU_WAVE_ATMOS',1,ZHOOK_HANDLE) - - END SUBROUTINE TAU_WAVE_ATMOS + IF (LHOOK) CALL DR_HOOK('TAU_WAVE_ATMOS',0,ZHOOK_HANDLE) + + NTH = NANG ! NUMBER OF DIRS , SAME AS KL + NK = NFRE ! NUMBER OF FREQS, SAME AS ML + NSPEC = NK * NTH ! NUMBER OF SPECTRAL BINS + + ITHN = IRANGE(1,NTH,1) ! Index vector 1:NTH + DO IK = 1, NK + ECOS2 (ITHN+(IK-1)*NTH) = COSTH + ESIN2 (ITHN+(IK-1)*NTH) = SINTH + END DO + + SX = ABS(MIN(0.0_JWRB,S))*RESHAPE(ECOS2,(/NTH,NK/)) + SY = ABS(MIN(0.0_JWRB,S))*RESHAPE(ESIN2,(/NTH,NK/)) + + !/ 0) --- split integral into low/high frequency contributions ------------- / + ! + ! + ! Th=2pi,f=inf Th=2pi,f=FR(NFRE) Th=2pi,f=inf + ! / / / / / / + ! | | S(f,Th) df dTh = | | S(f,Th) df dTh + | | S(f,Th) df dTh + ! / / / / / / + ! Th=0,f=0 Th=0,f=0 Th=0,f=FR(NFRE) + ! + ! + ! = LF_contribution + HF_contribution + ! + ! + !/ 1) --- low frequency contributions to the integral ---------------------- / + ! -- Direct summation over available freq. bins up to FR(NFRE) + + SDENSX_LF = SUM(SX,1) * DELTH + SDENSY_LF = SUM(SY,1) * DELTH + + TAUNWX_LF = TAUWINDS(SDENSX_LF,CINV,DSII) ! x-component + TAUNWY_LF = TAUWINDS(SDENSY_LF,CINV,DSII) ! y-component + + !/ 2) --- high frequency contributions to the integral --------------------- / + ! -- Assume spectral slope for S_IN(F) is proportional to F**(-2), then + ! integral collapses into easy analytic solution + ! + ! + ! Th=2pi,f=inf + ! / / + ! | | S(f,Th) df dTh = FR(NFRE) * DELTH * SUM(S(:,NFRE)) + ! / / + ! Th=0,f=FR(NFRE) + ! + ! + ! Determine value of spectrum at NFRE (i.e. at highest frequency). + ! - Note, direction dimension must remain + + ZA_SX = SX(:,NFRE) + ZA_SY = SY(:,NFRE) + + SDENSX_HF = SIG(NFRE) * DELTH * SUM(ZA_SX) + SDENSY_HF = SIG(NFRE) * DELTH * SUM(ZA_SY) + + TAUNWX_HF = G * ROWATER * ( SDENSX_HF ) + TAUNWY_HF = G * ROWATER * ( SDENSY_HF ) + + !/ 3) --- summate low + high frequency contributions to the integral ------- / + + TAUNWX = TAUNWX_LF + TAUNWX_HF + TAUNWY = TAUNWY_LF + TAUNWY_HF + + IF (LHOOK) CALL DR_HOOK('TAU_WAVE_ATMOS',1,ZHOOK_HANDLE) + + END SUBROUTINE TAU_WAVE_ATMOS From 62e7aa725f5a69eed338cba7a89e8bb6e005439d Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Thu, 23 Oct 2025 13:59:31 +0000 Subject: [PATCH 50/89] I think this is the correct implementation to include CINV for TAU integration for high frequencies --- src/ecwam/tau_wave_atmos.F90 | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/ecwam/tau_wave_atmos.F90 b/src/ecwam/tau_wave_atmos.F90 index bde204b00..266275c37 100644 --- a/src/ecwam/tau_wave_atmos.F90 +++ b/src/ecwam/tau_wave_atmos.F90 @@ -58,7 +58,7 @@ SUBROUTINE TAU_WAVE_ATMOS(S, CINV, SIG, DSII, TAUNWX, TAUNWY ) & FRATIO ,DELTH USE YOWMPP , ONLY : NINF ,NSUP USE YOWPARAM , ONLY : NANG ,NFRE - USE YOWPCONS , ONLY : G ,ZPI ,ROWATER ,EPSMIN + USE YOWPCONS , ONLY : G ,ZPI ,ROWATER ,EPSMIN, GM1 USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK ! ---------------------------------------------------------------------- @@ -109,14 +109,14 @@ SUBROUTINE TAU_WAVE_ATMOS(S, CINV, SIG, DSII, TAUNWX, TAUNWY ) !/ 0) --- split integral into low/high frequency contributions ------------- / ! ! - ! Th=2pi,f=inf Th=2pi,f=FR(NFRE) Th=2pi,f=inf - ! / / / / / / - ! | | S(f,Th) df dTh = | | S(f,Th) df dTh + | | S(f,Th) df dTh - ! / / / / / / - ! Th=0,f=0 Th=0,f=0 Th=0,f=FR(NFRE) + ! Th=2pi,f=inf Th=2pi,f=FR(NFRE) Th=2pi,f=inf + ! / / / / / / + ! | | S(f,Th)/c df dTh = | | S(f,Th)/c df dTh + | | S(f,Th)/c df dTh + ! / / / / / / + ! Th=0,f=0 Th=0,f=0 Th=0,f=FR(NFRE) ! ! - ! = LF_contribution + HF_contribution + ! = LF_contribution + HF_contribution ! ! !/ 1) --- low frequency contributions to the integral ---------------------- / @@ -135,7 +135,7 @@ SUBROUTINE TAU_WAVE_ATMOS(S, CINV, SIG, DSII, TAUNWX, TAUNWY ) ! ! Th=2pi,f=inf ! / / - ! | | S(f,Th) df dTh = FR(NFRE) * DELTH * SUM(S(:,NFRE)) + ! | | S(f,Th)/c df dTh = FR(NFRE)**2 * DELTH * SUM(S(:,NFRE)) * ZPI * GM1 / LOG(SIG(NFRE)) ! / / ! Th=0,f=FR(NFRE) ! @@ -146,8 +146,8 @@ SUBROUTINE TAU_WAVE_ATMOS(S, CINV, SIG, DSII, TAUNWX, TAUNWY ) ZA_SX = SX(:,NFRE) ZA_SY = SY(:,NFRE) - SDENSX_HF = SIG(NFRE) * DELTH * SUM(ZA_SX) - SDENSY_HF = SIG(NFRE) * DELTH * SUM(ZA_SY) + SDENSX_HF = SIG(NFRE)**2 * DELTH * SUM(ZA_SX) * ZPI * GM1 / LOG(SIG(NFRE)) + SDENSY_HF = SIG(NFRE)**2 * DELTH * SUM(ZA_SY) * ZPI * GM1 / LOG(SIG(NFRE)) TAUNWX_HF = G * ROWATER * ( SDENSX_HF ) TAUNWY_HF = G * ROWATER * ( SDENSY_HF ) From d69e08856b6c291a6de5c1fdfb3879ffaf7f46c1 Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Thu, 23 Oct 2025 17:10:16 +0000 Subject: [PATCH 51/89] cleanup allocations of LFACTOR --- src/ecwam/lfactor.F90 | 95 ++++--------- src/ecwam/lfactor.new.F90 | 282 ++++++++++++++++++++++++++++++++++++++ src/ecwam/setwavphys.F90 | 6 +- src/ecwam/sinflx_zbry.F90 | 63 +++++---- src/ecwam/yowphys.F90 | 6 + 5 files changed, 354 insertions(+), 98 deletions(-) create mode 100644 src/ecwam/lfactor.new.F90 diff --git a/src/ecwam/lfactor.F90 b/src/ecwam/lfactor.F90 index e973a9a16..5600af690 100644 --- a/src/ecwam/lfactor.F90 +++ b/src/ecwam/lfactor.F90 @@ -6,7 +6,7 @@ ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. - SUBROUTINE LFACTOR(S, CINV, U10, USTAR, USDIR, ROAIRN, SIG, DSII, & + SUBROUTINE LFACTOR(S, CINV, U10, USTAR, USDIR, ROAIRN, SIG, DSII, NK10Hz, & & LFACT, TAUWX, TAUWY, TAU) ! ---------------------------------------------------------------------------- @@ -93,6 +93,7 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, USDIR, ROAIRN, SIG, DSII, & REAL(KIND=JWRB), DIMENSION(NANG,NFRE), INTENT(IN) :: S REAL(KIND=JWRB), DIMENSION(NFRE), INTENT(IN) :: CINV, SIG, DSII REAL(KIND=JWRB), INTENT(IN) :: U10, USTAR, USDIR, ROAIRN + INTEGER(KIND=JWIM), INTENT(IN) :: NK10Hz REAL(KIND=JWRB), DIMENSION(NFRE), INTENT(OUT) :: LFACT REAL(KIND=JWRB), INTENT(OUT) :: TAUWX, TAUWY, TAU @@ -102,9 +103,9 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, USDIR, ROAIRN, SIG, DSII, & ! to find numerical LFACT soln REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: ECOS2, ESIN2 - REAL, ALLOCATABLE :: IK10Hz(:), LF10Hz(:), SIG10Hz(:), CINV10Hz(:) - REAL, ALLOCATABLE :: SDENS10Hz(:), SDENSX10Hz(:), SDENSY10Hz(:) - REAL, ALLOCATABLE :: DSII10Hz(:), UCINV10Hz(:) + REAL(KIND=JWRB), DIMENSION(NK10Hz) :: IK10Hz, LF10Hz, SIG10Hz, CINV10Hz + REAL(KIND=JWRB), DIMENSION(NK10Hz) :: SDENS10Hz, SDENSX10Hz, SDENSY10Hz + REAL(KIND=JWRB), DIMENSION(NK10Hz) :: DSII10Hz, UCINV10Hz REAL(KIND=JWRB) :: TAU_TOT, TAU_VIS, TAU_WAV REAL(KIND=JWRB) :: TAUVX, TAUVY, TAUX, TAUY @@ -113,7 +114,7 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, USDIR, ROAIRN, SIG, DSII, & LOGICAL :: OVERSHOT CHARACTER(LEN=23) :: IDTIME - INTEGER(KIND=JWIM) :: IK, ITH, NK10Hz, M, SIGN_NEW, SIGN_OLD + INTEGER(KIND=JWIM) :: IK, ITH, M, SIGN_NEW, SIGN_OLD INTEGER(KIND=JWIM) :: NK, NTH, NSPEC !num. of freqs, dirs, spec. bins INTEGER(KIND=JWIM), DIMENSION(NANG) :: ITHN INTEGER(KIND=JWIM), DIMENSION(NFRE) :: IKN @@ -128,30 +129,14 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, USDIR, ROAIRN, SIG, DSII, & NK = NFRE ! NUMBER OF FREQS, SAME AS ML NSPEC = NK * NTH ! NUMBER OF SPECTRAL BINS -!/ 0) --- Find the number of frequencies required to extend arrays -!/ up to f=10Hz and allocate arrays --------------------------- / - NK10Hz = CEILING(LOG(FRQMAX/(SIG(1)/ZPI))/LOG(FRATIO))+1 - NK10Hz = MAX(NK,NK10Hz) -! - ALLOCATE(IK10Hz(NK10Hz)) IK10Hz = REAL( IRANGE(1,NK10Hz,1) ) -! - ALLOCATE(SIG10Hz(NK10Hz)) - ALLOCATE(CINV10Hz(NK10Hz)) - ALLOCATE(DSII10Hz(NK10Hz)) - ALLOCATE(LF10Hz(NK10Hz)) - ALLOCATE(SDENS10Hz(NK10Hz)) - ALLOCATE(SDENSX10Hz(NK10Hz)) - ALLOCATE(SDENSY10Hz(NK10Hz)) - ALLOCATE(UCINV10Hz(NK10Hz)) -! + ITHN = IRANGE(1,NTH,1) ! Index vector 1:NTH DO IK = 1, NK - ECOS2 (ITHN+(IK-1)*NTH) = COSTH - ESIN2 (ITHN+(IK-1)*NTH) = SINTH + ECOS2 (ITHN+(IK-1)*NTH) = COSTH + ESIN2 (ITHN+(IK-1)*NTH) = SINTH END DO - ! !/ 1) --- Either extrapolate arrays up to 10Hz or use discrete spectral ! grid per se. Limit the constraint to the positive part of the @@ -213,68 +198,44 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, USDIR, ROAIRN, SIG, DSII, & IK = 0 ! IF (TAU .GT. TAU_TOT) THEN - OVERSHOT = .FALSE. - RTAU = ERR / 90.0_JWRB - DRTAU = 2.0_JWRB - SIGN_NEW = INT(SIGN(1.0_JWRB,ERR)) - UPROXY = FRIC * CDFAC * USTAR - UCINV10Hz = 1.0_JWRB - (UPROXY * CINV10Hz) -! -!/T6 WRITE (NDST,270) IDTIME, U10 -!/T6 WRITE (NDST,271) - DO IK=1,ITERMAX + OVERSHOT = .FALSE. + RTAU = ERR / 90.0_JWRB + DRTAU = 2.0_JWRB + + SIGN_NEW = INT(SIGN(1.0_JWRB,ERR)) + + UPROXY = FRIC * CDFAC * USTAR + UCINV10Hz = 1.0_JWRB - (UPROXY * CINV10Hz) + + DO IK=1,ITERMAX + LF10Hz = MIN(1.0_JWRB, EXP(UCINV10Hz * RTAU) ) -! TAU_NND = TAUWINDS(SDENS10Hz *LF10Hz,CINV10Hz,DSII10Hz) TAUWX = TAUWINDS(SDENSX10Hz*LF10Hz,CINV10Hz,DSII10Hz) TAUWY = TAUWINDS(SDENSY10Hz*LF10Hz,CINV10Hz,DSII10Hz) TAU_WAV = SQRT(TAUWX**2 + TAUWY**2) -! TAUX = TAUVX + TAUWX TAUY = TAUVY + TAUWY TAU = SQRT(TAUX**2 + TAUY**2) ERR = (TAU-TAU_TOT) / TAU_TOT -! SIGN_OLD = SIGN_NEW SIGN_NEW = INT(SIGN(1.0_JWRB, ERR)) -!/T6 WRITE (NDST,272) IK, RTAU, DRTAU, TAU, TAU_TOT, ERR, & -!/T6 TAUWX, TAUWY, TAUVX, TAUVY, TAU_NND -! + ! --- Slow down DRTAU when overshot. -------------------------- / + IF (SIGN_NEW .NE. SIGN_OLD) OVERSHOT = .TRUE. IF (OVERSHOT) DRTAU = MAX(0.5_JWRB*(1.0_JWRB+DRTAU),1.00010_JWRB) -! + RTAU = RTAU * (DRTAU**SIGN_NEW) -! + IF (ABS(ERR) .LT. 1.54E-4_JWRB) EXIT - END DO -! -! IF (IK .GE. ITERMAX) WRITE (NDST,280) IDTIME(1:19), U10, TAU, & -! TAU_TOT, ERR, TAUWX, TAUWY, TAUVX, TAUVY,TAU_NND + + END DO + END IF -! - LFACT(1:NK) = LF10Hz(1:NK) -! -!/T6 WRITE (NDST,273) 'Sin ', IDTIME(1:19), SDENS10Hz*TPI -!/T6 WRITE (NDST,273) 'SinR', IDTIME(1:19), SDENS10Hz*LF10Hz*TPI -!/T6 WRITE (NDST,274) 'Sin ', SUM(SDENS10Hz(1:NK)*DSII) -!/T6 WRITE (NDST,274) 'SinR ', SUM(SDENS10Hz(1:NK)*LF10Hz(1:NK)*DSII) -!/T6 WRITE (NDST,274) 'SinR/C', TAUWINDS(SDENS10Hz(1:NK)*LFACT,CINV,DSII) -! -!/T6 270 FORMAT (' TEST W3SIN6 : LFACTOR SUBROUTINE CALCULATING FOR ', & -!/T6 A,' U10=',F5.1 ) -!/T6 271 FORMAT (' TEST W3SIN6 : IK RTAU DRTAU TAU TAU_TOT' & -!/T6 ' ERR TAUW_X TAUW_Y TAUV_X TAUV_Y TAU1D' ) -!/T6 272 FORMAT (' TEST W3SIN6 : ',I2,2F9.5,2F8.5,E10.2,4F7.4,F7.3 ) -!/T6 273 FORMAT (' TEST W3SIN6 : ',A,'(',A,'):', 70E11.3 ) -! 274 FORMAT (' TEST W3SIN6 : Total ',A,' =', E13.5 ) -! 280 FORMAT (' WARNING LFACTOR (TIME,U10,TAU,TAU_TOT,ERR,TAUW_XY,' & -! 'TAUV_XY,TAU_SCALAR): ',A,F6.1,2F7.4,E10.3,4F7.4,F7.3 ) -! - DEALLOCATE(IK10Hz,SIG10Hz,CINV10Hz,DSII10Hz,LF10Hz) - DEALLOCATE(SDENS10Hz,SDENSX10Hz,SDENSY10Hz,UCINV10Hz) + LFACT(1:NK) = LF10Hz(1:NK) IF (LHOOK) CALL DR_HOOK('LFACTOR',1,ZHOOK_HANDLE) diff --git a/src/ecwam/lfactor.new.F90 b/src/ecwam/lfactor.new.F90 new file mode 100644 index 000000000..e9d36c948 --- /dev/null +++ b/src/ecwam/lfactor.new.F90 @@ -0,0 +1,282 @@ +! (C) Copyright 1989- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. + + SUBROUTINE XX_LFACTOR(S, CINV, U10, USTAR, USDIR, ROAIRN, SIG, DSII, & + & LFACT, TAUWX, TAUWY, TAU) + +! ---------------------------------------------------------------------------- +! +! 1. Purpose : +! +! Numerical approximation for the reduction factor LFACTOR(f) to +! reduce energy in the high-frequency part of the resolved part +! of the spectrum to meet the constraint on total stress (TAU). +! The constraint is TAU <= TAU_TOT (TAU_TOT = TAU_WAV + TAU_VIS), +! thus the wind input is reduced to match our constraint. +! +! 2. Method : +! +! 1) If required, extend resolved part of the spectrum to 10Hz using +! an approximation for the spectral slope at the high frequency +! limit: Sin(F) prop. F**(-2) and for E(F) prop. F**(-5). +! 2) Calculate stresses: +! total stress: TAU_TOT = DAIR * USTAR**2 +! viscous stress: TAU_VIS = DAIR * Cv * U10**2 +! viscous stress (x,y-components): +! TAUV_X = TAU_VIS * COS(USDIR) +! TAUV_Y = TAU_VIS * SIN(USDIR) +! wave supported stress (x,y-components): /10Hz +! TAUW_X,Y = GRAV * DWAT * | [SinX,Y(F)]/C(F) dF +! / +! total stress (input): TAU = SQRT( (TAUW_X + TAUV_X)**2 +! + (TAUW_Y + TAUV_Y)**2 ) +! 3) If TAU does not meet our constraint reduce the wind input +! using reduction factor: +! LFACT(F) = MIN(1,exp((1-U/C(F))*RTAU)) +! Then alter RTAU and repeat 3) until our constraint is matched. +! +! ---------------------------------------------------------------------------- +! +!** INTERFACE. +! ---------- + +! *CALL* *LFACTOR(S, CINV, U10, USTAR, USDIR, ROAIRN, SIG, DSII, & +! & LFACT, TAUWX, TAUWY, TAU) +! *S* - NEG. WIND INPUT ENERGY DENSITY SPECTRUM. +! *CINV* - INVERSE PHASE SPEED CALC. IN INPUT ROUTINE +! *UABS* - 10M WIND SPEED +! *USTAR* - NEW FRICTION VELOCITY IN M/S. +! *USDIR* - WIND DIRECTION +! *ROAIRN* - AIR DENSITY IN KG/M3 +! *SIG* - FREQ (RAD) +! *DSII* - ZPI*DF +! *LFACT* - CORRECTION FACTOR +! *TAUNWX, TAUNWY* - NEGATIVE WAVE NORMAL STRESS COMPONENTS + +! EXTERNALS. +! ---------- +! TAUWINDS +! IRANGE + +! ORIGIN. +! ---------- +! Adapted from Babanin Young Donelan & Banner (ZBRY) physics +! as implemented as ST6 in WAVEWATCH-III +! WW3 module: W3SRC6MD +! WW3 subroutine: LFACTOR +! Implementation into ECWAM DECEMBER 2021 by J. Kousal + +! ---------------------------------------------------------------------- + USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU + + USE YOWFRED , ONLY : FR ,TH ,DFIM ,COSTH ,SINTH,& +& FRATIO ,DELTH ,FRIC + USE YOWMPP , ONLY : NINF ,NSUP + USE YOWPARAM , ONLY : NANG ,NFRE + USE YOWPCONS , ONLY : G ,ZPI ,ROWATER ,EPSMIN, GM1 + USE YOWPHYS , ONLY : BETAMAX ,ZALP ,TAUWSHELTER, XKAPPA, RNU ,RNUM, CDFAC + USE YOWSTAT , ONLY : ISHALLO + USE YOWTABL , ONLY : IAB ,SWELLFT + USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK + +! ---------------------------------------------------------------------- + + IMPLICIT NONE +#include "irange.intfb.h" +#include "tauwinds.intfb.h" + + REAL(KIND=JWRB), DIMENSION(NANG,NFRE), INTENT(IN) :: S + REAL(KIND=JWRB), DIMENSION(NFRE), INTENT(IN) :: CINV, SIG, DSII + REAL(KIND=JWRB), INTENT(IN) :: U10, USTAR, USDIR, ROAIRN + + REAL(KIND=JWRB), DIMENSION(NFRE), INTENT(OUT) :: LFACT + REAL(KIND=JWRB), INTENT(OUT) :: TAUWX, TAUWY, TAU + + REAL(KIND=JWRB), PARAMETER :: FRQMAX = 10.0_JWRB ! Upper freq. limit to extrap. to + INTEGER(KIND=JWIM), PARAMETER :: ITERMAX = 80 ! Max. no. iterations + ! to find numerical LFACT soln + + REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: ECOS2, ESIN2 + REAL(KIND=JWRB), DIMENSION(NANG,NFRE) :: SX, SY + + REAL(KIND=JWRB), DIMENSION(NFRE) :: SDENSX_LF, SDENSY_LF + REAL(KIND=JWRB), DIMENSION(NFRE) :: ZA_SX, ZA_SY + + REAL(KIND=JWRB) :: SDENSX_HF, SDENSY_HF + REAL(KIND=JWRB) :: TAUWX_LF, TAUWY_LF + REAL(KIND=JWRB) :: TAUWX_HF, TAUWY_HF + + REAL(KIND=JWRB) :: TAU_TOT, TAU_VIS, TAU_WAV + REAL(KIND=JWRB) :: TAUVX, TAUVY, TAUX, TAUY + REAL(KIND=JWRB) :: TAU_NND, TAU_INIT(2) + REAL(KIND=JWRB) :: UPROXY, RTAU, DRTAU, ERR + LOGICAL :: OVERSHOT + CHARACTER(LEN=23) :: IDTIME + + + INTEGER(KIND=JWIM) :: IK, ITH, M, SIGN_NEW, SIGN_OLD + INTEGER(KIND=JWIM) :: NK, NTH, NSPEC !num. of freqs, dirs, spec. bins + INTEGER(KIND=JWIM), DIMENSION(NANG) :: ITHN + INTEGER(KIND=JWIM), DIMENSION(NFRE) :: IKN + + REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ---------------------------------------------------------------------- + + IF (LHOOK) CALL DR_HOOK('XX_LFACTOR',0,ZHOOK_HANDLE) + + NTH = NANG ! NUMBER OF DIRS , SAME AS KL + NK = NFRE ! NUMBER OF FREQS, SAME AS ML + NSPEC = NK * NTH ! NUMBER OF SPECTRAL BINS + + ITHN = IRANGE(1,NTH,1) ! Index vector 1:NTH + DO IK = 1, NK + ECOS2 (ITHN+(IK-1)*NTH) = COSTH + ESIN2 (ITHN+(IK-1)*NTH) = SINTH + END DO + + SX = ABS(MIN(0.0_JWRB,S))*RESHAPE(ECOS2,(/NTH,NK/)) + SY = ABS(MIN(0.0_JWRB,S))*RESHAPE(ESIN2,(/NTH,NK/)) + +!/ ----------------------------------------------------------------- / +!/ ----------------------------------------------------------------- / +!/ Part I) --- low/high frequency contributions of TAU ------------- / + + !/ 0) --- split integral into low/high frequency contributions ------------- / + ! + ! + ! Th=2pi,f=inf Th=2pi,f=FR(NFRE) Th=2pi,f=inf + ! / / / / / / + ! | | S(f,Th)/c df dTh = | | S(f,Th)/c df dTh + | | S(f,Th)/c df dTh + ! / / / / / / + ! Th=0,f=0 Th=0,f=0 Th=0,f=FR(NFRE) + ! + ! + ! = LF_contribution + HF_contribution + ! + ! + !/ 1) --- low frequency contributions to the integral ---------------------- / + ! -- Direct summation over available freq. bins up to FR(NFRE) + + SDENSX_LF = SUM(SX,1) * DELTH + SDENSY_LF = SUM(SY,1) * DELTH + + TAUWX_LF = TAUWINDS(SDENSX_LF,CINV,DSII) ! x-component + TAUWY_LF = TAUWINDS(SDENSY_LF,CINV,DSII) ! y-component + + !/ 2) --- high frequency contributions to the integral --------------------- / + ! -- Assume spectral slope for S_IN(F) is proportional to F**(-2), then + ! integral collapses into easy analytic solution + ! + ! + ! Th=2pi,f=inf + ! / / + ! | | S(f,Th)/c df dTh = FR(NFRE) * DELTH * SUM(S(:,NFRE)) * GM1 + ! / / + ! Th=0,f=FR(NFRE) + ! + ! + ! Determine value of spectrum at NFRE (i.e. at highest frequency). + ! - Note, direction dimension must remain + + ZA_SX = SX(:,NFRE) + ZA_SY = SY(:,NFRE) + + SDENSX_HF = SIG(NFRE)**2 * DELTH * SUM(ZA_SX) * ZPI * GM1 / LOG(SIG(NFRE)) + SDENSY_HF = SIG(NFRE)**2 * DELTH * SUM(ZA_SY) * ZPI * GM1 / LOG(SIG(NFRE)) + + TAUWX_HF = G * ROWATER * ( SDENSX_HF ) + TAUWY_HF = G * ROWATER * ( SDENSY_HF ) + + !/ 3) --- summate low + high frequency contributions to the integral ------- / + + TAUWX = TAUWX_LF + TAUWX_HF + TAUWY = TAUWY_LF + TAUWY_HF + +!/ ----------------------------------------------------------------- / +!/ ----------------------------------------------------------------- / +!/ Part II) --- USTAR based TAU calculation ------------- / +! +!/ 2) --- Stress calculation ----------------------------------------- / +! --- The total stress ------------------------------------------- / + TAU_TOT = USTAR**2 * ROAIRN + +! --- The viscous stress and check that it does not exceed +! the total stress. ------------------------------------------ / + TAU_VIS = MAX(0.0_JWRB, -5.0E-5_JWRB*U10 + 1.1E-3_JWRB) * U10**2 * ROAIRN +! TAU_VIS = MIN(0.9 * TAU_TOT, TAU_VIS) + TAU_VIS = MIN(0.95_JWRB * TAU_TOT, TAU_VIS) + + TAUVX = TAU_VIS * COS(USDIR) + TAUVY = TAU_VIS * SIN(USDIR) + +! --- The wave supported stress (using elements calculated in Part I). -- / +! + TAU_WAV = SQRT(TAUWX**2 + TAUWY**2) ! normal stress (magnitude) + TAU_INIT = (/TAUWX,TAUWY/) ! unadjusted normal stress components + + TAUX = TAUVX + TAUWX ! total stress (x-component) + TAUY = TAUVY + TAUWY ! total stress (y-component) + TAU = SQRT(TAUX**2 + TAUY**2) ! total stress (magnitude) + ERR = (TAU-TAU_TOT)/TAU_TOT ! initial error + +!/ 3) --- Find reduced Sin(f) = L(f)*Sin(f) to satisfy our constraint +!/ TAU <= TAU_TOT --------------------------------------------- / + + LF = 1.0_JWRB + IK = 0 + + IF (TAU .GT. TAU_TOT) THEN + + OVERSHOT = .FALSE. + RTAU = ERR / 90.0_JWRB + DRTAU = 2.0_JWRB + SIGN_NEW = INT(SIGN(1.0_JWRB,ERR)) + + UPROXY = FRIC * CDFAC * USTAR + UCINV = 1.0_JWRB - (UPROXY * CINV) + + DO IK=1,ITERMAX + + LF = MIN(1.0_JWRB, EXP(UCINV * RTAU) ) + + TAUWX_LF = TAUWINDS(SDENSX_LF * LF,CINV,DSII) ! x-component + TAUWY_LF = TAUWINDS(SDENSY_LF * LF,CINV,DSII) ! y-component + + TAUWX_HF = G * ROWATER * ( SDENSX_HF * LF) + TAUWY_HF = G * ROWATER * ( SDENSY_HF * LF) + + TAUWX = TAUWX_LF + TAUWX_HF + TAUWY = TAUWY_LF + TAUWY_HF + TAU_WAV = SQRT(TAUWX**2 + TAUWY**2) + + TAUX = TAUVX + TAUWX + TAUY = TAUVY + TAUWY + TAU = SQRT(TAUX**2 + TAUY**2) + ERR = (TAU-TAU_TOT) / TAU_TOT + + SIGN_OLD = SIGN_NEW + SIGN_NEW = INT(SIGN(1.0_JWRB, ERR)) + +! --- Slow down DRTAU when overshot. -------------------------- / + + IF (SIGN_NEW .NE. SIGN_OLD) OVERSHOT = .TRUE. + IF (OVERSHOT) DRTAU = MAX(0.5_JWRB*(1.0_JWRB+DRTAU),1.00010_JWRB) + + RTAU = RTAU * (DRTAU**SIGN_NEW) + + IF (ABS(ERR) .LT. 1.54E-4_JWRB) EXIT + END DO + + END IF + + LFACT = LF + + IF (LHOOK) CALL DR_HOOK('XX_LFACTOR',1,ZHOOK_HANDLE) + + END SUBROUTINE XX_LFACTOR diff --git a/src/ecwam/setwavphys.F90 b/src/ecwam/setwavphys.F90 index 878339ea5..51dfb80fa 100644 --- a/src/ecwam/setwavphys.F90 +++ b/src/ecwam/setwavphys.F90 @@ -27,7 +27,8 @@ SUBROUTINE SETWAVPHYS & ANG_GC_A, ANG_GC_B, ANG_GC_C, & & SWELLF4, SWELLF7, SWELLF7M1, Z0TUBMAX, Z0RAT, & & SSDSC5, CDFAC, ZSIN6A0, LLSWL6CSTB1, ZSWL6B1, & - & ZSDS6A1, ZSDS6A2, ISDS6P1, ISDS6P2, LLSDS6ET, NGST + & ZSDS6A1, ZSDS6A2, ISDS6P1, ISDS6P2, LLSDS6ET, & + & NGST, FRQMAX, LLFACT USE YOWSTAT , ONLY : IPHYS, IPHYS2_AIRSEA USE YOWTEST , ONLY : IU06 @@ -224,11 +225,13 @@ SUBROUTINE SETWAVPHYS ALPHAPMAX = 1.0_JWRB ! i.e. no cap on max spectral steepness TAILFACTOR=6.0_JWRB ! SIN6FC = 6.0 from WW3-ST6 TAILFACTOR_PM=4.0_JWRB ! FXPM = 4.0 from WW3 (all) + FRQMAX = 10.0_JWRB ! extend to 10Hz for LFACTOR CASE(2,3) NGST=2 ALPHAPMAX = 0.031_JWRB ! cap on spectral steepness as in ARD TAILFACTOR=2.5_JWRB TAILFACTOR_PM=3.0_JWRB ! as in ARD + FRQMAX = 5.0_JWRB ! 5Hz also works well (TODO: could do with further testing) CASE DEFAULT WRITE (IU06,*) '*************************************' WRITE (IU06,*) '* *' @@ -249,6 +252,7 @@ SUBROUTINE SETWAVPHYS LLSWL6CSTB1 = .FALSE. ZSWL6B1 = 0.0041_JWRB ZSIN6A0 = 9.0E-2_JWRB + LLFACT = .TRUE. ELSE WRITE (IU06,*) '*************************************' WRITE (IU06,*) '* *' diff --git a/src/ecwam/sinflx_zbry.F90 b/src/ecwam/sinflx_zbry.F90 index 0e743830f..da215de7c 100644 --- a/src/ecwam/sinflx_zbry.F90 +++ b/src/ecwam/sinflx_zbry.F90 @@ -104,7 +104,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & & SWELLF ,SWELLF2 ,SWELLF3 ,SWELLF4 , SWELLF5, & & SWELLF6 ,SWELLF7 ,SWELLF7M1, Z0RAT ,Z0TUBMAX , & & ABMIN ,ABMAX, CDFAC, DTHRN_A ,DTHRN_U, RNU_WATER, & - & ZSIN6A0 + & ZSIN6A0, FRQMAX, LLFACT USE YOWTEST , ONLY : IU06 USE YOWTABL , ONLY : IAB ,SWELLFT USE YOWSTAT , ONLY : IPHYS2_AIRSEA, LLLOWWINDS @@ -173,7 +173,6 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & REAL(KIND=JPHOOK) :: ZHOOK_HANDLE REAL(KIND=JWRB), DIMENSION(KIJL) :: RNFAC -LOGICAL :: LLFACT INTEGER(KIND=JWIM) :: IJ, K, M, IND, IGST INTEGER(KIND=JWIM) :: NSPEC !num. of freqs, dirs, spec. bins INTEGER(KIND=JWIM), DIMENSION(NANG) :: ITHN @@ -192,9 +191,8 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE,NGST) :: SDENSIG, DINPOS, DINTOT -! REAL(KIND=JWRB), PARAMETER :: SIN6A0 = 9.0E-2_JWRB ! ST6 PARAM ! TODO, move to PHYS REAL(KIND=JWRB), DIMENSION(KIJL,NGST) :: TAUWX, TAUWY ! Component of the wave-supported stress -REAL(KIND=JWRB), DIMENSION(KIJL,NGST) :: TAUNWX, TAUNWY ! Component of the neg. wave-supported stress +! REAL(KIND=JWRB), DIMENSION(KIJL,NGST) :: TAUNWX, TAUNWY ! Component of the neg. wave-supported stress REAL(KIND=JWRB), DIMENSION(KIJL) :: COSU, SINU REAL(KIND=JWRB), DIMENSION(KIJL,NGST) :: UPROXYGST @@ -210,7 +208,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & REAL(KIND=JWRB), PARAMETER :: USTMIN=0.000001_JWRB REAL(KIND=JWRB), PARAMETER :: PCHARMAX=0.1_JWRB REAL(KIND=JWRB), PARAMETER :: Z0FG=0.01_JWRB -INTEGER(KIND=JWIM) :: ITER +INTEGER(KIND=JWIM) :: ITER, NFRE_EXT REAL(KIND=JWRB) :: XZNLEV, PCHAROG, XKUTOP, XOLOGZ0 REAL(KIND=JWRB) :: UST, USTOLD, Z0CH, Z0VIS, Z0TOT, FF, DELF REAL(KIND=JWRB) :: CHARNOCK_MIN,CHNKMIN ! For Capping @@ -220,12 +218,14 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & REAL(KIND=JWRB), PARAMETER :: BMAX=0.01_JWRB REAL(KIND=JWRB) :: ALPHAOGMAXU10 -REAL(KIND=JWRB), DIMENSION(KIJL) :: ROAIRN, CHNKOG, TAUNW +REAL(KIND=JWRB), DIMENSION(KIJL) :: ROAIRN, CHNKOG +! REAL(KIND=JWRB), DIMENSION(KIJL) :: TAUNW, TAUNWGST_AVG ! For GUSTINESS REAL(KIND=JWRB) :: AVG_GST -REAL(KIND=JWRB), DIMENSION(KIJL) :: SIG_N, SIG_U10, TAUWGST_AVG, TAUWDIRGST_AVG, TAUNWGST_AVG, USTARGST_AVG, UPROXYGST_AVG -REAL(KIND=JWRB), DIMENSION(KIJL,NGST) :: TAUWGST, TAUWDIRGST, TAUNWGST, UABSGST, USTARGST, Z0GST +REAL(KIND=JWRB), DIMENSION(KIJL) :: SIG_N, SIG_U10, TAUWGST_AVG, TAUWDIRGST_AVG, USTARGST_AVG, UPROXYGST_AVG +REAL(KIND=JWRB), DIMENSION(KIJL,NGST) :: TAUWGST, TAUWDIRGST, UABSGST, USTARGST, Z0GST +! REAL(KIND=JWRB), DIMENSION(KIJL,NGST) :: TAUNWGST REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE) :: SLGST_AVG, SPOSGST_AVG, FLGST_AVG REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE,NGST) :: SLGST, SPOSGST, FLGST @@ -368,8 +368,8 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & ! DO IGST=1,NGST DO IJ = KIJS,KIJL - TAUNWX(IJ,IGST) = 0.0_JWRB - TAUNWY(IJ,IGST) = 0.0_JWRB + ! TAUNWX(IJ,IGST) = 0.0_JWRB + ! TAUNWY(IJ,IGST) = 0.0_JWRB TAUWX(IJ,IGST) = 0.0_JWRB TAUWY(IJ,IGST) = 0.0_JWRB TAU(IJ,IGST) = 0.0_JWRB @@ -473,26 +473,28 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & ENDDO ENDDO -! -!/ 5) --- calculate reduction factor LFACT using non-directional -! spectral density of the wind input ------------------------- / -DO IGST=1,NGST - DO IJ = KIJS,KIJL - SDENSIG(IJ,:,:,IGST) = RESHAPE(S(IJ,:,IGST)*SIG2/CG2(IJ,:),(/ NANG, NFRE /)) +IF (LLFACT) THEN ! TODO: how to make more efficient? is difficult... - CALL LFACTOR(SDENSIG(IJ,:,:,IGST), CINV1(IJ,:), UABSGST(IJ,IGST), USTARGST(IJ,IGST), WDWAVE(IJ), & -& ROAIRN(IJ), SIG, DSII, LFACT(IJ,:,IGST), TAUWX(IJ,IGST), TAUWY(IJ,IGST), TAU(IJ,IGST)) - ENDDO -ENDDO + !/ 5) --- calculate reduction factor LFACT using non-directional + ! spectral density of the wind input ------------------------- / -! -!/ 6) --- apply reduction (LFACT) to the entire spectrum ------------- / + ! DETERMINE THE NUMBER OF FREQUENCIES TO EXTEND TO + NFRE_EXT = CEILING(LOG(FRQMAX/(SIG(1)/ZPI))/LOG(FRATIO))+1 + NFRE_EXT = MAX(NFRE,NFRE_EXT) -LLFACT = .TRUE. -IF (LLFACT) THEN DO IGST=1,NGST - DO IJ = KIJS,KIJL ! TODO: how to make more efficient? is difficult... + + DO IJ = KIJS,KIJL + SDENSIG(IJ,:,:,IGST) = RESHAPE(S(IJ,:,IGST)*SIG2/CG2(IJ,:),(/ NANG, NFRE /)) + + CALL LFACTOR(SDENSIG(IJ,:,:,IGST), CINV1(IJ,:), UABSGST(IJ,IGST), USTARGST(IJ,IGST), WDWAVE(IJ), & + & ROAIRN(IJ), SIG, DSII, NFRE_EXT, LFACT(IJ,:,IGST), TAUWX(IJ,IGST), TAUWY(IJ,IGST), TAU(IJ,IGST)) + ENDDO + + !/ 6) --- apply reduction (LFACT) to the entire spectrum ------------- / + + DO IJ = KIJS,KIJL IF (SUM(LFACT(IJ,:,IGST)) .LT. NFRE) THEN DO K = 1, NANG D(IJ,IKN+K-1,IGST) = D(IJ,IKN+K-1,IGST) * LFACT(IJ,:,IGST) @@ -501,6 +503,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & END IF DINPOS(IJ,:,:,IGST) = RESHAPE(D(IJ,:,IGST),(/ NANG, NFRE /)) ENDDO + ENDDO END IF @@ -525,7 +528,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & ! ! --- compute negative component of the wave supported stresses ! ! from negative part of the wind input ---------------------- / SDENSIG(IJ,:,:,IGST) = RESHAPE(S(IJ,:,IGST)*SIG2/CG2(IJ,:),(/ NANG, NFRE /)) - CALL TAU_WAVE_ATMOS(SDENSIG(IJ,:,:,IGST), CINV1(IJ,:), SIG, DSII, TAUNWX(IJ,IGST), TAUNWY(IJ,IGST) ) + ! CALL TAU_WAVE_ATMOS(SDENSIG(IJ,:,:,IGST), CINV1(IJ,:), SIG, DSII, TAUNWX(IJ,IGST), TAUNWY(IJ,IGST) ) ENDDO ELSE DO IJ = KIJS,KIJL @@ -538,7 +541,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & DO IJ = KIJS,KIJL TAUWGST(IJ,IGST) = SQRT(TAUWX(IJ,IGST)**2+TAUWY(IJ,IGST)**2) / ROAIRN(IJ) ! KINEMATIC TAUW TAUWDIRGST(IJ,IGST) = ATAN2(TAUWX(IJ,IGST),TAUWY(IJ,IGST)) - TAUNWGST(IJ,IGST) = SQRT(TAUNWX(IJ,IGST)**2+TAUNWY(IJ,IGST)**2) / ROAIRN(IJ) ! KINEMATIC TAUNW + ! TAUNWGST(IJ,IGST) = SQRT(TAUNWX(IJ,IGST)**2+TAUNWY(IJ,IGST)**2) / ROAIRN(IJ) ! KINEMATIC TAUNW ENDDO ENDDO @@ -581,7 +584,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & DO IJ = KIJS,KIJL TAUWGST_AVG(IJ) = TAUWGST(IJ,IGST) TAUWDIRGST_AVG(IJ) = TAUWDIRGST(IJ,IGST) - TAUNWGST_AVG(IJ) = TAUNWGST(IJ,IGST) + ! TAUNWGST_AVG(IJ) = TAUNWGST(IJ,IGST) USTARGST_AVG(IJ) = USTARGST(IJ,IGST) UPROXYGST_AVG(IJ) = UPROXYGST(IJ,IGST) SLGST_AVG(IJ,:,:) = SLGST(IJ,:,:,IGST) @@ -592,7 +595,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & DO IJ = KIJS,KIJL TAUWGST_AVG(IJ) = TAUWGST_AVG(IJ) + TAUWGST(IJ,IGST) TAUWDIRGST_AVG(IJ) = TAUWDIRGST_AVG(IJ) + TAUWDIRGST(IJ,IGST) - TAUNWGST_AVG(IJ) = TAUNWGST_AVG(IJ) + TAUNWGST(IJ,IGST) + ! TAUNWGST_AVG(IJ) = TAUNWGST_AVG(IJ) + TAUNWGST(IJ,IGST) USTARGST_AVG(IJ) = USTARGST_AVG(IJ) + USTARGST(IJ,IGST) UPROXYGST_AVG(IJ) = UPROXYGST_AVG(IJ) + UPROXYGST(IJ,IGST) SLGST_AVG(IJ,:,:) = SLGST_AVG(IJ,:,:) + SLGST(IJ,:,:,IGST) @@ -604,7 +607,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & DO IJ = KIJS,KIJL TAUW(IJ) = AVG_GST*TAUWGST_AVG(IJ) TAUWDIR(IJ) = AVG_GST*TAUWDIRGST_AVG(IJ) - TAUNW(IJ) = AVG_GST*TAUNWGST_AVG(IJ) + ! TAUNW(IJ) = AVG_GST*TAUNWGST_AVG(IJ) UFRIC(IJ) = AVG_GST*USTARGST_AVG(IJ) UPROXY(IJ) = AVG_GST*UPROXYGST_AVG(IJ) SL(IJ,:,:) = AVG_GST*SLGST_AVG(IJ,:,:) diff --git a/src/ecwam/yowphys.F90 b/src/ecwam/yowphys.F90 index 0aefcbb8c..c94c98d82 100644 --- a/src/ecwam/yowphys.F90 +++ b/src/ecwam/yowphys.F90 @@ -183,6 +183,12 @@ MODULE YOWPHYS ! Integer defining whether or not wind gustiness parametrization is used (1=no, 2=yes) INTEGER(KIND=JWIM) :: NGST +! Logical to determine whether to use LFACTOR + LOGICAL :: LLFACT + +! Upper freq. limit to extrap. to in LFACTOR + REAL(KIND=JWRB) :: FRQMAX + ! NSDSNTH is the number of directions on both used to compute the spectral saturation INTEGER(KIND=JWIM) :: NSDSNTH From 4e1c750780d60dbc3b77cb2550f81af00d0d3bb8 Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Thu, 23 Oct 2025 17:13:38 +0000 Subject: [PATCH 52/89] redundant file lfactor.new --- src/ecwam/lfactor.new.F90 | 282 -------------------------------------- 1 file changed, 282 deletions(-) delete mode 100644 src/ecwam/lfactor.new.F90 diff --git a/src/ecwam/lfactor.new.F90 b/src/ecwam/lfactor.new.F90 deleted file mode 100644 index e9d36c948..000000000 --- a/src/ecwam/lfactor.new.F90 +++ /dev/null @@ -1,282 +0,0 @@ -! (C) Copyright 1989- ECMWF. -! -! This software is licensed under the terms of the Apache Licence Version 2.0 -! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. -! In applying this licence, ECMWF does not waive the privileges and immunities -! granted to it by virtue of its status as an intergovernmental organisation -! nor does it submit to any jurisdiction. - - SUBROUTINE XX_LFACTOR(S, CINV, U10, USTAR, USDIR, ROAIRN, SIG, DSII, & - & LFACT, TAUWX, TAUWY, TAU) - -! ---------------------------------------------------------------------------- -! -! 1. Purpose : -! -! Numerical approximation for the reduction factor LFACTOR(f) to -! reduce energy in the high-frequency part of the resolved part -! of the spectrum to meet the constraint on total stress (TAU). -! The constraint is TAU <= TAU_TOT (TAU_TOT = TAU_WAV + TAU_VIS), -! thus the wind input is reduced to match our constraint. -! -! 2. Method : -! -! 1) If required, extend resolved part of the spectrum to 10Hz using -! an approximation for the spectral slope at the high frequency -! limit: Sin(F) prop. F**(-2) and for E(F) prop. F**(-5). -! 2) Calculate stresses: -! total stress: TAU_TOT = DAIR * USTAR**2 -! viscous stress: TAU_VIS = DAIR * Cv * U10**2 -! viscous stress (x,y-components): -! TAUV_X = TAU_VIS * COS(USDIR) -! TAUV_Y = TAU_VIS * SIN(USDIR) -! wave supported stress (x,y-components): /10Hz -! TAUW_X,Y = GRAV * DWAT * | [SinX,Y(F)]/C(F) dF -! / -! total stress (input): TAU = SQRT( (TAUW_X + TAUV_X)**2 -! + (TAUW_Y + TAUV_Y)**2 ) -! 3) If TAU does not meet our constraint reduce the wind input -! using reduction factor: -! LFACT(F) = MIN(1,exp((1-U/C(F))*RTAU)) -! Then alter RTAU and repeat 3) until our constraint is matched. -! -! ---------------------------------------------------------------------------- -! -!** INTERFACE. -! ---------- - -! *CALL* *LFACTOR(S, CINV, U10, USTAR, USDIR, ROAIRN, SIG, DSII, & -! & LFACT, TAUWX, TAUWY, TAU) -! *S* - NEG. WIND INPUT ENERGY DENSITY SPECTRUM. -! *CINV* - INVERSE PHASE SPEED CALC. IN INPUT ROUTINE -! *UABS* - 10M WIND SPEED -! *USTAR* - NEW FRICTION VELOCITY IN M/S. -! *USDIR* - WIND DIRECTION -! *ROAIRN* - AIR DENSITY IN KG/M3 -! *SIG* - FREQ (RAD) -! *DSII* - ZPI*DF -! *LFACT* - CORRECTION FACTOR -! *TAUNWX, TAUNWY* - NEGATIVE WAVE NORMAL STRESS COMPONENTS - -! EXTERNALS. -! ---------- -! TAUWINDS -! IRANGE - -! ORIGIN. -! ---------- -! Adapted from Babanin Young Donelan & Banner (ZBRY) physics -! as implemented as ST6 in WAVEWATCH-III -! WW3 module: W3SRC6MD -! WW3 subroutine: LFACTOR -! Implementation into ECWAM DECEMBER 2021 by J. Kousal - -! ---------------------------------------------------------------------- - USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU - - USE YOWFRED , ONLY : FR ,TH ,DFIM ,COSTH ,SINTH,& -& FRATIO ,DELTH ,FRIC - USE YOWMPP , ONLY : NINF ,NSUP - USE YOWPARAM , ONLY : NANG ,NFRE - USE YOWPCONS , ONLY : G ,ZPI ,ROWATER ,EPSMIN, GM1 - USE YOWPHYS , ONLY : BETAMAX ,ZALP ,TAUWSHELTER, XKAPPA, RNU ,RNUM, CDFAC - USE YOWSTAT , ONLY : ISHALLO - USE YOWTABL , ONLY : IAB ,SWELLFT - USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK - -! ---------------------------------------------------------------------- - - IMPLICIT NONE -#include "irange.intfb.h" -#include "tauwinds.intfb.h" - - REAL(KIND=JWRB), DIMENSION(NANG,NFRE), INTENT(IN) :: S - REAL(KIND=JWRB), DIMENSION(NFRE), INTENT(IN) :: CINV, SIG, DSII - REAL(KIND=JWRB), INTENT(IN) :: U10, USTAR, USDIR, ROAIRN - - REAL(KIND=JWRB), DIMENSION(NFRE), INTENT(OUT) :: LFACT - REAL(KIND=JWRB), INTENT(OUT) :: TAUWX, TAUWY, TAU - - REAL(KIND=JWRB), PARAMETER :: FRQMAX = 10.0_JWRB ! Upper freq. limit to extrap. to - INTEGER(KIND=JWIM), PARAMETER :: ITERMAX = 80 ! Max. no. iterations - ! to find numerical LFACT soln - - REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: ECOS2, ESIN2 - REAL(KIND=JWRB), DIMENSION(NANG,NFRE) :: SX, SY - - REAL(KIND=JWRB), DIMENSION(NFRE) :: SDENSX_LF, SDENSY_LF - REAL(KIND=JWRB), DIMENSION(NFRE) :: ZA_SX, ZA_SY - - REAL(KIND=JWRB) :: SDENSX_HF, SDENSY_HF - REAL(KIND=JWRB) :: TAUWX_LF, TAUWY_LF - REAL(KIND=JWRB) :: TAUWX_HF, TAUWY_HF - - REAL(KIND=JWRB) :: TAU_TOT, TAU_VIS, TAU_WAV - REAL(KIND=JWRB) :: TAUVX, TAUVY, TAUX, TAUY - REAL(KIND=JWRB) :: TAU_NND, TAU_INIT(2) - REAL(KIND=JWRB) :: UPROXY, RTAU, DRTAU, ERR - LOGICAL :: OVERSHOT - CHARACTER(LEN=23) :: IDTIME - - - INTEGER(KIND=JWIM) :: IK, ITH, M, SIGN_NEW, SIGN_OLD - INTEGER(KIND=JWIM) :: NK, NTH, NSPEC !num. of freqs, dirs, spec. bins - INTEGER(KIND=JWIM), DIMENSION(NANG) :: ITHN - INTEGER(KIND=JWIM), DIMENSION(NFRE) :: IKN - - REAL(KIND=JPHOOK) :: ZHOOK_HANDLE - -! ---------------------------------------------------------------------- - - IF (LHOOK) CALL DR_HOOK('XX_LFACTOR',0,ZHOOK_HANDLE) - - NTH = NANG ! NUMBER OF DIRS , SAME AS KL - NK = NFRE ! NUMBER OF FREQS, SAME AS ML - NSPEC = NK * NTH ! NUMBER OF SPECTRAL BINS - - ITHN = IRANGE(1,NTH,1) ! Index vector 1:NTH - DO IK = 1, NK - ECOS2 (ITHN+(IK-1)*NTH) = COSTH - ESIN2 (ITHN+(IK-1)*NTH) = SINTH - END DO - - SX = ABS(MIN(0.0_JWRB,S))*RESHAPE(ECOS2,(/NTH,NK/)) - SY = ABS(MIN(0.0_JWRB,S))*RESHAPE(ESIN2,(/NTH,NK/)) - -!/ ----------------------------------------------------------------- / -!/ ----------------------------------------------------------------- / -!/ Part I) --- low/high frequency contributions of TAU ------------- / - - !/ 0) --- split integral into low/high frequency contributions ------------- / - ! - ! - ! Th=2pi,f=inf Th=2pi,f=FR(NFRE) Th=2pi,f=inf - ! / / / / / / - ! | | S(f,Th)/c df dTh = | | S(f,Th)/c df dTh + | | S(f,Th)/c df dTh - ! / / / / / / - ! Th=0,f=0 Th=0,f=0 Th=0,f=FR(NFRE) - ! - ! - ! = LF_contribution + HF_contribution - ! - ! - !/ 1) --- low frequency contributions to the integral ---------------------- / - ! -- Direct summation over available freq. bins up to FR(NFRE) - - SDENSX_LF = SUM(SX,1) * DELTH - SDENSY_LF = SUM(SY,1) * DELTH - - TAUWX_LF = TAUWINDS(SDENSX_LF,CINV,DSII) ! x-component - TAUWY_LF = TAUWINDS(SDENSY_LF,CINV,DSII) ! y-component - - !/ 2) --- high frequency contributions to the integral --------------------- / - ! -- Assume spectral slope for S_IN(F) is proportional to F**(-2), then - ! integral collapses into easy analytic solution - ! - ! - ! Th=2pi,f=inf - ! / / - ! | | S(f,Th)/c df dTh = FR(NFRE) * DELTH * SUM(S(:,NFRE)) * GM1 - ! / / - ! Th=0,f=FR(NFRE) - ! - ! - ! Determine value of spectrum at NFRE (i.e. at highest frequency). - ! - Note, direction dimension must remain - - ZA_SX = SX(:,NFRE) - ZA_SY = SY(:,NFRE) - - SDENSX_HF = SIG(NFRE)**2 * DELTH * SUM(ZA_SX) * ZPI * GM1 / LOG(SIG(NFRE)) - SDENSY_HF = SIG(NFRE)**2 * DELTH * SUM(ZA_SY) * ZPI * GM1 / LOG(SIG(NFRE)) - - TAUWX_HF = G * ROWATER * ( SDENSX_HF ) - TAUWY_HF = G * ROWATER * ( SDENSY_HF ) - - !/ 3) --- summate low + high frequency contributions to the integral ------- / - - TAUWX = TAUWX_LF + TAUWX_HF - TAUWY = TAUWY_LF + TAUWY_HF - -!/ ----------------------------------------------------------------- / -!/ ----------------------------------------------------------------- / -!/ Part II) --- USTAR based TAU calculation ------------- / -! -!/ 2) --- Stress calculation ----------------------------------------- / -! --- The total stress ------------------------------------------- / - TAU_TOT = USTAR**2 * ROAIRN - -! --- The viscous stress and check that it does not exceed -! the total stress. ------------------------------------------ / - TAU_VIS = MAX(0.0_JWRB, -5.0E-5_JWRB*U10 + 1.1E-3_JWRB) * U10**2 * ROAIRN -! TAU_VIS = MIN(0.9 * TAU_TOT, TAU_VIS) - TAU_VIS = MIN(0.95_JWRB * TAU_TOT, TAU_VIS) - - TAUVX = TAU_VIS * COS(USDIR) - TAUVY = TAU_VIS * SIN(USDIR) - -! --- The wave supported stress (using elements calculated in Part I). -- / -! - TAU_WAV = SQRT(TAUWX**2 + TAUWY**2) ! normal stress (magnitude) - TAU_INIT = (/TAUWX,TAUWY/) ! unadjusted normal stress components - - TAUX = TAUVX + TAUWX ! total stress (x-component) - TAUY = TAUVY + TAUWY ! total stress (y-component) - TAU = SQRT(TAUX**2 + TAUY**2) ! total stress (magnitude) - ERR = (TAU-TAU_TOT)/TAU_TOT ! initial error - -!/ 3) --- Find reduced Sin(f) = L(f)*Sin(f) to satisfy our constraint -!/ TAU <= TAU_TOT --------------------------------------------- / - - LF = 1.0_JWRB - IK = 0 - - IF (TAU .GT. TAU_TOT) THEN - - OVERSHOT = .FALSE. - RTAU = ERR / 90.0_JWRB - DRTAU = 2.0_JWRB - SIGN_NEW = INT(SIGN(1.0_JWRB,ERR)) - - UPROXY = FRIC * CDFAC * USTAR - UCINV = 1.0_JWRB - (UPROXY * CINV) - - DO IK=1,ITERMAX - - LF = MIN(1.0_JWRB, EXP(UCINV * RTAU) ) - - TAUWX_LF = TAUWINDS(SDENSX_LF * LF,CINV,DSII) ! x-component - TAUWY_LF = TAUWINDS(SDENSY_LF * LF,CINV,DSII) ! y-component - - TAUWX_HF = G * ROWATER * ( SDENSX_HF * LF) - TAUWY_HF = G * ROWATER * ( SDENSY_HF * LF) - - TAUWX = TAUWX_LF + TAUWX_HF - TAUWY = TAUWY_LF + TAUWY_HF - TAU_WAV = SQRT(TAUWX**2 + TAUWY**2) - - TAUX = TAUVX + TAUWX - TAUY = TAUVY + TAUWY - TAU = SQRT(TAUX**2 + TAUY**2) - ERR = (TAU-TAU_TOT) / TAU_TOT - - SIGN_OLD = SIGN_NEW - SIGN_NEW = INT(SIGN(1.0_JWRB, ERR)) - -! --- Slow down DRTAU when overshot. -------------------------- / - - IF (SIGN_NEW .NE. SIGN_OLD) OVERSHOT = .TRUE. - IF (OVERSHOT) DRTAU = MAX(0.5_JWRB*(1.0_JWRB+DRTAU),1.00010_JWRB) - - RTAU = RTAU * (DRTAU**SIGN_NEW) - - IF (ABS(ERR) .LT. 1.54E-4_JWRB) EXIT - END DO - - END IF - - LFACT = LF - - IF (LHOOK) CALL DR_HOOK('XX_LFACTOR',1,ZHOOK_HANDLE) - - END SUBROUTINE XX_LFACTOR From 2c59e2726ef60e2f89c938c9ad799868ede4cedd Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Fri, 24 Oct 2025 09:04:22 +0000 Subject: [PATCH 53/89] move LFACTOR frequency related things into YOWFRED --- src/ecwam/initmdl.F90 | 36 +++++++++++++++++- src/ecwam/lfactor.F90 | 80 ++++++++++++++++----------------------- src/ecwam/sinflx_zbry.F90 | 24 ++---------- src/ecwam/yowfred.F90 | 8 ++++ 4 files changed, 79 insertions(+), 69 deletions(-) diff --git a/src/ecwam/initmdl.F90 b/src/ecwam/initmdl.F90 index cf057b8fd..f3abd5d09 100644 --- a/src/ecwam/initmdl.F90 +++ b/src/ecwam/initmdl.F90 @@ -177,7 +177,8 @@ SUBROUTINE INITMDL (NADV, & & DFIM ,DFIMOFR ,DFIMFR ,DFIMFR2 , & & DFIM_SIM ,DFIMOFR_SIM ,DFIMFR_SIM ,DFIMFR2_SIM , & & DFIM_END_L, DFIM_END_U, & - & WVPRPT_LAND + & WVPRPT_LAND, SIG ,DSII ,SIGM1 ,DF, & + & SIG_EXT , DSII_EXT ,IFRE_EXT ,NFRE_EXT USE YOWGRIBHD, ONLY : LGRHDIFS USE YOWGRID , ONLY : DELPHI, DELLAM, COSPH, & & NPROMA_WAM, NCHNK, IJFROMCHNK @@ -191,7 +192,7 @@ SUBROUTINE INITMDL (NADV, & & LLUNSTR USE YOWPCONS , ONLY : G ,CIRC ,PI ,ZPI , & & RAD ,ROWATER ,ZPI4GM2 ,FM2FP - USE YOWPHYS , ONLY : ALPHAPMAX, ALPHAPMINFAC, FLMINFAC + USE YOWPHYS , ONLY : ALPHAPMAX, ALPHAPMINFAC, FLMINFAC, FRQMAX USE YOWREFD , ONLY : LLUPDTTD USE YOWSHAL , ONLY : NDEPTH ,DEPTHA ,DEPTHD ,TOOSHALLOW USE YOWSPEC , ONLY : NBLKS ,NBLKE ,KLENTOP ,KLENBOT @@ -247,6 +248,7 @@ SUBROUTINE INITMDL (NADV, & #include "initdpthflds.intfb.h" #include "initnemocpl.intfb.h" #include "iniwcst.intfb.h" +#include "irange.intfb.h" #include "iwam_get_unit.intfb.h" #include "mcout.intfb.h" #include "outstep0.intfb.h" @@ -502,6 +504,36 @@ SUBROUTINE INITMDL (NADV, & DFIMFR2_SIM(M) = DFIM_SIM(M)*FR(M)**2 ENDDO + ! -------------------------------------------------- + ! TODO: ZBRY switch to not slow down runtime for IPHYS=0,1? + IF (.NOT.ALLOCATED(DF)) ALLOCATE(DF(NFRE)) + IF (.NOT.ALLOCATED(SIG)) ALLOCATE(SIG(NFRE)) + IF (.NOT.ALLOCATED(DSII)) ALLOCATE(DSII(NFRE)) + IF (.NOT.ALLOCATED(SIGM1)) ALLOCATE(SIGM1(NFRE)) + DO M=1,NFRE + DF(M) = FR(M)*( FRATIO - 1.0_JWRB ) + SIG(M) = ZPI*FR(M) + DSII(M) = ZPI*DF(M) + SIGM1(M) = 1.0_JWRB/SIG(M) + ENDDO + + ! DETERMINE THE NUMBER OF FREQUENCIES TO EXTEND TO + NFRE_EXT = CEILING(LOG(FRQMAX/FR(1))/LOG(FRATIO))+1 + NFRE_EXT = MAX(NFRE,NFRE_EXT) + IFRE_EXT = REAL( IRANGE(1,NFRE_EXT,1) ) + IF (.NOT.ALLOCATED(SIG_EXT)) ALLOCATE(SIG_EXT(NFRE_EXT)) + IF (.NOT.ALLOCATED(DSII_EXT)) ALLOCATE(DSII_EXT(NFRE_EXT)) + IF (NFRE .LT. NFRE_EXT) THEN + SIG_EXT = SIG(1)*FRATIO**(IFRE_EXT-1.0_JWRB) + DSII_EXT = 0.5_JWRB * SIG_EXT * (FRATIO-1.0_JWRB/FRATIO) + ! The first and last frequency bin: + DSII_EXT(1) = 0.5_JWRB * SIG_EXT(1) * (FRATIO-1.0_JWRB) + DSII_EXT(NFRE_EXT) = 0.5_JWRB * SIG_EXT(NFRE_EXT) * (FRATIO-1.0_JWRB) / FRATIO + ELSE + SIG_EXT = SIG + DSII_EXT = DSII + END IF + ! -------------------------------------------------- CALL TABU_SWELLFT diff --git a/src/ecwam/lfactor.F90 b/src/ecwam/lfactor.F90 index 5600af690..feb93bc98 100644 --- a/src/ecwam/lfactor.F90 +++ b/src/ecwam/lfactor.F90 @@ -6,7 +6,7 @@ ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. - SUBROUTINE LFACTOR(S, CINV, U10, USTAR, USDIR, ROAIRN, SIG, DSII, NK10Hz, & + SUBROUTINE LFACTOR(S, CINV, U10, USTAR, USDIR, ROAIRN, & & LFACT, TAUWX, TAUWY, TAU) ! ---------------------------------------------------------------------------- @@ -53,8 +53,6 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, USDIR, ROAIRN, SIG, DSII, NK10Hz, & ! *USTAR* - NEW FRICTION VELOCITY IN M/S. ! *USDIR* - WIND DIRECTION ! *ROAIRN* - AIR DENSITY IN KG/M3 -! *SIG* - FREQ (RAD) -! *DSII* - ZPI*DF ! *LFACT* - CORRECTION FACTOR ! *TAUNWX, TAUNWY* - NEGATIVE WAVE NORMAL STRESS COMPONENTS @@ -75,10 +73,11 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, USDIR, ROAIRN, SIG, DSII, NK10Hz, & USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU USE YOWFRED , ONLY : FR ,TH ,DFIM ,COSTH ,SINTH,& -& FRATIO ,DELTH ,FRIC +& FRATIO ,DELTH ,FRIC, SIG, DSII, SIGM1, DF, & +& NFRE_EXT ,DSII_EXT ,SIG_EXT USE YOWMPP , ONLY : NINF ,NSUP USE YOWPARAM , ONLY : NANG ,NFRE - USE YOWPCONS , ONLY : G ,ZPI ,ROWATER ,EPSMIN + USE YOWPCONS , ONLY : G ,ZPI ,ROWATER ,EPSMIN, GM1 USE YOWPHYS , ONLY : BETAMAX ,ZALP ,TAUWSHELTER, XKAPPA, RNU ,RNUM, CDFAC USE YOWSTAT , ONLY : ISHALLO USE YOWTABL , ONLY : IAB ,SWELLFT @@ -91,21 +90,19 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, USDIR, ROAIRN, SIG, DSII, NK10Hz, & #include "tauwinds.intfb.h" REAL(KIND=JWRB), DIMENSION(NANG,NFRE), INTENT(IN) :: S - REAL(KIND=JWRB), DIMENSION(NFRE), INTENT(IN) :: CINV, SIG, DSII + REAL(KIND=JWRB), DIMENSION(NFRE), INTENT(IN) :: CINV REAL(KIND=JWRB), INTENT(IN) :: U10, USTAR, USDIR, ROAIRN - INTEGER(KIND=JWIM), INTENT(IN) :: NK10Hz REAL(KIND=JWRB), DIMENSION(NFRE), INTENT(OUT) :: LFACT REAL(KIND=JWRB), INTENT(OUT) :: TAUWX, TAUWY, TAU - REAL(KIND=JWRB), PARAMETER :: FRQMAX = 10.0_JWRB ! Upper freq. limit to extrap. to INTEGER(KIND=JWIM), PARAMETER :: ITERMAX = 80 ! Max. no. iterations - ! to find numerical LFACT soln + ! to find numerical LFACT soln REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: ECOS2, ESIN2 - REAL(KIND=JWRB), DIMENSION(NK10Hz) :: IK10Hz, LF10Hz, SIG10Hz, CINV10Hz - REAL(KIND=JWRB), DIMENSION(NK10Hz) :: SDENS10Hz, SDENSX10Hz, SDENSY10Hz - REAL(KIND=JWRB), DIMENSION(NK10Hz) :: DSII10Hz, UCINV10Hz + REAL(KIND=JWRB), DIMENSION(NFRE_EXT) :: LF_EXT, CINV_EXT + REAL(KIND=JWRB), DIMENSION(NFRE_EXT) :: SDENS_EXT, SDENSX_EXT, SDENSY_EXT + REAL(KIND=JWRB), DIMENSION(NFRE_EXT) :: UCINV_EXT REAL(KIND=JWRB) :: TAU_TOT, TAU_VIS, TAU_WAV REAL(KIND=JWRB) :: TAUVX, TAUVY, TAUX, TAUY @@ -129,41 +126,30 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, USDIR, ROAIRN, SIG, DSII, NK10Hz, & NK = NFRE ! NUMBER OF FREQS, SAME AS ML NSPEC = NK * NTH ! NUMBER OF SPECTRAL BINS - IK10Hz = REAL( IRANGE(1,NK10Hz,1) ) - ITHN = IRANGE(1,NTH,1) ! Index vector 1:NTH DO IK = 1, NK ECOS2 (ITHN+(IK-1)*NTH) = COSTH ESIN2 (ITHN+(IK-1)*NTH) = SINTH END DO -! !/ 1) --- Either extrapolate arrays up to 10Hz or use discrete spectral ! grid per se. Limit the constraint to the positive part of the ! wind input only. ---------------------------------------------- / - IF (NK .LT. NK10Hz) THEN - SDENS10Hz(1:NK) = SUM(S,1) * DELTH - SDENSX10Hz(1:NK) = SUM(MAX(0.0_JWRB,S)*RESHAPE(ECOS2,(/NTH,NK/)),1) * DELTH - SDENSY10Hz(1:NK) = SUM(MAX(0.0_JWRB,S)*RESHAPE(ESIN2,(/NTH,NK/)),1) * DELTH - SIG10Hz = SIG(1)*FRATIO**(IK10Hz-1.0_JWRB) - CINV10Hz(1:NK) = CINV - CINV10Hz(NK+1:NK10Hz) = SIG10Hz(NK+1:NK10Hz)*0.101978_JWRB ! 1/c=σ/g - DSII10Hz = 0.5_JWRB * SIG10Hz * (FRATIO-1.0_JWRB/FRATIO) -! The first and last frequency bin: - DSII10Hz(1) = 0.5_JWRB * SIG10Hz(1) * (FRATIO-1.0_JWRB) - DSII10Hz(NK10Hz) = 0.5_JWRB * SIG10Hz(NK10Hz) * (FRATIO-1.0_JWRB) / FRATIO -! -! --- Spectral slope for S_IN(F) is proportional to F**(-2) ------ / - SDENS10Hz(NK+1:NK10Hz) = SDENS10Hz(NK) * (SIG10Hz(NK)/SIG10Hz(NK+1:NK10Hz))**2 - SDENSX10Hz(NK+1:NK10Hz) = SDENSX10Hz(NK) * (SIG10Hz(NK)/SIG10Hz(NK+1:NK10Hz))**2 - SDENSY10hz(NK+1:NK10Hz) = SDENSY10Hz(NK) * (SIG10Hz(NK)/SIG10Hz(NK+1:NK10Hz))**2 + IF (NFRE .LT. NFRE_EXT) THEN + CINV_EXT(1:NK) = CINV + SDENS_EXT(1:NK) = SUM(S,1) * DELTH + SDENSX_EXT(1:NK) = SUM(MAX(0.0_JWRB,S)*RESHAPE(ECOS2,(/NTH,NK/)),1) * DELTH + SDENSY_EXT(1:NK) = SUM(MAX(0.0_JWRB,S)*RESHAPE(ESIN2,(/NTH,NK/)),1) * DELTH + ! --- Spectral slope for S_IN(F) is proportional to F**(-2) ------ / + CINV_EXT(NK+1:NFRE_EXT) = SIG_EXT(NK+1:NFRE_EXT)*GM1 ! 1/c=σ/g + SDENS_EXT(NK+1:NFRE_EXT) = SDENS_EXT(NK) * (SIG_EXT(NK)/SIG_EXT(NK+1:NFRE_EXT))**2 + SDENSX_EXT(NK+1:NFRE_EXT) = SDENSX_EXT(NK) * (SIG_EXT(NK)/SIG_EXT(NK+1:NFRE_EXT))**2 + SDENSY_EXT(NK+1:NFRE_EXT) = SDENSY_EXT(NK) * (SIG_EXT(NK)/SIG_EXT(NK+1:NFRE_EXT))**2 ELSE - SIG10Hz = SIG - CINV10Hz = CINV - DSII10Hz = DSII - SDENS10Hz(1:NK) = SUM(S,1) * DELTH - SDENSX10Hz(1:NK) = SUM(MAX(0.0_JWRB,S)*RESHAPE(ECOS2,(/NTH,NK/)),1) * DELTH - SDENSY10Hz(1:NK) = SUM(MAX(0.0_JWRB,S)*RESHAPE(ESIN2,(/NTH,NK/)),1) * DELTH + CINV_EXT = CINV + SDENS_EXT(1:NK) = SUM(S,1) * DELTH + SDENSX_EXT(1:NK) = SUM(MAX(0.0_JWRB,S)*RESHAPE(ECOS2,(/NTH,NK/)),1) * DELTH + SDENSY_EXT(1:NK) = SUM(MAX(0.0_JWRB,S)*RESHAPE(ESIN2,(/NTH,NK/)),1) * DELTH END IF ! !/ 2) --- Stress calculation ----------------------------------------- / @@ -180,9 +166,9 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, USDIR, ROAIRN, SIG, DSII, NK10Hz, & TAUVY = TAU_VIS * SIN(USDIR) ! ! --- The wave supported stress. --------------------------------- / - TAUWX = TAUWINDS(SDENSX10Hz,CINV10Hz,DSII10Hz) ! normal stress (x-component) - TAUWY = TAUWINDS(SDENSY10Hz,CINV10Hz,DSII10Hz) ! normal stress (y-component) - TAU_NND = TAUWINDS(SDENS10Hz, CINV10Hz,DSII10Hz) ! normal stress (non-directional) + TAUWX = TAUWINDS(SDENSX_EXT,CINV_EXT,DSII_EXT) ! normal stress (x-component) + TAUWY = TAUWINDS(SDENSY_EXT,CINV_EXT,DSII_EXT) ! normal stress (y-component) + TAU_NND = TAUWINDS(SDENS_EXT, CINV_EXT,DSII_EXT) ! normal stress (non-directional) TAU_WAV = SQRT(TAUWX**2 + TAUWY**2) ! normal stress (magnitude) TAU_INIT = (/TAUWX,TAUWY/) ! unadjusted normal stress components ! @@ -194,7 +180,7 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, USDIR, ROAIRN, SIG, DSII, NK10Hz, & !/ 3) --- Find reduced Sin(f) = L(f)*Sin(f) to satisfy our constraint !/ TAU <= TAU_TOT --------------------------------------------- / !CALL STME21 ( TIME , IDTIME ) - LF10Hz = 1.0_JWRB + LF_EXT = 1.0_JWRB IK = 0 ! IF (TAU .GT. TAU_TOT) THEN @@ -206,14 +192,14 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, USDIR, ROAIRN, SIG, DSII, NK10Hz, & SIGN_NEW = INT(SIGN(1.0_JWRB,ERR)) UPROXY = FRIC * CDFAC * USTAR - UCINV10Hz = 1.0_JWRB - (UPROXY * CINV10Hz) + UCINV_EXT = 1.0_JWRB - (UPROXY * CINV_EXT) DO IK=1,ITERMAX - LF10Hz = MIN(1.0_JWRB, EXP(UCINV10Hz * RTAU) ) - TAU_NND = TAUWINDS(SDENS10Hz *LF10Hz,CINV10Hz,DSII10Hz) - TAUWX = TAUWINDS(SDENSX10Hz*LF10Hz,CINV10Hz,DSII10Hz) - TAUWY = TAUWINDS(SDENSY10Hz*LF10Hz,CINV10Hz,DSII10Hz) + LF_EXT = MIN(1.0_JWRB, EXP(UCINV_EXT * RTAU) ) + TAU_NND = TAUWINDS(SDENS_EXT *LF_EXT,CINV_EXT,DSII_EXT) + TAUWX = TAUWINDS(SDENSX_EXT*LF_EXT,CINV_EXT,DSII_EXT) + TAUWY = TAUWINDS(SDENSY_EXT*LF_EXT,CINV_EXT,DSII_EXT) TAU_WAV = SQRT(TAUWX**2 + TAUWY**2) TAUX = TAUVX + TAUWX TAUY = TAUVY + TAUWY @@ -235,7 +221,7 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, USDIR, ROAIRN, SIG, DSII, NK10Hz, & END IF - LFACT(1:NK) = LF10Hz(1:NK) + LFACT(1:NK) = LF_EXT(1:NK) IF (LHOOK) CALL DR_HOOK('LFACTOR',1,ZHOOK_HANDLE) diff --git a/src/ecwam/sinflx_zbry.F90 b/src/ecwam/sinflx_zbry.F90 index da215de7c..9da6abe2a 100644 --- a/src/ecwam/sinflx_zbry.F90 +++ b/src/ecwam/sinflx_zbry.F90 @@ -96,7 +96,8 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & USE YOWWNDG , ONLY : ICODE ,ICODE_CPL - USE YOWFRED , ONLY : FR ,TH ,DFIM ,COSTH ,SINTH, ZPIFR, DELTH, FRATIO, FRIC + USE YOWFRED , ONLY : FR ,TH ,DFIM ,COSTH ,SINTH, ZPIFR, DELTH, FRATIO, FRIC, & + & SIG ,DSII ,SIGM1 ,DF ,NFRE_EXT USE YOWPARAM , ONLY : NANG ,NFRE USE YOWPCONS , ONLY : G ,GM1 ,EPSMIN, EPSUS, ZPI, ROWATER USE YOWPHYS , ONLY : ZALP ,TAUWSHELTER, XKAPPA, BETAMAXOXKAPPA2, & @@ -179,7 +180,6 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & INTEGER(KIND=JWIM), DIMENSION(NFRE) :: IKN REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: ECOS2, ESIN2, SIG2 -REAL(KIND=JWRB), DIMENSION(NFRE) :: DSII, SIG, DF REAL(KIND=JWRB), DIMENSION(NANG,NFRE) :: SPOSDENSIG, SNEGDENSIG REAL(KIND=JWRB), DIMENSION(KIJL,NANG*NFRE) :: CG2, WN2 @@ -197,7 +197,6 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & REAL(KIND=JWRB), DIMENSION(KIJL,NGST) :: UPROXYGST REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: XK, CGG_WAM, CM -REAL(KIND=JWRB), DIMENSION(NFRE) :: SIGM1 ! For USTAR, Z0, CHNK REAL(KIND=JWRB), DIMENSION(KIJL,NGST) :: TAU @@ -208,7 +207,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & REAL(KIND=JWRB), PARAMETER :: USTMIN=0.000001_JWRB REAL(KIND=JWRB), PARAMETER :: PCHARMAX=0.1_JWRB REAL(KIND=JWRB), PARAMETER :: Z0FG=0.01_JWRB -INTEGER(KIND=JWIM) :: ITER, NFRE_EXT +INTEGER(KIND=JWIM) :: ITER REAL(KIND=JWRB) :: XZNLEV, PCHAROG, XKUTOP, XOLOGZ0 REAL(KIND=JWRB) :: UST, USTOLD, Z0CH, Z0VIS, Z0TOT, FF, DELF REAL(KIND=JWRB) :: CHARNOCK_MIN,CHNKMIN ! For Capping @@ -271,17 +270,6 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & ! Wind height ZNLEV = 10._JWRB -! COMPUTE FREQUENCY INTERVALLS -DO M = 1,NFRE - DF(M) = FR(M)*( FRATIO - 1.0_JWRB ) -ENDDO - -DO M = 1,NFRE - SIG(M) = ZPI*FR(M) - DSII(M) = ZPI*DF(M) - SIGM1(M) = 1.0_JWRB/SIG(M) -END DO - DO M=1,NFRE DO IJ=KIJS,KIJL CM(IJ,M) = WAVNUM(IJ,M)*SIGM1(M) @@ -479,17 +467,13 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & !/ 5) --- calculate reduction factor LFACT using non-directional ! spectral density of the wind input ------------------------- / - ! DETERMINE THE NUMBER OF FREQUENCIES TO EXTEND TO - NFRE_EXT = CEILING(LOG(FRQMAX/(SIG(1)/ZPI))/LOG(FRATIO))+1 - NFRE_EXT = MAX(NFRE,NFRE_EXT) - DO IGST=1,NGST DO IJ = KIJS,KIJL SDENSIG(IJ,:,:,IGST) = RESHAPE(S(IJ,:,IGST)*SIG2/CG2(IJ,:),(/ NANG, NFRE /)) CALL LFACTOR(SDENSIG(IJ,:,:,IGST), CINV1(IJ,:), UABSGST(IJ,IGST), USTARGST(IJ,IGST), WDWAVE(IJ), & - & ROAIRN(IJ), SIG, DSII, NFRE_EXT, LFACT(IJ,:,IGST), TAUWX(IJ,IGST), TAUWY(IJ,IGST), TAU(IJ,IGST)) + & ROAIRN(IJ), LFACT(IJ,:,IGST), TAUWX(IJ,IGST), TAUWY(IJ,IGST), TAU(IJ,IGST)) ENDDO !/ 6) --- apply reduction (LFACT) to the entire spectrum ------------- / diff --git a/src/ecwam/yowfred.F90 b/src/ecwam/yowfred.F90 index cdc94c767..9d6f73ab6 100644 --- a/src/ecwam/yowfred.F90 +++ b/src/ecwam/yowfred.F90 @@ -20,6 +20,13 @@ MODULE YOWFRED !* ** *FREDIR* - FREQUENCY AND DIRECTION GRID. REAL(KIND=JWRB), ALLOCATABLE :: FR(:) + REAL(KIND=JWRB), ALLOCATABLE :: DF(:) + REAL(KIND=JWRB), ALLOCATABLE :: SIG(:) + REAL(KIND=JWRB), ALLOCATABLE :: SIGM1(:) + REAL(KIND=JWRB), ALLOCATABLE :: DSII(:) + REAL(KIND=JWRB), ALLOCATABLE :: SIG_EXT(:) + REAL(KIND=JWRB), ALLOCATABLE :: DSII_EXT(:) + REAL(KIND=JWRB), ALLOCATABLE :: IFRE_EXT(:) REAL(KIND=JWRB), ALLOCATABLE :: DFIM(:) REAL(KIND=JWRB), ALLOCATABLE :: RHOWG_DFIM(:) REAL(KIND=JWRB), ALLOCATABLE :: DFIM_SIM(:) @@ -58,6 +65,7 @@ MODULE YOWFRED REAL(KIND=JWRB) :: XKMSS_CUTOFF INTEGER(KIND=JWIM) :: NWAV_GC + INTEGER(KIND=JWIM) :: NFRE_EXT REAL(KIND=JWRB), PARAMETER :: KRATIO_GC = 1.2_JWRB REAL(KIND=JWRB), PARAMETER :: XLOGKRATIOM1_GC = 1.0_JWRB/LOG(KRATIO_GC) REAL(KIND=JWRB), PARAMETER :: XKS_GC = 0.006_JWRB From 3d2d6725450376eeb3ff6f60e843acd0cc6644d7 Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Fri, 24 Oct 2025 10:12:03 +0000 Subject: [PATCH 54/89] correct high frequency contribution in tau_wave_atmos --- src/ecwam/initmdl.F90 | 4 +++- src/ecwam/sdissip_zbry.F90 | 14 ++------------ src/ecwam/sinflx_zbry.F90 | 2 +- src/ecwam/swldissip_zbry.F90 | 9 ++------- src/ecwam/tau_wave_atmos.F90 | 29 ++++++++++++++++++----------- src/ecwam/yowfred.F90 | 1 + 6 files changed, 27 insertions(+), 32 deletions(-) diff --git a/src/ecwam/initmdl.F90 b/src/ecwam/initmdl.F90 index f3abd5d09..db629df49 100644 --- a/src/ecwam/initmdl.F90 +++ b/src/ecwam/initmdl.F90 @@ -178,7 +178,7 @@ SUBROUTINE INITMDL (NADV, & & DFIM_SIM ,DFIMOFR_SIM ,DFIMFR_SIM ,DFIMFR2_SIM , & & DFIM_END_L, DFIM_END_U, & & WVPRPT_LAND, SIG ,DSII ,SIGM1 ,DF, & - & SIG_EXT , DSII_EXT ,IFRE_EXT ,NFRE_EXT + & SIG_EXT , DSII_EXT ,IFRE_EXT ,NFRE_EXT ,DDEN USE YOWGRIBHD, ONLY : LGRHDIFS USE YOWGRID , ONLY : DELPHI, DELLAM, COSPH, & & NPROMA_WAM, NCHNK, IJFROMCHNK @@ -508,12 +508,14 @@ SUBROUTINE INITMDL (NADV, & ! TODO: ZBRY switch to not slow down runtime for IPHYS=0,1? IF (.NOT.ALLOCATED(DF)) ALLOCATE(DF(NFRE)) IF (.NOT.ALLOCATED(SIG)) ALLOCATE(SIG(NFRE)) + IF (.NOT.ALLOCATED(DDEN)) ALLOCATE(DDEN(NFRE)) IF (.NOT.ALLOCATED(DSII)) ALLOCATE(DSII(NFRE)) IF (.NOT.ALLOCATED(SIGM1)) ALLOCATE(SIGM1(NFRE)) DO M=1,NFRE DF(M) = FR(M)*( FRATIO - 1.0_JWRB ) SIG(M) = ZPI*FR(M) DSII(M) = ZPI*DF(M) + DDEN(M) = ZPI*DFIM(M)*SIG(M) SIGM1(M) = 1.0_JWRB/SIG(M) ENDDO diff --git a/src/ecwam/sdissip_zbry.F90 b/src/ecwam/sdissip_zbry.F90 index 15c877f9c..ad8138747 100644 --- a/src/ecwam/sdissip_zbry.F90 +++ b/src/ecwam/sdissip_zbry.F90 @@ -72,7 +72,8 @@ SUBROUTINE SDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & ! ---------------------------------------------------------------------- USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU - USE YOWFRED , ONLY : FR , TH ,ZPIFR ,FRATIO ,DELTH, DFIM + USE YOWFRED , ONLY : FR , TH ,ZPIFR ,FRATIO ,DELTH, DFIM,& + & SIG , DF USE YOWPCONS , ONLY : G ,ZPI USE YOWPARAM , ONLY : NANG ,NFRE USE YOWSTAT , ONLY : LLLOWWINDS @@ -99,7 +100,6 @@ SUBROUTINE SDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & INTEGER(KIND=JWIM), DIMENSION(NFRE) :: IKN REAL(KIND=JWRB), DIMENSION(NFRE) :: FREQ ! frequencies [Hz] - REAL(KIND=JWRB), DIMENSION(NFRE) :: SIG ! frequencies [RAD] REAL(KIND=JWRB), DIMENSION(NFRE) :: DFII ! frequency bandwiths [Hz] REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: ANAR ! directional narrowness REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: EDENS ! spectral density E(f) @@ -110,7 +110,6 @@ SUBROUTINE SDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: T2 ! forced dissipation term REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: T12 ! =T1+T2 or combined dissipation REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: ADF ! temporary variable - REAL(KIND=JWRB), DIMENSION(NFRE) :: DF ! FREQUENCY INTERVALS REAL(KIND=JWRB) :: BNT ! empirical constant for wave breaking probability REAL(KIND=JWRB) :: XFAC ! temporary variableis REAL(KIND=JWRB), DIMENSION(KIJL) :: EDENSMAX ! temporary variable @@ -128,15 +127,6 @@ SUBROUTINE SDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & NSPEC = NANG * NFRE ! NUMBER OF SPECTRAL BINS - DO M = 1,NFRE - SIG(M) = ZPI*FR(M) - END DO - -! COMPUTE FREQUENCY INTERVALLS - DO M = 1,NFRE - DF(M) = FR(M)*( FRATIO - 1.0_JWRB ) - ENDDO - IKN = IRANGE(1,NSPEC,NANG) ! Index vector for elements of 1 ... NFRE ! ! such that e.g. SIG(1:NFRE) = SIG2(IKN). diff --git a/src/ecwam/sinflx_zbry.F90 b/src/ecwam/sinflx_zbry.F90 index 9da6abe2a..236c6c76f 100644 --- a/src/ecwam/sinflx_zbry.F90 +++ b/src/ecwam/sinflx_zbry.F90 @@ -512,7 +512,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & ! ! --- compute negative component of the wave supported stresses ! ! from negative part of the wind input ---------------------- / SDENSIG(IJ,:,:,IGST) = RESHAPE(S(IJ,:,IGST)*SIG2/CG2(IJ,:),(/ NANG, NFRE /)) - ! CALL TAU_WAVE_ATMOS(SDENSIG(IJ,:,:,IGST), CINV1(IJ,:), SIG, DSII, TAUNWX(IJ,IGST), TAUNWY(IJ,IGST) ) + ! CALL TAU_WAVE_ATMOS(SDENSIG(IJ,:,:,IGST), CINV1(IJ,:), TAUNWX(IJ,IGST), TAUNWY(IJ,IGST) ) ENDDO ELSE DO IJ = KIJS,KIJL diff --git a/src/ecwam/swldissip_zbry.F90 b/src/ecwam/swldissip_zbry.F90 index 85a966fc7..b363fd3c9 100644 --- a/src/ecwam/swldissip_zbry.F90 +++ b/src/ecwam/swldissip_zbry.F90 @@ -66,7 +66,8 @@ SUBROUTINE SWLDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & ! ---------------------------------------------------------------------- USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU - USE YOWFRED , ONLY : FR , TH ,ZPIFR ,FRATIO ,DELTH, DFIM + USE YOWFRED , ONLY : FR , TH ,ZPIFR ,FRATIO ,DELTH, DFIM, + & SIG , DDEN USE YOWPCONS , ONLY : G ,ZPI USE YOWPARAM , ONLY : NANG ,NFRE USE YOWPHYS , ONLY : LLSWL6CSTB1, ZSWL6B1 @@ -95,7 +96,6 @@ SUBROUTINE SWLDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE) :: KK REAL(KIND=JWRB), DIMENSION(KIJL,NANG*NFRE) :: S, D, A, CG2 REAL(KIND=JWRB), DIMENSION(KIJL) :: B1 - REAL(KIND=JWRB), DIMENSION(NFRE) :: SIG, DDEN REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: SIG2 REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE) :: DSWL @@ -107,11 +107,6 @@ SUBROUTINE SWLDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & NSPEC = NANG * NFRE ! NUMBER OF SPECTRAL BINS - DO M = 1,NFRE - SIG(M) = ZPI*FR(M) - DDEN(M) = ZPI*DFIM(M)*SIG(M) - END DO - IKN = IRANGE(1,NSPEC,NANG) ! Index vector for elements of 1 ... NFRE ! ! such that e.g. SIG(1:NFRE) = SIG2(IKN). DO K = 1, NANG ! Apply to all directions diff --git a/src/ecwam/tau_wave_atmos.F90 b/src/ecwam/tau_wave_atmos.F90 index 266275c37..26c8f020e 100644 --- a/src/ecwam/tau_wave_atmos.F90 +++ b/src/ecwam/tau_wave_atmos.F90 @@ -6,7 +6,7 @@ ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. - SUBROUTINE TAU_WAVE_ATMOS(S, CINV, SIG, DSII, TAUNWX, TAUNWY ) + SUBROUTINE TAU_WAVE_ATMOS(S, CINV, TAUNWX, TAUNWY ) ! ---------------------------------------------------------------------- ! @@ -30,12 +30,10 @@ SUBROUTINE TAU_WAVE_ATMOS(S, CINV, SIG, DSII, TAUNWX, TAUNWY ) !** INTERFACE. ! ---------- -! *CALL* *TAU_WAVE_ATMOS(S, CINV, SIG, DSII, TAUNWX, TAUNWY ) +! *CALL* *TAU_WAVE_ATMOS(S, CINV, TAUNWX, TAUNWY ) ! *S* - NEG. WIND INPUT ENERGY DENSITY SPECTRUM. ! *CINV* - INVERSE PHASE SPEED CALC. IN INPUT ROUTINE -! *SIG* - FREQ (RAD) -! *DSII* - ZPI*DF ! *TAUNWX, TAUNWY* - NEGATIVE WAVE NORMAL STRESS COMPONENTS ! EXTERNALS. @@ -55,10 +53,11 @@ SUBROUTINE TAU_WAVE_ATMOS(S, CINV, SIG, DSII, TAUNWX, TAUNWY ) USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU USE YOWFRED , ONLY : FR ,TH ,DFIM ,COSTH ,SINTH,& - & FRATIO ,DELTH + & FRATIO ,DELTH ,SIG , DSII USE YOWMPP , ONLY : NINF ,NSUP USE YOWPARAM , ONLY : NANG ,NFRE USE YOWPCONS , ONLY : G ,ZPI ,ROWATER ,EPSMIN, GM1 + USE YOWPHYS , ONLY : FRQMAX USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK ! ---------------------------------------------------------------------- @@ -68,7 +67,7 @@ SUBROUTINE TAU_WAVE_ATMOS(S, CINV, SIG, DSII, TAUNWX, TAUNWY ) #include "tauwinds.intfb.h" REAL(KIND=JWRB), DIMENSION(NANG,NFRE), INTENT(IN) :: S ! Sin(sigma) in [m2/rad-Hz] - REAL(KIND=JWRB), DIMENSION(NFRE), INTENT(IN) :: CINV, SIG, DSII + REAL(KIND=JWRB), DIMENSION(NFRE), INTENT(IN) :: CINV REAL(KIND=JWRB), INTENT(OUT) :: TAUNWX, TAUNWY @@ -133,11 +132,19 @@ SUBROUTINE TAU_WAVE_ATMOS(S, CINV, SIG, DSII, TAUNWX, TAUNWY ) ! integral collapses into easy analytic solution ! ! - ! Th=2pi,f=inf + ! Th=2pi,ω=inf ! / / - ! | | S(f,Th)/c df dTh = FR(NFRE)**2 * DELTH * SUM(S(:,NFRE)) * ZPI * GM1 / LOG(SIG(NFRE)) + ! | | S(f,Th)/c df dTh = (LOG(inf) - LOG(SIG(NFRE))) * SIG(NFRE)**2 * DELTH * SUM(S(:,NFRE)) * ZPI * GM1 ! / / - ! Th=0,f=FR(NFRE) + ! Th=0,ω=SIG(NFRE) + ! + ! Instead, use FRQMAX extension (e.g. 10Hz) + ! + ! Th=2pi,ω=ZPI*FRQMAX + ! / / + ! | | S(f,Th)/c df dTh = (LOG(ZPI*FRQMAX) - LOG(SIG(NFRE))) * SIG(NFRE)**2 * DELTH * SUM(S(:,NFRE)) * ZPI * GM1 + ! / / + ! Th=0,ω=SIG(NFRE) ! ! ! Determine value of spectrum at NFRE (i.e. at highest frequency). @@ -146,8 +153,8 @@ SUBROUTINE TAU_WAVE_ATMOS(S, CINV, SIG, DSII, TAUNWX, TAUNWY ) ZA_SX = SX(:,NFRE) ZA_SY = SY(:,NFRE) - SDENSX_HF = SIG(NFRE)**2 * DELTH * SUM(ZA_SX) * ZPI * GM1 / LOG(SIG(NFRE)) - SDENSY_HF = SIG(NFRE)**2 * DELTH * SUM(ZA_SY) * ZPI * GM1 / LOG(SIG(NFRE)) + SDENSX_HF = (LOG(ZPI*FRQMAX) - LOG(SIG(NFRE))) * SIG(NFRE)**2 * DELTH * SUM(ZA_SX) * ZPI * GM1 + SDENSY_HF = (LOG(ZPI*FRQMAX) - LOG(SIG(NFRE))) * SIG(NFRE)**2 * DELTH * SUM(ZA_SY) * ZPI * GM1 TAUNWX_HF = G * ROWATER * ( SDENSX_HF ) TAUNWY_HF = G * ROWATER * ( SDENSY_HF ) diff --git a/src/ecwam/yowfred.F90 b/src/ecwam/yowfred.F90 index 9d6f73ab6..82c7d3316 100644 --- a/src/ecwam/yowfred.F90 +++ b/src/ecwam/yowfred.F90 @@ -22,6 +22,7 @@ MODULE YOWFRED REAL(KIND=JWRB), ALLOCATABLE :: FR(:) REAL(KIND=JWRB), ALLOCATABLE :: DF(:) REAL(KIND=JWRB), ALLOCATABLE :: SIG(:) + REAL(KIND=JWRB), ALLOCATABLE :: DDEN(:) REAL(KIND=JWRB), ALLOCATABLE :: SIGM1(:) REAL(KIND=JWRB), ALLOCATABLE :: DSII(:) REAL(KIND=JWRB), ALLOCATABLE :: SIG_EXT(:) From e51a2c3f1c28fafe5a610ce174429f2a2ae65e89 Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Fri, 24 Oct 2025 15:20:00 +0000 Subject: [PATCH 55/89] how I believe lfactor should be, although something must be wrong in implementation (lfactor.old works) --- src/ecwam/CMakeLists.txt | 1 + src/ecwam/ei.F90 | 89 ++++++++++++++ src/ecwam/lfactor.F90 | 189 ++++++++++++++++++++--------- src/ecwam/lfactor.old.F90 | 225 +++++++++++++++++++++++++++++++++++ src/ecwam/swldissip_zbry.F90 | 2 +- 5 files changed, 450 insertions(+), 56 deletions(-) create mode 100644 src/ecwam/ei.F90 create mode 100644 src/ecwam/lfactor.old.F90 diff --git a/src/ecwam/CMakeLists.txt b/src/ecwam/CMakeLists.txt index 76daa75b1..17430020f 100644 --- a/src/ecwam/CMakeLists.txt +++ b/src/ecwam/CMakeLists.txt @@ -73,6 +73,7 @@ list( APPEND ecwam_srcs depthprpt.F90 difdate.F90 dominant_period.F90 + ei.F90 expand_string.F90 femean.F90 femeanws.F90 diff --git a/src/ecwam/ei.F90 b/src/ecwam/ei.F90 new file mode 100644 index 000000000..48e869817 --- /dev/null +++ b/src/ecwam/ei.F90 @@ -0,0 +1,89 @@ +! (C) Copyright 1989- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. + + FUNCTION EI(x) RESULT(res) + +! ---------------------------------------------------------------------------- +! +! 1. Purpose : +! + ! Real-valued exponential integral Ei(x) approximation for real x + ! Uses power series for small/negative x and an asymptotic expansion for large positive x. + ! Reasonable accuracy for typical geophysical ranges; replace with a library routine if you need higher precision. + +!---------------------------------------------------------------------- +! +! INTERFACE VARIABLES. +! -------------------- + +! ORIGIN. +! ---------- +! Adapted from Babanin Young Donelan & Banner (ZBRY) physics +! as implemented as ST6 in WAVEWATCH-III +! WW3 module: W3SRC6MD +! WW3 subroutine: TAUWINDS +! Implementation into ECWAM DECEMBER 2021 by J. Kousal + +! ---------------------------------------------------------------------------- +! + + USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU + USE YOMHOOK , ONLY : LHOOK ,DR_HOOK, JPHOOK + +!---------------------------------------------------------------------- + + IMPLICIT NONE + + REAL(KIND=JWRB), INTENT(IN) :: x + REAL(KIND=JWRB), PARAMETER :: EULER = 0.57721566490153286060651209_JWRB + REAL(KIND=JWRB) :: term, sum, res + INTEGER(KIND=JWIM) :: k, kmax + REAL(KIND=JWRB) :: eps + + REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ---------------------------------------------------------------------------- +! + + IF (LHOOK) CALL DR_HOOK('EI',0,ZHOOK_HANDLE) + + + eps = 1.0E-12_JWRB + if (x < 0.0_JWRB .or. abs(x) <= 6.0_JWRB) then + ! series: Ei(x) = gamma + ln(|x|) + sum_{k=1..inf} x^k/(k*k!) + if (x == 0.0_JWRB) then + res = -huge(1.0_JWRB) ! singular; caller should not hit exact zero normally + return + end if + sum = 0.0_JWRB + term = x + k = 1 + kmax = 200 + do while (k <= kmax) + sum = sum + term/real(k,kind=JWRB) + term = term * x/real(k+1,kind=JWRB) + if (abs(term/real(k+1,kind=JWRB)) < abs(sum)*eps) exit + k = k + 1 + end do + res = EULER + log(abs(x)) + sum + else + ! asymptotic for large positive x: Ei(x) ~ exp(x)/x * (1 + 1/x + 2!/x^2 + 6/x^3 + ...) + kmax = 50 + sum = 1.0_JWRB + term = 1.0_JWRB + do k = 1, kmax + term = term * real(k,kind=JWRB) / x + sum = sum + term + if (abs(term) < abs(sum)*eps) exit + end do + res = exp(x) / x * sum + end if + + IF (LHOOK) CALL DR_HOOK('EI',1,ZHOOK_HANDLE) + + END FUNCTION EI \ No newline at end of file diff --git a/src/ecwam/lfactor.F90 b/src/ecwam/lfactor.F90 index feb93bc98..c37e54d3e 100644 --- a/src/ecwam/lfactor.F90 +++ b/src/ecwam/lfactor.F90 @@ -73,14 +73,11 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, USDIR, ROAIRN, & USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU USE YOWFRED , ONLY : FR ,TH ,DFIM ,COSTH ,SINTH,& -& FRATIO ,DELTH ,FRIC, SIG, DSII, SIGM1, DF, & -& NFRE_EXT ,DSII_EXT ,SIG_EXT - USE YOWMPP , ONLY : NINF ,NSUP +& FRATIO ,DELTH ,FRIC, SIG,DSII ,SIGM1,& +& DF ,NFRE_EXT ,DSII_EXT ,SIG_EXT USE YOWPARAM , ONLY : NANG ,NFRE USE YOWPCONS , ONLY : G ,ZPI ,ROWATER ,EPSMIN, GM1 - USE YOWPHYS , ONLY : BETAMAX ,ZALP ,TAUWSHELTER, XKAPPA, RNU ,RNUM, CDFAC - USE YOWSTAT , ONLY : ISHALLO - USE YOWTABL , ONLY : IAB ,SWELLFT + USE YOWPHYS , ONLY : CDFAC ,FRQMAX USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK ! ---------------------------------------------------------------------- @@ -88,8 +85,9 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, USDIR, ROAIRN, & IMPLICIT NONE #include "irange.intfb.h" #include "tauwinds.intfb.h" +#include "ei.intfb.h" - REAL(KIND=JWRB), DIMENSION(NANG,NFRE), INTENT(IN) :: S + REAL(KIND=JWRB), DIMENSION(NANG,NFRE), INTENT(IN) :: S ! Sin(sigma) in [m2/rad-Hz] REAL(KIND=JWRB), DIMENSION(NFRE), INTENT(IN) :: CINV REAL(KIND=JWRB), INTENT(IN) :: U10, USTAR, USDIR, ROAIRN @@ -100,16 +98,24 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, USDIR, ROAIRN, & ! to find numerical LFACT soln REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: ECOS2, ESIN2 - REAL(KIND=JWRB), DIMENSION(NFRE_EXT) :: LF_EXT, CINV_EXT - REAL(KIND=JWRB), DIMENSION(NFRE_EXT) :: SDENS_EXT, SDENSX_EXT, SDENSY_EXT - REAL(KIND=JWRB), DIMENSION(NFRE_EXT) :: UCINV_EXT + REAL(KIND=JWRB), DIMENSION(NANG,NFRE) :: SX, SY + REAL(KIND=JWRB), DIMENSION(NFRE) :: SDENSX_LF, SDENSY_LF + REAL(KIND=JWRB), DIMENSION(NFRE) :: ZA_SX, ZA_SY + REAL(KIND=JWRB), DIMENSION(NFRE) :: UCINV + REAL(KIND=JWRB), DIMENSION(NFRE) :: LF + + REAL(KIND=JWRB) :: SDENSX_HF, SDENSY_HF, SDENSX_HF_UB, SDENSY_HF_UB + REAL(KIND=JWRB) :: TAUWX_LF, TAUWY_LF + REAL(KIND=JWRB) :: TAUWX_HF, TAUWY_HF + REAL(KIND=JWRB) :: ZA_EXP REAL(KIND=JWRB) :: TAU_TOT, TAU_VIS, TAU_WAV - REAL(KIND=JWRB) :: TAUVX, TAUVY, TAUX, TAUY + REAL(KIND=JWRB) :: TAUVX, TAUVY, TAUX, TAUY + REAL(KIND=JWRB) :: TAU_NND, TAU_INIT(2) - REAL(KIND=JWRB) :: UPROXY, RTAU, DRTAU, ERR + + REAL(KIND=JWRB) :: UPROXY, RTAU, DRTAU, ERR LOGICAL :: OVERSHOT - CHARACTER(LEN=23) :: IDTIME INTEGER(KIND=JWIM) :: IK, ITH, M, SIGN_NEW, SIGN_OLD INTEGER(KIND=JWIM) :: NK, NTH, NSPEC !num. of freqs, dirs, spec. bins @@ -132,78 +138,151 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, USDIR, ROAIRN, & ESIN2 (ITHN+(IK-1)*NTH) = SINTH END DO -!/ 1) --- Either extrapolate arrays up to 10Hz or use discrete spectral -! grid per se. Limit the constraint to the positive part of the -! wind input only. ---------------------------------------------- / - IF (NFRE .LT. NFRE_EXT) THEN - CINV_EXT(1:NK) = CINV - SDENS_EXT(1:NK) = SUM(S,1) * DELTH - SDENSX_EXT(1:NK) = SUM(MAX(0.0_JWRB,S)*RESHAPE(ECOS2,(/NTH,NK/)),1) * DELTH - SDENSY_EXT(1:NK) = SUM(MAX(0.0_JWRB,S)*RESHAPE(ESIN2,(/NTH,NK/)),1) * DELTH - ! --- Spectral slope for S_IN(F) is proportional to F**(-2) ------ / - CINV_EXT(NK+1:NFRE_EXT) = SIG_EXT(NK+1:NFRE_EXT)*GM1 ! 1/c=σ/g - SDENS_EXT(NK+1:NFRE_EXT) = SDENS_EXT(NK) * (SIG_EXT(NK)/SIG_EXT(NK+1:NFRE_EXT))**2 - SDENSX_EXT(NK+1:NFRE_EXT) = SDENSX_EXT(NK) * (SIG_EXT(NK)/SIG_EXT(NK+1:NFRE_EXT))**2 - SDENSY_EXT(NK+1:NFRE_EXT) = SDENSY_EXT(NK) * (SIG_EXT(NK)/SIG_EXT(NK+1:NFRE_EXT))**2 - ELSE - CINV_EXT = CINV - SDENS_EXT(1:NK) = SUM(S,1) * DELTH - SDENSX_EXT(1:NK) = SUM(MAX(0.0_JWRB,S)*RESHAPE(ECOS2,(/NTH,NK/)),1) * DELTH - SDENSY_EXT(1:NK) = SUM(MAX(0.0_JWRB,S)*RESHAPE(ESIN2,(/NTH,NK/)),1) * DELTH - END IF + SX = ABS(MIN(0.0_JWRB,S))*RESHAPE(ECOS2,(/NTH,NK/)) + SY = ABS(MIN(0.0_JWRB,S))*RESHAPE(ESIN2,(/NTH,NK/)) + +!/ ----------------------------------------------------------------- / +!/ ----------------------------------------------------------------- / +!/ Part I) --- low/high frequency contributions of TAU ------------- / + + !/ 0) --- split integral into low/high frequency contributions ------------- / + ! + ! + ! Th=2pi,f=inf Th=2pi,f=FR(NFRE) Th=2pi,f=inf + ! / / / / / / + ! | | S(f,Th)/c df dTh = | | S(f,Th)/c df dTh + | | S(f,Th)/c df dTh + ! / / / / / / + ! Th=0,f=0 Th=0,f=0 Th=0,f=FR(NFRE) + ! + ! + ! = LF_contribution + HF_contribution + ! + ! + !/ 1) --- low frequency contributions to the integral ---------------------- / + ! -- Direct summation over available freq. bins up to FR(NFRE) + + SDENSX_LF = SUM(SX,1) * DELTH + SDENSY_LF = SUM(SY,1) * DELTH + + TAUWX_LF = TAUWINDS(SDENSX_LF,CINV,DSII) ! x-component + TAUWY_LF = TAUWINDS(SDENSY_LF,CINV,DSII) ! y-component + + !/ 2) --- high frequency contributions to the integral --------------------- / + ! -- Assume spectral slope for S_IN(F) is proportional to F**(-2), then + ! integral collapses into easy analytic solution + ! + ! + ! Th=2pi,ω=ZPI*FRQMAX + ! / / + ! | | S(f,Th)/c df dTh = (LOG(ZPI*FRQMAX) - LOG(SIG(NFRE))) * SIG(NFRE)**2 * DELTH * SUM(S(:,NFRE)) * ZPI * GM1 + ! / / + ! Th=0,ω=SIG(NFRE) + ! + ! + ! Determine value of spectrum at NFRE (i.e. at highest frequency). + ! - Note, direction dimension must remain + + ZA_SX = SX(:,NFRE) + ZA_SY = SY(:,NFRE) + + SDENSX_HF = (LOG(ZPI*FRQMAX) - LOG(SIG(NFRE))) * SIG(NFRE)**2 * DELTH * SUM(ZA_SX) * ZPI * GM1 + SDENSY_HF = (LOG(ZPI*FRQMAX) - LOG(SIG(NFRE))) * SIG(NFRE)**2 * DELTH * SUM(ZA_SY) * ZPI * GM1 + + ! save these to be used later as upper bounds when LFACT applied (i.e. cap LFACT at 1) + SDENSX_HF_UB = SDENSX_HF + SDENSY_HF_UB = SDENSY_HF + + TAUWX_HF = G * ROWATER * ( SDENSX_HF ) + TAUWY_HF = G * ROWATER * ( SDENSY_HF ) + + !/ 3) --- summate low + high frequency contributions to the integral ------- / + + TAUWX = TAUWX_LF + TAUWX_HF + TAUWY = TAUWY_LF + TAUWY_HF + +!/ ----------------------------------------------------------------- / +!/ ----------------------------------------------------------------- / +!/ Part II) --- USTAR based TAU calculation ------------- / ! !/ 2) --- Stress calculation ----------------------------------------- / ! --- The total stress ------------------------------------------- / + TAU_TOT = USTAR**2 * ROAIRN -! + ! --- The viscous stress and check that it does not exceed ! the total stress. ------------------------------------------ / + TAU_VIS = MAX(0.0_JWRB, -5.0E-5_JWRB*U10 + 1.1E-3_JWRB) * U10**2 * ROAIRN ! TAU_VIS = MIN(0.9 * TAU_TOT, TAU_VIS) TAU_VIS = MIN(0.95_JWRB * TAU_TOT, TAU_VIS) -! + TAUVX = TAU_VIS * COS(USDIR) TAUVY = TAU_VIS * SIN(USDIR) + +! --- The wave supported stress (using elements calculated in Part I). -- / ! -! --- The wave supported stress. --------------------------------- / - TAUWX = TAUWINDS(SDENSX_EXT,CINV_EXT,DSII_EXT) ! normal stress (x-component) - TAUWY = TAUWINDS(SDENSY_EXT,CINV_EXT,DSII_EXT) ! normal stress (y-component) - TAU_NND = TAUWINDS(SDENS_EXT, CINV_EXT,DSII_EXT) ! normal stress (non-directional) TAU_WAV = SQRT(TAUWX**2 + TAUWY**2) ! normal stress (magnitude) TAU_INIT = (/TAUWX,TAUWY/) ! unadjusted normal stress components -! + TAUX = TAUVX + TAUWX ! total stress (x-component) TAUY = TAUVY + TAUWY ! total stress (y-component) TAU = SQRT(TAUX**2 + TAUY**2) ! total stress (magnitude) ERR = (TAU-TAU_TOT)/TAU_TOT ! initial error -! + !/ 3) --- Find reduced Sin(f) = L(f)*Sin(f) to satisfy our constraint !/ TAU <= TAU_TOT --------------------------------------------- / - !CALL STME21 ( TIME , IDTIME ) - LF_EXT = 1.0_JWRB + + LF = 1.0_JWRB IK = 0 -! IF (TAU .GT. TAU_TOT) THEN - OVERSHOT = .FALSE. RTAU = ERR / 90.0_JWRB DRTAU = 2.0_JWRB - - SIGN_NEW = INT(SIGN(1.0_JWRB,ERR)) + SIGN_NEW = INT(SIGN(1.0_JWRB,ERR)) UPROXY = FRIC * CDFAC * USTAR - UCINV_EXT = 1.0_JWRB - (UPROXY * CINV_EXT) - + UCINV = 1.0_JWRB - (UPROXY * CINV) DO IK=1,ITERMAX - - LF_EXT = MIN(1.0_JWRB, EXP(UCINV_EXT * RTAU) ) - TAU_NND = TAUWINDS(SDENS_EXT *LF_EXT,CINV_EXT,DSII_EXT) - TAUWX = TAUWINDS(SDENSX_EXT*LF_EXT,CINV_EXT,DSII_EXT) - TAUWY = TAUWINDS(SDENSY_EXT*LF_EXT,CINV_EXT,DSII_EXT) + + ! LFAC capped at 1 (i.e. always a reduction of Sin) + LF = MIN(1.0_JWRB, EXP(UCINV * RTAU) ) + + !/ 1) --- low frequency contributions as above ---------------------- / + TAUWX_LF = TAUWINDS(SDENSX_LF * LF,CINV,DSII) ! x-component + TAUWY_LF = TAUWINDS(SDENSY_LF * LF,CINV,DSII) ! y-component + + !/ 2) --- high frequency contributions as above, but modification to include LFAC ------ / + ! + ! + ! Th=2pi,ω=ZPI*FRQMAX + ! / / + ! | | LFAC*S(f,Th)/c df dTh = (-EXP(RTAU)*EI(ZA_EXP*SIG(NFRE))) * SIG(NFRE)**2 * DELTH * SUM(S(:,NFRE)) * ZPI * GM1 + ! / / + ! Th=0,ω=SIG(NFRE) + ! + ! where, LFAC = EXP(RTAU*( 1 - (U * 1/c))) + ! ZA_EXP = -ZPI*RTAU*U/GRAV + ! + ! then , use EI for exponential integral solution + ! + + ZA_EXP = -ZPI*RTAU*UPROXY*GM1 + + SDENSX_HF = (-EXP(RTAU)*EI(ZA_EXP*SIG(NFRE))) * SIG(NFRE)**2 * DELTH * SUM(ZA_SX) * ZPI * GM1 + SDENSY_HF = (-EXP(RTAU)*EI(ZA_EXP*SIG(NFRE))) * SIG(NFRE)**2 * DELTH * SUM(ZA_SY) * ZPI * GM1 + SDENSX_HF = MIN(SDENSX_HF, SDENSX_HF_UB) ! cap at unmodified HF contribution (LFAC capped at 1) + SDENSY_HF = MIN(SDENSY_HF, SDENSY_HF_UB) ! cap at unmodified HF contribution (LFAC capped at 1) + TAUWX_HF = G * ROWATER * ( SDENSX_HF ) + TAUWY_HF = G * ROWATER * ( SDENSY_HF ) + + TAUWX = TAUWX_LF + TAUWX_HF + TAUWY = TAUWY_LF + TAUWY_HF TAU_WAV = SQRT(TAUWX**2 + TAUWY**2) + TAUX = TAUVX + TAUWX TAUY = TAUVY + TAUWY TAU = SQRT(TAUX**2 + TAUY**2) + ERR = (TAU-TAU_TOT) / TAU_TOT SIGN_OLD = SIGN_NEW SIGN_NEW = INT(SIGN(1.0_JWRB, ERR)) @@ -216,12 +295,12 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, USDIR, ROAIRN, & RTAU = RTAU * (DRTAU**SIGN_NEW) IF (ABS(ERR) .LT. 1.54E-4_JWRB) EXIT - + END DO END IF - LFACT(1:NK) = LF_EXT(1:NK) + LFACT = LF IF (LHOOK) CALL DR_HOOK('LFACTOR',1,ZHOOK_HANDLE) diff --git a/src/ecwam/lfactor.old.F90 b/src/ecwam/lfactor.old.F90 new file mode 100644 index 000000000..4e96ccaac --- /dev/null +++ b/src/ecwam/lfactor.old.F90 @@ -0,0 +1,225 @@ +! (C) Copyright 1989- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. + + SUBROUTINE LFACTORXX(S, CINV, U10, USTAR, USDIR, ROAIRN, & + & LFACT, TAUWX, TAUWY, TAU) + +! ---------------------------------------------------------------------------- +! +! 1. Purpose : +! +! Numerical approximation for the reduction factor LFACTOR(f) to +! reduce energy in the high-frequency part of the resolved part +! of the spectrum to meet the constraint on total stress (TAU). +! The constraint is TAU <= TAU_TOT (TAU_TOT = TAU_WAV + TAU_VIS), +! thus the wind input is reduced to match our constraint. +! +! 2. Method : +! +! 1) If required, extend resolved part of the spectrum to 10Hz using +! an approximation for the spectral slope at the high frequency +! limit: Sin(F) prop. F**(-2) and for E(F) prop. F**(-5). +! 2) Calculate stresses: +! total stress: TAU_TOT = DAIR * USTAR**2 +! viscous stress: TAU_VIS = DAIR * Cv * U10**2 +! viscous stress (x,y-components): +! TAUV_X = TAU_VIS * COS(USDIR) +! TAUV_Y = TAU_VIS * SIN(USDIR) +! wave supported stress (x,y-components): /10Hz +! TAUW_X,Y = GRAV * DWAT * | [SinX,Y(F)]/C(F) dF +! / +! total stress (input): TAU = SQRT( (TAUW_X + TAUV_X)**2 +! + (TAUW_Y + TAUV_Y)**2 ) +! 3) If TAU does not meet our constraint reduce the wind input +! using reduction factor: +! LFACT(F) = MIN(1,exp((1-U/C(F))*RTAU)) +! Then alter RTAU and repeat 3) until our constraint is matched. +! +! ---------------------------------------------------------------------------- +! +!** INTERFACE. +! ---------- + +! *CALL* *LFACTOR(S, CINV, U10, USTAR, USDIR, ROAIRN, SIG, DSII, & +! & LFACT, TAUWX, TAUWY, TAU) +! *S* - NEG. WIND INPUT ENERGY DENSITY SPECTRUM. +! *CINV* - INVERSE PHASE SPEED CALC. IN INPUT ROUTINE +! *UABS* - 10M WIND SPEED +! *USTAR* - NEW FRICTION VELOCITY IN M/S. +! *USDIR* - WIND DIRECTION +! *ROAIRN* - AIR DENSITY IN KG/M3 +! *LFACT* - CORRECTION FACTOR +! *TAUNWX, TAUNWY* - NEGATIVE WAVE NORMAL STRESS COMPONENTS + +! EXTERNALS. +! ---------- +! TAUWINDS +! IRANGE + +! ORIGIN. +! ---------- +! Adapted from Babanin Young Donelan & Banner (ZBRY) physics +! as implemented as ST6 in WAVEWATCH-III +! WW3 module: W3SRC6MD +! WW3 subroutine: LFACTOR +! Implementation into ECWAM DECEMBER 2021 by J. Kousal + +! ---------------------------------------------------------------------- + USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU + + USE YOWFRED , ONLY : FR ,TH ,DFIM ,COSTH ,SINTH,& +& FRATIO ,DELTH ,FRIC, SIG,DSII ,SIGM1,& +& DF ,NFRE_EXT ,DSII_EXT ,SIG_EXT + USE YOWPARAM , ONLY : NANG ,NFRE + USE YOWPCONS , ONLY : G ,ZPI ,ROWATER ,EPSMIN, GM1 + USE YOWPHYS , ONLY : CDFAC + USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK + +! ---------------------------------------------------------------------- + + IMPLICIT NONE +#include "irange.intfb.h" +#include "tauwinds.intfb.h" + + REAL(KIND=JWRB), DIMENSION(NANG,NFRE), INTENT(IN) :: S ! Sin(sigma) in [m2/rad-Hz] + REAL(KIND=JWRB), DIMENSION(NFRE), INTENT(IN) :: CINV + REAL(KIND=JWRB), INTENT(IN) :: U10, USTAR, USDIR, ROAIRN + + REAL(KIND=JWRB), DIMENSION(NFRE), INTENT(OUT) :: LFACT + REAL(KIND=JWRB), INTENT(OUT) :: TAUWX, TAUWY, TAU + + INTEGER(KIND=JWIM), PARAMETER :: ITERMAX = 80 ! Max. no. iterations + ! to find numerical LFACT soln + + REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: ECOS2, ESIN2 + REAL(KIND=JWRB), DIMENSION(NFRE_EXT) :: LF_EXT, CINV_EXT + REAL(KIND=JWRB), DIMENSION(NFRE_EXT) :: SDENS_EXT, SDENSX_EXT, SDENSY_EXT + REAL(KIND=JWRB), DIMENSION(NFRE_EXT) :: UCINV_EXT + + REAL(KIND=JWRB) :: TAU_TOT, TAU_VIS, TAU_WAV + REAL(KIND=JWRB) :: TAUVX, TAUVY, TAUX, TAUY + REAL(KIND=JWRB) :: TAU_NND, TAU_INIT(2) + REAL(KIND=JWRB) :: UPROXY, RTAU, DRTAU, ERR + LOGICAL :: OVERSHOT + CHARACTER(LEN=23) :: IDTIME + + INTEGER(KIND=JWIM) :: IK, ITH, M, SIGN_NEW, SIGN_OLD + INTEGER(KIND=JWIM) :: NK, NTH, NSPEC !num. of freqs, dirs, spec. bins + INTEGER(KIND=JWIM), DIMENSION(NANG) :: ITHN + INTEGER(KIND=JWIM), DIMENSION(NFRE) :: IKN + + REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ---------------------------------------------------------------------- + + IF (LHOOK) CALL DR_HOOK('LFACTOR',0,ZHOOK_HANDLE) + + NTH = NANG ! NUMBER OF DIRS , SAME AS KL + NK = NFRE ! NUMBER OF FREQS, SAME AS ML + NSPEC = NK * NTH ! NUMBER OF SPECTRAL BINS + + ITHN = IRANGE(1,NTH,1) ! Index vector 1:NTH + DO IK = 1, NK + ECOS2 (ITHN+(IK-1)*NTH) = COSTH + ESIN2 (ITHN+(IK-1)*NTH) = SINTH + END DO + +!/ 1) --- Either extrapolate arrays up to 10Hz or use discrete spectral +! grid per se. Limit the constraint to the positive part of the +! wind input only. ---------------------------------------------- / + IF (NFRE .LT. NFRE_EXT) THEN + CINV_EXT(1:NK) = CINV + SDENS_EXT(1:NK) = SUM(S,1) * DELTH + SDENSX_EXT(1:NK) = SUM(MAX(0.0_JWRB,S)*RESHAPE(ECOS2,(/NTH,NK/)),1) * DELTH + SDENSY_EXT(1:NK) = SUM(MAX(0.0_JWRB,S)*RESHAPE(ESIN2,(/NTH,NK/)),1) * DELTH + ! --- Spectral slope for S_IN(F) is proportional to F**(-2) ------ / + CINV_EXT(NK+1:NFRE_EXT) = SIG_EXT(NK+1:NFRE_EXT)*GM1 ! 1/c=σ/g + SDENS_EXT(NK+1:NFRE_EXT) = SDENS_EXT(NK) * (SIG_EXT(NK)/SIG_EXT(NK+1:NFRE_EXT))**2 + SDENSX_EXT(NK+1:NFRE_EXT) = SDENSX_EXT(NK) * (SIG_EXT(NK)/SIG_EXT(NK+1:NFRE_EXT))**2 + SDENSY_EXT(NK+1:NFRE_EXT) = SDENSY_EXT(NK) * (SIG_EXT(NK)/SIG_EXT(NK+1:NFRE_EXT))**2 + ELSE + CINV_EXT = CINV + SDENS_EXT(1:NK) = SUM(S,1) * DELTH + SDENSX_EXT(1:NK) = SUM(MAX(0.0_JWRB,S)*RESHAPE(ECOS2,(/NTH,NK/)),1) * DELTH + SDENSY_EXT(1:NK) = SUM(MAX(0.0_JWRB,S)*RESHAPE(ESIN2,(/NTH,NK/)),1) * DELTH + END IF +! +!/ 2) --- Stress calculation ----------------------------------------- / +! --- The total stress ------------------------------------------- / + TAU_TOT = USTAR**2 * ROAIRN +! +! --- The viscous stress and check that it does not exceed +! the total stress. ------------------------------------------ / + TAU_VIS = MAX(0.0_JWRB, -5.0E-5_JWRB*U10 + 1.1E-3_JWRB) * U10**2 * ROAIRN +! TAU_VIS = MIN(0.9 * TAU_TOT, TAU_VIS) + TAU_VIS = MIN(0.95_JWRB * TAU_TOT, TAU_VIS) +! + TAUVX = TAU_VIS * COS(USDIR) + TAUVY = TAU_VIS * SIN(USDIR) +! +! --- The wave supported stress. --------------------------------- / + TAUWX = TAUWINDS(SDENSX_EXT,CINV_EXT,DSII_EXT) ! normal stress (x-component) + TAUWY = TAUWINDS(SDENSY_EXT,CINV_EXT,DSII_EXT) ! normal stress (y-component) + TAU_NND = TAUWINDS(SDENS_EXT, CINV_EXT,DSII_EXT) ! normal stress (non-directional) + TAU_WAV = SQRT(TAUWX**2 + TAUWY**2) ! normal stress (magnitude) + TAU_INIT = (/TAUWX,TAUWY/) ! unadjusted normal stress components +! + TAUX = TAUVX + TAUWX ! total stress (x-component) + TAUY = TAUVY + TAUWY ! total stress (y-component) + TAU = SQRT(TAUX**2 + TAUY**2) ! total stress (magnitude) + ERR = (TAU-TAU_TOT)/TAU_TOT ! initial error +! +!/ 3) --- Find reduced Sin(f) = L(f)*Sin(f) to satisfy our constraint +!/ TAU <= TAU_TOT --------------------------------------------- / + !CALL STME21 ( TIME , IDTIME ) + LF_EXT = 1.0_JWRB + IK = 0 +! + IF (TAU .GT. TAU_TOT) THEN + + OVERSHOT = .FALSE. + RTAU = ERR / 90.0_JWRB + DRTAU = 2.0_JWRB + + SIGN_NEW = INT(SIGN(1.0_JWRB,ERR)) + + UPROXY = FRIC * CDFAC * USTAR + UCINV_EXT = 1.0_JWRB - (UPROXY * CINV_EXT) + + DO IK=1,ITERMAX + + LF_EXT = MIN(1.0_JWRB, EXP(UCINV_EXT * RTAU) ) + TAU_NND = TAUWINDS(SDENS_EXT *LF_EXT,CINV_EXT,DSII_EXT) + TAUWX = TAUWINDS(SDENSX_EXT*LF_EXT,CINV_EXT,DSII_EXT) + TAUWY = TAUWINDS(SDENSY_EXT*LF_EXT,CINV_EXT,DSII_EXT) + TAU_WAV = SQRT(TAUWX**2 + TAUWY**2) + TAUX = TAUVX + TAUWX + TAUY = TAUVY + TAUWY + TAU = SQRT(TAUX**2 + TAUY**2) + ERR = (TAU-TAU_TOT) / TAU_TOT + SIGN_OLD = SIGN_NEW + SIGN_NEW = INT(SIGN(1.0_JWRB, ERR)) + +! --- Slow down DRTAU when overshot. -------------------------- / + + IF (SIGN_NEW .NE. SIGN_OLD) OVERSHOT = .TRUE. + IF (OVERSHOT) DRTAU = MAX(0.5_JWRB*(1.0_JWRB+DRTAU),1.00010_JWRB) + + RTAU = RTAU * (DRTAU**SIGN_NEW) + + IF (ABS(ERR) .LT. 1.54E-4_JWRB) EXIT + + END DO + + END IF + + LFACT(1:NK) = LF_EXT(1:NK) + + IF (LHOOK) CALL DR_HOOK('LFACTOR',1,ZHOOK_HANDLE) + + END SUBROUTINE LFACTORXX diff --git a/src/ecwam/swldissip_zbry.F90 b/src/ecwam/swldissip_zbry.F90 index b363fd3c9..47760bdc9 100644 --- a/src/ecwam/swldissip_zbry.F90 +++ b/src/ecwam/swldissip_zbry.F90 @@ -66,7 +66,7 @@ SUBROUTINE SWLDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & ! ---------------------------------------------------------------------- USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU - USE YOWFRED , ONLY : FR , TH ,ZPIFR ,FRATIO ,DELTH, DFIM, + USE YOWFRED , ONLY : FR , TH ,ZPIFR ,FRATIO ,DELTH, DFIM,& & SIG , DDEN USE YOWPCONS , ONLY : G ,ZPI USE YOWPARAM , ONLY : NANG ,NFRE From c57969fc4bdf12d1f258470af009e5439cdf3f70 Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Fri, 24 Oct 2025 15:36:34 +0000 Subject: [PATCH 56/89] keep two versions of lfactor --- src/ecwam/lfactor.F90 | 180 +++------- src/ecwam/lfactor.ei.F90 | 307 ++++++++++++++++++ .../{lfactor.old.F90 => lfactor.ext.F90} | 0 3 files changed, 356 insertions(+), 131 deletions(-) create mode 100644 src/ecwam/lfactor.ei.F90 rename src/ecwam/{lfactor.old.F90 => lfactor.ext.F90} (100%) diff --git a/src/ecwam/lfactor.F90 b/src/ecwam/lfactor.F90 index c37e54d3e..8034499df 100644 --- a/src/ecwam/lfactor.F90 +++ b/src/ecwam/lfactor.F90 @@ -77,7 +77,7 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, USDIR, ROAIRN, & & DF ,NFRE_EXT ,DSII_EXT ,SIG_EXT USE YOWPARAM , ONLY : NANG ,NFRE USE YOWPCONS , ONLY : G ,ZPI ,ROWATER ,EPSMIN, GM1 - USE YOWPHYS , ONLY : CDFAC ,FRQMAX + USE YOWPHYS , ONLY : CDFAC USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK ! ---------------------------------------------------------------------- @@ -85,7 +85,6 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, USDIR, ROAIRN, & IMPLICIT NONE #include "irange.intfb.h" #include "tauwinds.intfb.h" -#include "ei.intfb.h" REAL(KIND=JWRB), DIMENSION(NANG,NFRE), INTENT(IN) :: S ! Sin(sigma) in [m2/rad-Hz] REAL(KIND=JWRB), DIMENSION(NFRE), INTENT(IN) :: CINV @@ -98,24 +97,16 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, USDIR, ROAIRN, & ! to find numerical LFACT soln REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: ECOS2, ESIN2 - REAL(KIND=JWRB), DIMENSION(NANG,NFRE) :: SX, SY - REAL(KIND=JWRB), DIMENSION(NFRE) :: SDENSX_LF, SDENSY_LF - REAL(KIND=JWRB), DIMENSION(NFRE) :: ZA_SX, ZA_SY - REAL(KIND=JWRB), DIMENSION(NFRE) :: UCINV - REAL(KIND=JWRB), DIMENSION(NFRE) :: LF - - REAL(KIND=JWRB) :: SDENSX_HF, SDENSY_HF, SDENSX_HF_UB, SDENSY_HF_UB - REAL(KIND=JWRB) :: TAUWX_LF, TAUWY_LF - REAL(KIND=JWRB) :: TAUWX_HF, TAUWY_HF - REAL(KIND=JWRB) :: ZA_EXP + REAL(KIND=JWRB), DIMENSION(NFRE_EXT) :: LF_EXT, CINV_EXT + REAL(KIND=JWRB), DIMENSION(NFRE_EXT) :: SDENS_EXT, SDENSX_EXT, SDENSY_EXT + REAL(KIND=JWRB), DIMENSION(NFRE_EXT) :: UCINV_EXT REAL(KIND=JWRB) :: TAU_TOT, TAU_VIS, TAU_WAV - REAL(KIND=JWRB) :: TAUVX, TAUVY, TAUX, TAUY - + REAL(KIND=JWRB) :: TAUVX, TAUVY, TAUX, TAUY REAL(KIND=JWRB) :: TAU_NND, TAU_INIT(2) - - REAL(KIND=JWRB) :: UPROXY, RTAU, DRTAU, ERR + REAL(KIND=JWRB) :: UPROXY, RTAU, DRTAU, ERR LOGICAL :: OVERSHOT + CHARACTER(LEN=23) :: IDTIME INTEGER(KIND=JWIM) :: IK, ITH, M, SIGN_NEW, SIGN_OLD INTEGER(KIND=JWIM) :: NK, NTH, NSPEC !num. of freqs, dirs, spec. bins @@ -138,151 +129,78 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, USDIR, ROAIRN, & ESIN2 (ITHN+(IK-1)*NTH) = SINTH END DO - SX = ABS(MIN(0.0_JWRB,S))*RESHAPE(ECOS2,(/NTH,NK/)) - SY = ABS(MIN(0.0_JWRB,S))*RESHAPE(ESIN2,(/NTH,NK/)) - -!/ ----------------------------------------------------------------- / -!/ ----------------------------------------------------------------- / -!/ Part I) --- low/high frequency contributions of TAU ------------- / - - !/ 0) --- split integral into low/high frequency contributions ------------- / - ! - ! - ! Th=2pi,f=inf Th=2pi,f=FR(NFRE) Th=2pi,f=inf - ! / / / / / / - ! | | S(f,Th)/c df dTh = | | S(f,Th)/c df dTh + | | S(f,Th)/c df dTh - ! / / / / / / - ! Th=0,f=0 Th=0,f=0 Th=0,f=FR(NFRE) - ! - ! - ! = LF_contribution + HF_contribution - ! - ! - !/ 1) --- low frequency contributions to the integral ---------------------- / - ! -- Direct summation over available freq. bins up to FR(NFRE) - - SDENSX_LF = SUM(SX,1) * DELTH - SDENSY_LF = SUM(SY,1) * DELTH - - TAUWX_LF = TAUWINDS(SDENSX_LF,CINV,DSII) ! x-component - TAUWY_LF = TAUWINDS(SDENSY_LF,CINV,DSII) ! y-component - - !/ 2) --- high frequency contributions to the integral --------------------- / - ! -- Assume spectral slope for S_IN(F) is proportional to F**(-2), then - ! integral collapses into easy analytic solution - ! - ! - ! Th=2pi,ω=ZPI*FRQMAX - ! / / - ! | | S(f,Th)/c df dTh = (LOG(ZPI*FRQMAX) - LOG(SIG(NFRE))) * SIG(NFRE)**2 * DELTH * SUM(S(:,NFRE)) * ZPI * GM1 - ! / / - ! Th=0,ω=SIG(NFRE) - ! - ! - ! Determine value of spectrum at NFRE (i.e. at highest frequency). - ! - Note, direction dimension must remain - - ZA_SX = SX(:,NFRE) - ZA_SY = SY(:,NFRE) - - SDENSX_HF = (LOG(ZPI*FRQMAX) - LOG(SIG(NFRE))) * SIG(NFRE)**2 * DELTH * SUM(ZA_SX) * ZPI * GM1 - SDENSY_HF = (LOG(ZPI*FRQMAX) - LOG(SIG(NFRE))) * SIG(NFRE)**2 * DELTH * SUM(ZA_SY) * ZPI * GM1 - - ! save these to be used later as upper bounds when LFACT applied (i.e. cap LFACT at 1) - SDENSX_HF_UB = SDENSX_HF - SDENSY_HF_UB = SDENSY_HF - - TAUWX_HF = G * ROWATER * ( SDENSX_HF ) - TAUWY_HF = G * ROWATER * ( SDENSY_HF ) - - !/ 3) --- summate low + high frequency contributions to the integral ------- / - - TAUWX = TAUWX_LF + TAUWX_HF - TAUWY = TAUWY_LF + TAUWY_HF - -!/ ----------------------------------------------------------------- / -!/ ----------------------------------------------------------------- / -!/ Part II) --- USTAR based TAU calculation ------------- / +!/ 1) --- Either extrapolate arrays up to 10Hz or use discrete spectral +! grid per se. Limit the constraint to the positive part of the +! wind input only. ---------------------------------------------- / + IF (NFRE .LT. NFRE_EXT) THEN + CINV_EXT(1:NK) = CINV + SDENS_EXT(1:NK) = SUM(S,1) * DELTH + SDENSX_EXT(1:NK) = SUM(MAX(0.0_JWRB,S)*RESHAPE(ECOS2,(/NTH,NK/)),1) * DELTH + SDENSY_EXT(1:NK) = SUM(MAX(0.0_JWRB,S)*RESHAPE(ESIN2,(/NTH,NK/)),1) * DELTH + ! --- Spectral slope for S_IN(F) is proportional to F**(-2) ------ / + CINV_EXT(NK+1:NFRE_EXT) = SIG_EXT(NK+1:NFRE_EXT)*GM1 ! 1/c=σ/g + SDENS_EXT(NK+1:NFRE_EXT) = SDENS_EXT(NK) * (SIG_EXT(NK)/SIG_EXT(NK+1:NFRE_EXT))**2 + SDENSX_EXT(NK+1:NFRE_EXT) = SDENSX_EXT(NK) * (SIG_EXT(NK)/SIG_EXT(NK+1:NFRE_EXT))**2 + SDENSY_EXT(NK+1:NFRE_EXT) = SDENSY_EXT(NK) * (SIG_EXT(NK)/SIG_EXT(NK+1:NFRE_EXT))**2 + ELSE + CINV_EXT = CINV + SDENS_EXT(1:NK) = SUM(S,1) * DELTH + SDENSX_EXT(1:NK) = SUM(MAX(0.0_JWRB,S)*RESHAPE(ECOS2,(/NTH,NK/)),1) * DELTH + SDENSY_EXT(1:NK) = SUM(MAX(0.0_JWRB,S)*RESHAPE(ESIN2,(/NTH,NK/)),1) * DELTH + END IF ! !/ 2) --- Stress calculation ----------------------------------------- / ! --- The total stress ------------------------------------------- / - TAU_TOT = USTAR**2 * ROAIRN - +! ! --- The viscous stress and check that it does not exceed ! the total stress. ------------------------------------------ / - TAU_VIS = MAX(0.0_JWRB, -5.0E-5_JWRB*U10 + 1.1E-3_JWRB) * U10**2 * ROAIRN ! TAU_VIS = MIN(0.9 * TAU_TOT, TAU_VIS) TAU_VIS = MIN(0.95_JWRB * TAU_TOT, TAU_VIS) - +! TAUVX = TAU_VIS * COS(USDIR) TAUVY = TAU_VIS * SIN(USDIR) - -! --- The wave supported stress (using elements calculated in Part I). -- / ! +! --- The wave supported stress. --------------------------------- / + TAUWX = TAUWINDS(SDENSX_EXT,CINV_EXT,DSII_EXT) ! normal stress (x-component) + TAUWY = TAUWINDS(SDENSY_EXT,CINV_EXT,DSII_EXT) ! normal stress (y-component) + TAU_NND = TAUWINDS(SDENS_EXT, CINV_EXT,DSII_EXT) ! normal stress (non-directional) TAU_WAV = SQRT(TAUWX**2 + TAUWY**2) ! normal stress (magnitude) TAU_INIT = (/TAUWX,TAUWY/) ! unadjusted normal stress components - +! TAUX = TAUVX + TAUWX ! total stress (x-component) TAUY = TAUVY + TAUWY ! total stress (y-component) TAU = SQRT(TAUX**2 + TAUY**2) ! total stress (magnitude) ERR = (TAU-TAU_TOT)/TAU_TOT ! initial error - +! !/ 3) --- Find reduced Sin(f) = L(f)*Sin(f) to satisfy our constraint !/ TAU <= TAU_TOT --------------------------------------------- / - - LF = 1.0_JWRB + !CALL STME21 ( TIME , IDTIME ) + LF_EXT = 1.0_JWRB IK = 0 +! IF (TAU .GT. TAU_TOT) THEN + OVERSHOT = .FALSE. RTAU = ERR / 90.0_JWRB DRTAU = 2.0_JWRB - SIGN_NEW = INT(SIGN(1.0_JWRB,ERR)) + + SIGN_NEW = INT(SIGN(1.0_JWRB,ERR)) UPROXY = FRIC * CDFAC * USTAR - UCINV = 1.0_JWRB - (UPROXY * CINV) + UCINV_EXT = 1.0_JWRB - (UPROXY * CINV_EXT) + DO IK=1,ITERMAX - - ! LFAC capped at 1 (i.e. always a reduction of Sin) - LF = MIN(1.0_JWRB, EXP(UCINV * RTAU) ) - - !/ 1) --- low frequency contributions as above ---------------------- / - TAUWX_LF = TAUWINDS(SDENSX_LF * LF,CINV,DSII) ! x-component - TAUWY_LF = TAUWINDS(SDENSY_LF * LF,CINV,DSII) ! y-component - - !/ 2) --- high frequency contributions as above, but modification to include LFAC ------ / - ! - ! - ! Th=2pi,ω=ZPI*FRQMAX - ! / / - ! | | LFAC*S(f,Th)/c df dTh = (-EXP(RTAU)*EI(ZA_EXP*SIG(NFRE))) * SIG(NFRE)**2 * DELTH * SUM(S(:,NFRE)) * ZPI * GM1 - ! / / - ! Th=0,ω=SIG(NFRE) - ! - ! where, LFAC = EXP(RTAU*( 1 - (U * 1/c))) - ! ZA_EXP = -ZPI*RTAU*U/GRAV - ! - ! then , use EI for exponential integral solution - ! - - ZA_EXP = -ZPI*RTAU*UPROXY*GM1 - - SDENSX_HF = (-EXP(RTAU)*EI(ZA_EXP*SIG(NFRE))) * SIG(NFRE)**2 * DELTH * SUM(ZA_SX) * ZPI * GM1 - SDENSY_HF = (-EXP(RTAU)*EI(ZA_EXP*SIG(NFRE))) * SIG(NFRE)**2 * DELTH * SUM(ZA_SY) * ZPI * GM1 - SDENSX_HF = MIN(SDENSX_HF, SDENSX_HF_UB) ! cap at unmodified HF contribution (LFAC capped at 1) - SDENSY_HF = MIN(SDENSY_HF, SDENSY_HF_UB) ! cap at unmodified HF contribution (LFAC capped at 1) - TAUWX_HF = G * ROWATER * ( SDENSX_HF ) - TAUWY_HF = G * ROWATER * ( SDENSY_HF ) - - TAUWX = TAUWX_LF + TAUWX_HF - TAUWY = TAUWY_LF + TAUWY_HF - TAU_WAV = SQRT(TAUWX**2 + TAUWY**2) + LF_EXT = MIN(1.0_JWRB, EXP(UCINV_EXT * RTAU) ) + TAU_NND = TAUWINDS(SDENS_EXT *LF_EXT,CINV_EXT,DSII_EXT) + TAUWX = TAUWINDS(SDENSX_EXT*LF_EXT,CINV_EXT,DSII_EXT) + TAUWY = TAUWINDS(SDENSY_EXT*LF_EXT,CINV_EXT,DSII_EXT) + TAU_WAV = SQRT(TAUWX**2 + TAUWY**2) TAUX = TAUVX + TAUWX TAUY = TAUVY + TAUWY TAU = SQRT(TAUX**2 + TAUY**2) - ERR = (TAU-TAU_TOT) / TAU_TOT SIGN_OLD = SIGN_NEW SIGN_NEW = INT(SIGN(1.0_JWRB, ERR)) @@ -295,12 +213,12 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, USDIR, ROAIRN, & RTAU = RTAU * (DRTAU**SIGN_NEW) IF (ABS(ERR) .LT. 1.54E-4_JWRB) EXIT - + END DO END IF - LFACT = LF + LFACT(1:NK) = LF_EXT(1:NK) IF (LHOOK) CALL DR_HOOK('LFACTOR',1,ZHOOK_HANDLE) diff --git a/src/ecwam/lfactor.ei.F90 b/src/ecwam/lfactor.ei.F90 new file mode 100644 index 000000000..f38993970 --- /dev/null +++ b/src/ecwam/lfactor.ei.F90 @@ -0,0 +1,307 @@ +! (C) Copyright 1989- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. + + SUBROUTINE LFACTORXY(S, CINV, U10, USTAR, USDIR, ROAIRN, & + & LFACT, TAUWX, TAUWY, TAU) + +! ---------------------------------------------------------------------------- +! +! 1. Purpose : +! +! Numerical approximation for the reduction factor LFACTOR(f) to +! reduce energy in the high-frequency part of the resolved part +! of the spectrum to meet the constraint on total stress (TAU). +! The constraint is TAU <= TAU_TOT (TAU_TOT = TAU_WAV + TAU_VIS), +! thus the wind input is reduced to match our constraint. +! +! 2. Method : +! +! 1) If required, extend resolved part of the spectrum to 10Hz using +! an approximation for the spectral slope at the high frequency +! limit: Sin(F) prop. F**(-2) and for E(F) prop. F**(-5). +! 2) Calculate stresses: +! total stress: TAU_TOT = DAIR * USTAR**2 +! viscous stress: TAU_VIS = DAIR * Cv * U10**2 +! viscous stress (x,y-components): +! TAUV_X = TAU_VIS * COS(USDIR) +! TAUV_Y = TAU_VIS * SIN(USDIR) +! wave supported stress (x,y-components): /10Hz +! TAUW_X,Y = GRAV * DWAT * | [SinX,Y(F)]/C(F) dF +! / +! total stress (input): TAU = SQRT( (TAUW_X + TAUV_X)**2 +! + (TAUW_Y + TAUV_Y)**2 ) +! 3) If TAU does not meet our constraint reduce the wind input +! using reduction factor: +! LFACT(F) = MIN(1,exp((1-U/C(F))*RTAU)) +! Then alter RTAU and repeat 3) until our constraint is matched. +! +! ---------------------------------------------------------------------------- +! +!** INTERFACE. +! ---------- + +! *CALL* *LFACTOR(S, CINV, U10, USTAR, USDIR, ROAIRN, SIG, DSII, & +! & LFACT, TAUWX, TAUWY, TAU) +! *S* - NEG. WIND INPUT ENERGY DENSITY SPECTRUM. +! *CINV* - INVERSE PHASE SPEED CALC. IN INPUT ROUTINE +! *UABS* - 10M WIND SPEED +! *USTAR* - NEW FRICTION VELOCITY IN M/S. +! *USDIR* - WIND DIRECTION +! *ROAIRN* - AIR DENSITY IN KG/M3 +! *LFACT* - CORRECTION FACTOR +! *TAUNWX, TAUNWY* - NEGATIVE WAVE NORMAL STRESS COMPONENTS + +! EXTERNALS. +! ---------- +! TAUWINDS +! IRANGE + +! ORIGIN. +! ---------- +! Adapted from Babanin Young Donelan & Banner (ZBRY) physics +! as implemented as ST6 in WAVEWATCH-III +! WW3 module: W3SRC6MD +! WW3 subroutine: LFACTOR +! Implementation into ECWAM DECEMBER 2021 by J. Kousal + +! ---------------------------------------------------------------------- + USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU + + USE YOWFRED , ONLY : FR ,TH ,DFIM ,COSTH ,SINTH,& +& FRATIO ,DELTH ,FRIC, SIG,DSII ,SIGM1,& +& DF ,NFRE_EXT ,DSII_EXT ,SIG_EXT + USE YOWPARAM , ONLY : NANG ,NFRE + USE YOWPCONS , ONLY : G ,ZPI ,ROWATER ,EPSMIN, GM1 + USE YOWPHYS , ONLY : CDFAC ,FRQMAX + USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK + +! ---------------------------------------------------------------------- + + IMPLICIT NONE +#include "irange.intfb.h" +#include "tauwinds.intfb.h" +#include "ei.intfb.h" + + REAL(KIND=JWRB), DIMENSION(NANG,NFRE), INTENT(IN) :: S ! Sin(sigma) in [m2/rad-Hz] + REAL(KIND=JWRB), DIMENSION(NFRE), INTENT(IN) :: CINV + REAL(KIND=JWRB), INTENT(IN) :: U10, USTAR, USDIR, ROAIRN + + REAL(KIND=JWRB), DIMENSION(NFRE), INTENT(OUT) :: LFACT + REAL(KIND=JWRB), INTENT(OUT) :: TAUWX, TAUWY, TAU + + INTEGER(KIND=JWIM), PARAMETER :: ITERMAX = 80 ! Max. no. iterations + ! to find numerical LFACT soln + + REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: ECOS2, ESIN2 + REAL(KIND=JWRB), DIMENSION(NANG,NFRE) :: SX, SY + REAL(KIND=JWRB), DIMENSION(NFRE) :: SDENSX_LF, SDENSY_LF + REAL(KIND=JWRB), DIMENSION(NFRE) :: ZA_SX, ZA_SY + REAL(KIND=JWRB), DIMENSION(NFRE) :: UCINV + REAL(KIND=JWRB), DIMENSION(NFRE) :: LF + + REAL(KIND=JWRB) :: SDENSX_HF, SDENSY_HF, SDENSX_HF_UB, SDENSY_HF_UB + REAL(KIND=JWRB) :: TAUWX_LF, TAUWY_LF + REAL(KIND=JWRB) :: TAUWX_HF, TAUWY_HF + REAL(KIND=JWRB) :: ZA_EXP + + REAL(KIND=JWRB) :: TAU_TOT, TAU_VIS, TAU_WAV + REAL(KIND=JWRB) :: TAUVX, TAUVY, TAUX, TAUY + + REAL(KIND=JWRB) :: TAU_NND, TAU_INIT(2) + + REAL(KIND=JWRB) :: UPROXY, RTAU, DRTAU, ERR + LOGICAL :: OVERSHOT + + INTEGER(KIND=JWIM) :: IK, ITH, M, SIGN_NEW, SIGN_OLD + INTEGER(KIND=JWIM) :: NK, NTH, NSPEC !num. of freqs, dirs, spec. bins + INTEGER(KIND=JWIM), DIMENSION(NANG) :: ITHN + INTEGER(KIND=JWIM), DIMENSION(NFRE) :: IKN + + REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ---------------------------------------------------------------------- + + IF (LHOOK) CALL DR_HOOK('LFACTOR',0,ZHOOK_HANDLE) + + NTH = NANG ! NUMBER OF DIRS , SAME AS KL + NK = NFRE ! NUMBER OF FREQS, SAME AS ML + NSPEC = NK * NTH ! NUMBER OF SPECTRAL BINS + + ITHN = IRANGE(1,NTH,1) ! Index vector 1:NTH + DO IK = 1, NK + ECOS2 (ITHN+(IK-1)*NTH) = COSTH + ESIN2 (ITHN+(IK-1)*NTH) = SINTH + END DO + + SX = ABS(MIN(0.0_JWRB,S))*RESHAPE(ECOS2,(/NTH,NK/)) + SY = ABS(MIN(0.0_JWRB,S))*RESHAPE(ESIN2,(/NTH,NK/)) + +!/ ----------------------------------------------------------------- / +!/ ----------------------------------------------------------------- / +!/ Part I) --- low/high frequency contributions of TAU ------------- / + + !/ 0) --- split integral into low/high frequency contributions ------------- / + ! + ! + ! Th=2pi,f=inf Th=2pi,f=FR(NFRE) Th=2pi,f=inf + ! / / / / / / + ! | | S(f,Th)/c df dTh = | | S(f,Th)/c df dTh + | | S(f,Th)/c df dTh + ! / / / / / / + ! Th=0,f=0 Th=0,f=0 Th=0,f=FR(NFRE) + ! + ! + ! = LF_contribution + HF_contribution + ! + ! + !/ 1) --- low frequency contributions to the integral ---------------------- / + ! -- Direct summation over available freq. bins up to FR(NFRE) + + SDENSX_LF = SUM(SX,1) * DELTH + SDENSY_LF = SUM(SY,1) * DELTH + + TAUWX_LF = TAUWINDS(SDENSX_LF,CINV,DSII) ! x-component + TAUWY_LF = TAUWINDS(SDENSY_LF,CINV,DSII) ! y-component + + !/ 2) --- high frequency contributions to the integral --------------------- / + ! -- Assume spectral slope for S_IN(F) is proportional to F**(-2), then + ! integral collapses into easy analytic solution + ! + ! + ! Th=2pi,ω=ZPI*FRQMAX + ! / / + ! | | S(f,Th)/c df dTh = (LOG(ZPI*FRQMAX) - LOG(SIG(NFRE))) * SIG(NFRE)**2 * DELTH * SUM(S(:,NFRE)) * ZPI * GM1 + ! / / + ! Th=0,ω=SIG(NFRE) + ! + ! + ! Determine value of spectrum at NFRE (i.e. at highest frequency). + ! - Note, direction dimension must remain + + ZA_SX = SX(:,NFRE) + ZA_SY = SY(:,NFRE) + + SDENSX_HF = (LOG(ZPI*FRQMAX) - LOG(SIG(NFRE))) * SIG(NFRE)**2 * DELTH * SUM(ZA_SX) * ZPI * GM1 + SDENSY_HF = (LOG(ZPI*FRQMAX) - LOG(SIG(NFRE))) * SIG(NFRE)**2 * DELTH * SUM(ZA_SY) * ZPI * GM1 + + ! save these to be used later as upper bounds when LFACT applied (i.e. cap LFACT at 1) + SDENSX_HF_UB = SDENSX_HF + SDENSY_HF_UB = SDENSY_HF + + TAUWX_HF = G * ROWATER * ( SDENSX_HF ) + TAUWY_HF = G * ROWATER * ( SDENSY_HF ) + + !/ 3) --- summate low + high frequency contributions to the integral ------- / + + TAUWX = TAUWX_LF + TAUWX_HF + TAUWY = TAUWY_LF + TAUWY_HF + +!/ ----------------------------------------------------------------- / +!/ ----------------------------------------------------------------- / +!/ Part II) --- USTAR based TAU calculation ------------- / +! +!/ 2) --- Stress calculation ----------------------------------------- / +! --- The total stress ------------------------------------------- / + + TAU_TOT = USTAR**2 * ROAIRN + +! --- The viscous stress and check that it does not exceed +! the total stress. ------------------------------------------ / + + TAU_VIS = MAX(0.0_JWRB, -5.0E-5_JWRB*U10 + 1.1E-3_JWRB) * U10**2 * ROAIRN +! TAU_VIS = MIN(0.9 * TAU_TOT, TAU_VIS) + TAU_VIS = MIN(0.95_JWRB * TAU_TOT, TAU_VIS) + + TAUVX = TAU_VIS * COS(USDIR) + TAUVY = TAU_VIS * SIN(USDIR) + +! --- The wave supported stress (using elements calculated in Part I). -- / +! + TAU_WAV = SQRT(TAUWX**2 + TAUWY**2) ! normal stress (magnitude) + TAU_INIT = (/TAUWX,TAUWY/) ! unadjusted normal stress components + + TAUX = TAUVX + TAUWX ! total stress (x-component) + TAUY = TAUVY + TAUWY ! total stress (y-component) + TAU = SQRT(TAUX**2 + TAUY**2) ! total stress (magnitude) + ERR = (TAU-TAU_TOT)/TAU_TOT ! initial error + +!/ 3) --- Find reduced Sin(f) = L(f)*Sin(f) to satisfy our constraint +!/ TAU <= TAU_TOT --------------------------------------------- / + + LF = 1.0_JWRB + IK = 0 + IF (TAU .GT. TAU_TOT) THEN + OVERSHOT = .FALSE. + RTAU = ERR / 90.0_JWRB + DRTAU = 2.0_JWRB + SIGN_NEW = INT(SIGN(1.0_JWRB,ERR)) + + UPROXY = FRIC * CDFAC * USTAR + UCINV = 1.0_JWRB - (UPROXY * CINV) + DO IK=1,ITERMAX + + ! LFAC capped at 1 (i.e. always a reduction of Sin) + LF = MIN(1.0_JWRB, EXP(UCINV * RTAU) ) + + !/ 1) --- low frequency contributions as above ---------------------- / + TAUWX_LF = TAUWINDS(SDENSX_LF * LF,CINV,DSII) ! x-component + TAUWY_LF = TAUWINDS(SDENSY_LF * LF,CINV,DSII) ! y-component + + !/ 2) --- high frequency contributions as above, but modification to include LFAC ------ / + ! + ! + ! Th=2pi,ω=ZPI*FRQMAX + ! / / + ! | | LFAC*S(f,Th)/c df dTh = (-EXP(RTAU)*EI(ZA_EXP*SIG(NFRE))) * SIG(NFRE)**2 * DELTH * SUM(S(:,NFRE)) * ZPI * GM1 + ! / / + ! Th=0,ω=SIG(NFRE) + ! + ! where, LFAC = EXP(RTAU*( 1 - (U * 1/c))) + ! ZA_EXP = -ZPI*RTAU*U/GRAV + ! + ! then , use EI for exponential integral solution + ! + + ZA_EXP = -ZPI*RTAU*UPROXY*GM1 + + SDENSX_HF = (-EXP(RTAU)*EI(ZA_EXP*SIG(NFRE))) * SIG(NFRE)**2 * DELTH * SUM(ZA_SX) * ZPI * GM1 + SDENSY_HF = (-EXP(RTAU)*EI(ZA_EXP*SIG(NFRE))) * SIG(NFRE)**2 * DELTH * SUM(ZA_SY) * ZPI * GM1 + SDENSX_HF = MIN(SDENSX_HF, SDENSX_HF_UB) ! cap at unmodified HF contribution (LFAC capped at 1) + SDENSY_HF = MIN(SDENSY_HF, SDENSY_HF_UB) ! cap at unmodified HF contribution (LFAC capped at 1) + TAUWX_HF = G * ROWATER * ( SDENSX_HF ) + TAUWY_HF = G * ROWATER * ( SDENSY_HF ) + + TAUWX = TAUWX_LF + TAUWX_HF + TAUWY = TAUWY_LF + TAUWY_HF + TAU_WAV = SQRT(TAUWX**2 + TAUWY**2) + + TAUX = TAUVX + TAUWX + TAUY = TAUVY + TAUWY + TAU = SQRT(TAUX**2 + TAUY**2) + + ERR = (TAU-TAU_TOT) / TAU_TOT + SIGN_OLD = SIGN_NEW + SIGN_NEW = INT(SIGN(1.0_JWRB, ERR)) + +! --- Slow down DRTAU when overshot. -------------------------- / + + IF (SIGN_NEW .NE. SIGN_OLD) OVERSHOT = .TRUE. + IF (OVERSHOT) DRTAU = MAX(0.5_JWRB*(1.0_JWRB+DRTAU),1.00010_JWRB) + + RTAU = RTAU * (DRTAU**SIGN_NEW) + + IF (ABS(ERR) .LT. 1.54E-4_JWRB) EXIT + + END DO + + END IF + + LFACT = LF + + IF (LHOOK) CALL DR_HOOK('LFACTOR',1,ZHOOK_HANDLE) + + END SUBROUTINE LFACTORXY diff --git a/src/ecwam/lfactor.old.F90 b/src/ecwam/lfactor.ext.F90 similarity index 100% rename from src/ecwam/lfactor.old.F90 rename to src/ecwam/lfactor.ext.F90 From fcc523d31cb8ee791136f8c568de2225c538f86a Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Mon, 27 Oct 2025 12:22:45 +0000 Subject: [PATCH 57/89] post hoc merge conflict fix for airsea --- src/ecwam/airsea_jan.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/ecwam/airsea_jan.F90 b/src/ecwam/airsea_jan.F90 index 819152cd6..379655b20 100644 --- a/src/ecwam/airsea_jan.F90 +++ b/src/ecwam/airsea_jan.F90 @@ -99,6 +99,7 @@ SUBROUTINE AIRSEA_JAN (KIJS, KIJL, & ELSEIF (ICODE_WND == 1 .OR. ICODE_WND == 2) THEN +!$loki remove !* 3. DETERMINE ROUGHNESS LENGTH (if needed). ! --------------------------- @@ -116,6 +117,7 @@ SUBROUTINE AIRSEA_JAN (KIJS, KIJL, & U10 (IJ) = MAX (U10 (IJ), WSPMIN) ENDDO +!$loki end remove ELSE WRITE (IU06, * ) ' ++++++++++++++++++++++++++++++++++++++++++' WRITE (IU06, * ) ' + AIRSEA_JAN : INVALID VALUE OF ICODE_WND +' From 6d9c93a904e17317c8e9d8ec738cccf68b121c00 Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Tue, 28 Oct 2025 13:36:50 +0000 Subject: [PATCH 58/89] more bugfixes on lfactor_wvei, but still not quite there... --- src/ecwam/CMakeLists.txt | 2 +- src/ecwam/lfactor.F90 | 17 ++- .../{lfactor.ext.F90 => lfactor_ext.F90} | 17 ++- .../{lfactor.ei.F90 => lfactor_wvei.F90} | 106 +++++++++++------- src/ecwam/sinflx_zbry.F90 | 2 +- src/ecwam/w_maxh.F90 | 3 +- src/ecwam/{ei.F90 => wvei.F90} | 19 ++-- src/ecwam/yowpcons.F90 | 1 + 8 files changed, 105 insertions(+), 62 deletions(-) rename src/ecwam/{lfactor.ext.F90 => lfactor_ext.F90} (92%) rename src/ecwam/{lfactor.ei.F90 => lfactor_wvei.F90} (77%) rename src/ecwam/{ei.F90 => wvei.F90} (82%) diff --git a/src/ecwam/CMakeLists.txt b/src/ecwam/CMakeLists.txt index 17430020f..adb060fde 100644 --- a/src/ecwam/CMakeLists.txt +++ b/src/ecwam/CMakeLists.txt @@ -73,7 +73,6 @@ list( APPEND ecwam_srcs depthprpt.F90 difdate.F90 dominant_period.F90 - ei.F90 expand_string.F90 femean.F90 femeanws.F90 @@ -322,6 +321,7 @@ list( APPEND ecwam_srcs wvalloc.F90 wvchkmid.F90 wvdealloc.F90 + wvei.F90 wvfricvelo.F90 wvopenbathy.F90 wvopensubbathy.F90 diff --git a/src/ecwam/lfactor.F90 b/src/ecwam/lfactor.F90 index 8034499df..06dcb1f46 100644 --- a/src/ecwam/lfactor.F90 +++ b/src/ecwam/lfactor.F90 @@ -6,7 +6,7 @@ ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. - SUBROUTINE LFACTOR(S, CINV, U10, USTAR, USDIR, ROAIRN, & + SUBROUTINE LFACTOR(S, CINV, U10, USTAR, UPROXY, USDIR, ROAIRN, & & LFACT, TAUWX, TAUWY, TAU) ! ---------------------------------------------------------------------------- @@ -85,10 +85,11 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, USDIR, ROAIRN, & IMPLICIT NONE #include "irange.intfb.h" #include "tauwinds.intfb.h" +#include "abort1.intfb.h" REAL(KIND=JWRB), DIMENSION(NANG,NFRE), INTENT(IN) :: S ! Sin(sigma) in [m2/rad-Hz] REAL(KIND=JWRB), DIMENSION(NFRE), INTENT(IN) :: CINV - REAL(KIND=JWRB), INTENT(IN) :: U10, USTAR, USDIR, ROAIRN + REAL(KIND=JWRB), INTENT(IN) :: U10, USTAR, UPROXY, USDIR, ROAIRN REAL(KIND=JWRB), DIMENSION(NFRE), INTENT(OUT) :: LFACT REAL(KIND=JWRB), INTENT(OUT) :: TAUWX, TAUWY, TAU @@ -104,7 +105,7 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, USDIR, ROAIRN, & REAL(KIND=JWRB) :: TAU_TOT, TAU_VIS, TAU_WAV REAL(KIND=JWRB) :: TAUVX, TAUVY, TAUX, TAUY REAL(KIND=JWRB) :: TAU_NND, TAU_INIT(2) - REAL(KIND=JWRB) :: UPROXY, RTAU, DRTAU, ERR + REAL(KIND=JWRB) :: RTAU, DRTAU, ERR LOGICAL :: OVERSHOT CHARACTER(LEN=23) :: IDTIME @@ -165,6 +166,9 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, USDIR, ROAIRN, & ! --- The wave supported stress. --------------------------------- / TAUWX = TAUWINDS(SDENSX_EXT,CINV_EXT,DSII_EXT) ! normal stress (x-component) TAUWY = TAUWINDS(SDENSY_EXT,CINV_EXT,DSII_EXT) ! normal stress (y-component) + ! WRITE (*,*) ' ' + ! WRITE (*,*) ' TAUWX_LF ',TAUWINDS(SDENSX_EXT(1:NK),CINV_EXT(1:NK),DSII_EXT(1:NK)) + ! WRITE (*,*) ' TAUWX_MF_HF ',TAUWINDS(SDENSX_EXT(NK+1:NFRE_EXT),CINV_EXT(1:NK),DSII_EXT(NK+1:NFRE_EXT)) TAU_NND = TAUWINDS(SDENS_EXT, CINV_EXT,DSII_EXT) ! normal stress (non-directional) TAU_WAV = SQRT(TAUWX**2 + TAUWY**2) ! normal stress (magnitude) TAU_INIT = (/TAUWX,TAUWY/) ! unadjusted normal stress components @@ -188,7 +192,6 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, USDIR, ROAIRN, & SIGN_NEW = INT(SIGN(1.0_JWRB,ERR)) - UPROXY = FRIC * CDFAC * USTAR UCINV_EXT = 1.0_JWRB - (UPROXY * CINV_EXT) DO IK=1,ITERMAX @@ -197,6 +200,9 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, USDIR, ROAIRN, & TAU_NND = TAUWINDS(SDENS_EXT *LF_EXT,CINV_EXT,DSII_EXT) TAUWX = TAUWINDS(SDENSX_EXT*LF_EXT,CINV_EXT,DSII_EXT) TAUWY = TAUWINDS(SDENSY_EXT*LF_EXT,CINV_EXT,DSII_EXT) + ! WRITE (*,*) ' ' + ! WRITE (*,*) ' TAUWX_LF ',TAUWINDS(SDENSX_EXT(1:NK)*LF_EXT(1:NK),CINV_EXT(1:NK),DSII_EXT(1:NK)) + ! WRITE (*,*) ' TAUWX_MF_HF ',TAUWINDS(SDENSX_EXT(NK+1:NFRE_EXT)*LF_EXT(NK+1:NFRE_EXT),CINV_EXT(1:NK),DSII_EXT(NK+1:NFRE_EXT)) TAU_WAV = SQRT(TAUWX**2 + TAUWY**2) TAUX = TAUVX + TAUWX TAUY = TAUVY + TAUWY @@ -212,6 +218,9 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, USDIR, ROAIRN, & RTAU = RTAU * (DRTAU**SIGN_NEW) + ! CALL ABORT1 + + IF (ABS(ERR) .LT. 1.54E-4_JWRB) EXIT END DO diff --git a/src/ecwam/lfactor.ext.F90 b/src/ecwam/lfactor_ext.F90 similarity index 92% rename from src/ecwam/lfactor.ext.F90 rename to src/ecwam/lfactor_ext.F90 index 4e96ccaac..a32d5b1ce 100644 --- a/src/ecwam/lfactor.ext.F90 +++ b/src/ecwam/lfactor_ext.F90 @@ -6,7 +6,7 @@ ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. - SUBROUTINE LFACTORXX(S, CINV, U10, USTAR, USDIR, ROAIRN, & + SUBROUTINE LFACTORXX(S, CINV, U10, USTAR, UPROXY, USDIR, ROAIRN, & & LFACT, TAUWX, TAUWY, TAU) ! ---------------------------------------------------------------------------- @@ -85,10 +85,11 @@ SUBROUTINE LFACTORXX(S, CINV, U10, USTAR, USDIR, ROAIRN, & IMPLICIT NONE #include "irange.intfb.h" #include "tauwinds.intfb.h" +#include "abort1.intfb.h" REAL(KIND=JWRB), DIMENSION(NANG,NFRE), INTENT(IN) :: S ! Sin(sigma) in [m2/rad-Hz] REAL(KIND=JWRB), DIMENSION(NFRE), INTENT(IN) :: CINV - REAL(KIND=JWRB), INTENT(IN) :: U10, USTAR, USDIR, ROAIRN + REAL(KIND=JWRB), INTENT(IN) :: U10, USTAR, UPROXY, USDIR, ROAIRN REAL(KIND=JWRB), DIMENSION(NFRE), INTENT(OUT) :: LFACT REAL(KIND=JWRB), INTENT(OUT) :: TAUWX, TAUWY, TAU @@ -104,7 +105,7 @@ SUBROUTINE LFACTORXX(S, CINV, U10, USTAR, USDIR, ROAIRN, & REAL(KIND=JWRB) :: TAU_TOT, TAU_VIS, TAU_WAV REAL(KIND=JWRB) :: TAUVX, TAUVY, TAUX, TAUY REAL(KIND=JWRB) :: TAU_NND, TAU_INIT(2) - REAL(KIND=JWRB) :: UPROXY, RTAU, DRTAU, ERR + REAL(KIND=JWRB) :: RTAU, DRTAU, ERR LOGICAL :: OVERSHOT CHARACTER(LEN=23) :: IDTIME @@ -165,6 +166,9 @@ SUBROUTINE LFACTORXX(S, CINV, U10, USTAR, USDIR, ROAIRN, & ! --- The wave supported stress. --------------------------------- / TAUWX = TAUWINDS(SDENSX_EXT,CINV_EXT,DSII_EXT) ! normal stress (x-component) TAUWY = TAUWINDS(SDENSY_EXT,CINV_EXT,DSII_EXT) ! normal stress (y-component) + ! WRITE (*,*) ' ' + ! WRITE (*,*) ' TAUWX_LF ',TAUWINDS(SDENSX_EXT(1:NK),CINV_EXT(1:NK),DSII_EXT(1:NK)) + ! WRITE (*,*) ' TAUWX_MF_HF ',TAUWINDS(SDENSX_EXT(NK+1:NFRE_EXT),CINV_EXT(1:NK),DSII_EXT(NK+1:NFRE_EXT)) TAU_NND = TAUWINDS(SDENS_EXT, CINV_EXT,DSII_EXT) ! normal stress (non-directional) TAU_WAV = SQRT(TAUWX**2 + TAUWY**2) ! normal stress (magnitude) TAU_INIT = (/TAUWX,TAUWY/) ! unadjusted normal stress components @@ -188,7 +192,6 @@ SUBROUTINE LFACTORXX(S, CINV, U10, USTAR, USDIR, ROAIRN, & SIGN_NEW = INT(SIGN(1.0_JWRB,ERR)) - UPROXY = FRIC * CDFAC * USTAR UCINV_EXT = 1.0_JWRB - (UPROXY * CINV_EXT) DO IK=1,ITERMAX @@ -197,6 +200,9 @@ SUBROUTINE LFACTORXX(S, CINV, U10, USTAR, USDIR, ROAIRN, & TAU_NND = TAUWINDS(SDENS_EXT *LF_EXT,CINV_EXT,DSII_EXT) TAUWX = TAUWINDS(SDENSX_EXT*LF_EXT,CINV_EXT,DSII_EXT) TAUWY = TAUWINDS(SDENSY_EXT*LF_EXT,CINV_EXT,DSII_EXT) + ! WRITE (*,*) ' ' + ! WRITE (*,*) ' TAUWX_LF ',TAUWINDS(SDENSX_EXT(1:NK)*LF_EXT(1:NK),CINV_EXT(1:NK),DSII_EXT(1:NK)) + ! WRITE (*,*) ' TAUWX_MF_HF ',TAUWINDS(SDENSX_EXT(NK+1:NFRE_EXT)*LF_EXT(NK+1:NFRE_EXT),CINV_EXT(1:NK),DSII_EXT(NK+1:NFRE_EXT)) TAU_WAV = SQRT(TAUWX**2 + TAUWY**2) TAUX = TAUVX + TAUWX TAUY = TAUVY + TAUWY @@ -212,6 +218,9 @@ SUBROUTINE LFACTORXX(S, CINV, U10, USTAR, USDIR, ROAIRN, & RTAU = RTAU * (DRTAU**SIGN_NEW) + ! CALL ABORT1 + + IF (ABS(ERR) .LT. 1.54E-4_JWRB) EXIT END DO diff --git a/src/ecwam/lfactor.ei.F90 b/src/ecwam/lfactor_wvei.F90 similarity index 77% rename from src/ecwam/lfactor.ei.F90 rename to src/ecwam/lfactor_wvei.F90 index f38993970..4cd92a3ad 100644 --- a/src/ecwam/lfactor.ei.F90 +++ b/src/ecwam/lfactor_wvei.F90 @@ -6,7 +6,7 @@ ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. - SUBROUTINE LFACTORXY(S, CINV, U10, USTAR, USDIR, ROAIRN, & + SUBROUTINE LFACTORXY(S, CINV, U10, USTAR, UPROXY, USDIR, ROAIRN, & & LFACT, TAUWX, TAUWY, TAU) ! ---------------------------------------------------------------------------- @@ -85,11 +85,12 @@ SUBROUTINE LFACTORXY(S, CINV, U10, USTAR, USDIR, ROAIRN, & IMPLICIT NONE #include "irange.intfb.h" #include "tauwinds.intfb.h" -#include "ei.intfb.h" +#include "wvei.intfb.h" +#include "abort1.intfb.h" - REAL(KIND=JWRB), DIMENSION(NANG,NFRE), INTENT(IN) :: S ! Sin(sigma) in [m2/rad-Hz] + REAL(KIND=JWRB), DIMENSION(NANG,NFRE), INTENT(IN) :: S ! Sin(sigma) in omega REAL(KIND=JWRB), DIMENSION(NFRE), INTENT(IN) :: CINV - REAL(KIND=JWRB), INTENT(IN) :: U10, USTAR, USDIR, ROAIRN + REAL(KIND=JWRB), INTENT(IN) :: U10, USTAR, UPROXY, USDIR, ROAIRN REAL(KIND=JWRB), DIMENSION(NFRE), INTENT(OUT) :: LFACT REAL(KIND=JWRB), INTENT(OUT) :: TAUWX, TAUWY, TAU @@ -104,18 +105,20 @@ SUBROUTINE LFACTORXY(S, CINV, U10, USTAR, USDIR, ROAIRN, & REAL(KIND=JWRB), DIMENSION(NFRE) :: UCINV REAL(KIND=JWRB), DIMENSION(NFRE) :: LF - REAL(KIND=JWRB) :: SDENSX_HF, SDENSY_HF, SDENSX_HF_UB, SDENSY_HF_UB - REAL(KIND=JWRB) :: TAUWX_LF, TAUWY_LF + REAL(KIND=JWRB) :: SDENSX_HF, SDENSY_HF, SDENSX_MF_HF, SDENSY_MF_HF + REAL(KIND=JWRB) :: SDENSX_MF, SDENSY_MF + REAL(KIND=JWRB) :: TAUWX_LF, TAUWY_LF, TAUWX_MF_HF, TAUWY_MF_HF REAL(KIND=JWRB) :: TAUWX_HF, TAUWY_HF - REAL(KIND=JWRB) :: ZA_EXP + REAL(KIND=JWRB) :: ZA_EXP, ZWVEI, FRQMID REAL(KIND=JWRB) :: TAU_TOT, TAU_VIS, TAU_WAV REAL(KIND=JWRB) :: TAUVX, TAUVY, TAUX, TAUY REAL(KIND=JWRB) :: TAU_NND, TAU_INIT(2) - REAL(KIND=JWRB) :: UPROXY, RTAU, DRTAU, ERR + REAL(KIND=JWRB) :: RTAU, DRTAU, ERR LOGICAL :: OVERSHOT + LOGICAL :: LLFRQHF INTEGER(KIND=JWIM) :: IK, ITH, M, SIGN_NEW, SIGN_OLD INTEGER(KIND=JWIM) :: NK, NTH, NSPEC !num. of freqs, dirs, spec. bins @@ -132,15 +135,24 @@ SUBROUTINE LFACTORXY(S, CINV, U10, USTAR, USDIR, ROAIRN, & NK = NFRE ! NUMBER OF FREQS, SAME AS ML NSPEC = NK * NTH ! NUMBER OF SPECTRAL BINS + FRQMID = MIN(FRQMAX,G/(ZPI*UPROXY)) ! dynamic cutoff frequency, capped at FRQMAX + + ! Determines if we need special treatment for some of the high frequencies to account for LFAC + IF (FRQMID>FR(NFRE)) THEN + LLFRQHF = .TRUE. + ELSE + LLFRQHF = .FALSE. + END IF + ITHN = IRANGE(1,NTH,1) ! Index vector 1:NTH DO IK = 1, NK ECOS2 (ITHN+(IK-1)*NTH) = COSTH ESIN2 (ITHN+(IK-1)*NTH) = SINTH END DO - SX = ABS(MIN(0.0_JWRB,S))*RESHAPE(ECOS2,(/NTH,NK/)) - SY = ABS(MIN(0.0_JWRB,S))*RESHAPE(ESIN2,(/NTH,NK/)) - + SX = MAX(0.0_JWRB,S)*RESHAPE(ECOS2,(/NTH,NK/)) + SY = MAX(0.0_JWRB,S)*RESHAPE(ESIN2,(/NTH,NK/)) + !/ ----------------------------------------------------------------- / !/ ----------------------------------------------------------------- / !/ Part I) --- low/high frequency contributions of TAU ------------- / @@ -172,9 +184,9 @@ SUBROUTINE LFACTORXY(S, CINV, U10, USTAR, USDIR, ROAIRN, & ! integral collapses into easy analytic solution ! ! - ! Th=2pi,ω=ZPI*FRQMAX + ! Th=2pi,ω=ZPI*FRQMID ! / / - ! | | S(f,Th)/c df dTh = (LOG(ZPI*FRQMAX) - LOG(SIG(NFRE))) * SIG(NFRE)**2 * DELTH * SUM(S(:,NFRE)) * ZPI * GM1 + ! | | S(f,Th)/c df dTh = (LOG(ZPI*FRQMID) - LOG(SIG(NFRE))) * SIG(NFRE)**2 * DELTH * SUM(S(:,NFRE)) * ZPI * GM1 ! / / ! Th=0,ω=SIG(NFRE) ! @@ -185,20 +197,20 @@ SUBROUTINE LFACTORXY(S, CINV, U10, USTAR, USDIR, ROAIRN, & ZA_SX = SX(:,NFRE) ZA_SY = SY(:,NFRE) - SDENSX_HF = (LOG(ZPI*FRQMAX) - LOG(SIG(NFRE))) * SIG(NFRE)**2 * DELTH * SUM(ZA_SX) * ZPI * GM1 - SDENSY_HF = (LOG(ZPI*FRQMAX) - LOG(SIG(NFRE))) * SIG(NFRE)**2 * DELTH * SUM(ZA_SY) * ZPI * GM1 - - ! save these to be used later as upper bounds when LFACT applied (i.e. cap LFACT at 1) - SDENSX_HF_UB = SDENSX_HF - SDENSY_HF_UB = SDENSY_HF + ! mid + high frequency contributions + SDENSX_MF_HF = ZPI * GM1 * SIG(NFRE)**2 * (LOG(ZPI*FRQMAX) - LOG(SIG(NFRE))) * DELTH * SUM(ZA_SX) + SDENSY_MF_HF = ZPI * GM1 * SIG(NFRE)**2 * (LOG(ZPI*FRQMAX) - LOG(SIG(NFRE))) * DELTH * SUM(ZA_SY) - TAUWX_HF = G * ROWATER * ( SDENSX_HF ) - TAUWY_HF = G * ROWATER * ( SDENSY_HF ) + TAUWX_MF_HF = G * ROWATER * ( SDENSX_MF_HF ) + TAUWY_MF_HF = G * ROWATER * ( SDENSY_MF_HF ) - !/ 3) --- summate low + high frequency contributions to the integral ------- / + !/ 3) --- summate low + mid + high frequency contributions to the integral ------- / - TAUWX = TAUWX_LF + TAUWX_HF - TAUWY = TAUWY_LF + TAUWY_HF + TAUWX = TAUWX_LF + TAUWX_MF_HF + TAUWY = TAUWY_LF + TAUWY_MF_HF + ! WRITE (*,*) ' ' + ! WRITE (*,*) ' TAUWX_LF ',TAUWX_LF + ! WRITE (*,*) ' TAUWX_MF_HF ',TAUWX_MF_HF !/ ----------------------------------------------------------------- / !/ ----------------------------------------------------------------- / @@ -234,13 +246,24 @@ SUBROUTINE LFACTORXY(S, CINV, U10, USTAR, USDIR, ROAIRN, & LF = 1.0_JWRB IK = 0 + + IF (LLFRQHF) THEN + ! mid frequency contributions (from FR(NFRE) to FRQMID) + SDENSX_MF = (LOG(ZPI*FRQMID) - LOG(SIG(NFRE))) * SIG(NFRE)**2 * DELTH * SUM(ZA_SX) * ZPI * GM1 + SDENSY_MF = (LOG(ZPI*FRQMID) - LOG(SIG(NFRE))) * SIG(NFRE)**2 * DELTH * SUM(ZA_SY) * ZPI * GM1 + ELSE + ! mid + high frequency contributions (from FR(NFRE) to FRQMAX) + SDENSX_MF_HF = (LOG(ZPI*FRQMAX) - LOG(SIG(NFRE))) * SIG(NFRE)**2 * DELTH * SUM(ZA_SX) * ZPI * GM1 + SDENSY_MF_HF = (LOG(ZPI*FRQMAX) - LOG(SIG(NFRE))) * SIG(NFRE)**2 * DELTH * SUM(ZA_SY) * ZPI * GM1 + END IF + + IF (TAU .GT. TAU_TOT) THEN OVERSHOT = .FALSE. RTAU = ERR / 90.0_JWRB DRTAU = 2.0_JWRB SIGN_NEW = INT(SIGN(1.0_JWRB,ERR)) - UPROXY = FRIC * CDFAC * USTAR UCINV = 1.0_JWRB - (UPROXY * CINV) DO IK=1,ITERMAX @@ -258,7 +281,7 @@ SUBROUTINE LFACTORXY(S, CINV, U10, USTAR, USDIR, ROAIRN, & ! / / ! | | LFAC*S(f,Th)/c df dTh = (-EXP(RTAU)*EI(ZA_EXP*SIG(NFRE))) * SIG(NFRE)**2 * DELTH * SUM(S(:,NFRE)) * ZPI * GM1 ! / / - ! Th=0,ω=SIG(NFRE) + ! Th=0,ω=ZPI*FRQMID ! ! where, LFAC = EXP(RTAU*( 1 - (U * 1/c))) ! ZA_EXP = -ZPI*RTAU*U/GRAV @@ -266,23 +289,28 @@ SUBROUTINE LFACTORXY(S, CINV, U10, USTAR, USDIR, ROAIRN, & ! then , use EI for exponential integral solution ! - ZA_EXP = -ZPI*RTAU*UPROXY*GM1 + IF (LLFRQHF) THEN + ZA_EXP = -ZPI*RTAU*UPROXY*GM1 + ZWVEI = -EXP(RTAU)*WVEI(ZA_EXP*(ZPI*FRQMID)) + SDENSX_HF = ZWVEI * (ZPI*FRQMID)**2 * ZPI * GM1 * DELTH * SUM(ZA_SX) + SDENSY_HF = ZWVEI * (ZPI*FRQMID)**2 * ZPI * GM1 * DELTH * SUM(ZA_SY) + TAUWX_MF_HF = G * ROWATER * ( SDENSX_MF + SDENSX_HF) + TAUWY_MF_HF = G * ROWATER * ( SDENSY_MF + SDENSY_HF) + ELSE + TAUWX_MF_HF = G * ROWATER * ( SDENSX_MF_HF ) + TAUWY_MF_HF = G * ROWATER * ( SDENSY_MF_HF ) + END IF + + TAUWX = TAUWX_LF + TAUWX_MF_HF + TAUWY = TAUWY_LF + TAUWY_MF_HF + ! WRITE (*,*) ' ' + ! WRITE (*,*) ' TAUWX_LF ',TAUWX_LF + ! WRITE (*,*) ' TAUWX_MF_HF ',TAUWX_MF_HF - SDENSX_HF = (-EXP(RTAU)*EI(ZA_EXP*SIG(NFRE))) * SIG(NFRE)**2 * DELTH * SUM(ZA_SX) * ZPI * GM1 - SDENSY_HF = (-EXP(RTAU)*EI(ZA_EXP*SIG(NFRE))) * SIG(NFRE)**2 * DELTH * SUM(ZA_SY) * ZPI * GM1 - SDENSX_HF = MIN(SDENSX_HF, SDENSX_HF_UB) ! cap at unmodified HF contribution (LFAC capped at 1) - SDENSY_HF = MIN(SDENSY_HF, SDENSY_HF_UB) ! cap at unmodified HF contribution (LFAC capped at 1) - TAUWX_HF = G * ROWATER * ( SDENSX_HF ) - TAUWY_HF = G * ROWATER * ( SDENSY_HF ) - - TAUWX = TAUWX_LF + TAUWX_HF - TAUWY = TAUWY_LF + TAUWY_HF TAU_WAV = SQRT(TAUWX**2 + TAUWY**2) - TAUX = TAUVX + TAUWX TAUY = TAUVY + TAUWY TAU = SQRT(TAUX**2 + TAUY**2) - ERR = (TAU-TAU_TOT) / TAU_TOT SIGN_OLD = SIGN_NEW SIGN_NEW = INT(SIGN(1.0_JWRB, ERR)) @@ -294,6 +322,8 @@ SUBROUTINE LFACTORXY(S, CINV, U10, USTAR, USDIR, ROAIRN, & RTAU = RTAU * (DRTAU**SIGN_NEW) + ! CALL ABORT1 + IF (ABS(ERR) .LT. 1.54E-4_JWRB) EXIT END DO diff --git a/src/ecwam/sinflx_zbry.F90 b/src/ecwam/sinflx_zbry.F90 index 236c6c76f..84096dcd7 100644 --- a/src/ecwam/sinflx_zbry.F90 +++ b/src/ecwam/sinflx_zbry.F90 @@ -472,7 +472,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & DO IJ = KIJS,KIJL SDENSIG(IJ,:,:,IGST) = RESHAPE(S(IJ,:,IGST)*SIG2/CG2(IJ,:),(/ NANG, NFRE /)) - CALL LFACTOR(SDENSIG(IJ,:,:,IGST), CINV1(IJ,:), UABSGST(IJ,IGST), USTARGST(IJ,IGST), WDWAVE(IJ), & + CALL LFACTOR(SDENSIG(IJ,:,:,IGST), CINV1(IJ,:), UABSGST(IJ,IGST), USTARGST(IJ,IGST), UPROXYGST(IJ,IGST), WDWAVE(IJ), & & ROAIRN(IJ), LFACT(IJ,:,IGST), TAUWX(IJ,IGST), TAUWY(IJ,IGST), TAU(IJ,IGST)) ENDDO diff --git a/src/ecwam/w_maxh.F90 b/src/ecwam/w_maxh.F90 index 0b067c136..784895a3d 100644 --- a/src/ecwam/w_maxh.F90 +++ b/src/ecwam/w_maxh.F90 @@ -37,7 +37,7 @@ SUBROUTINE W_MAXH (KIJS, KIJL, F, DEPTH, WAVNUM, & USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU -USE YOWPCONS , ONLY : G ,ZPI +USE YOWPCONS , ONLY : G ,ZPI ,GAMMA_E USE YOWFRED , ONLY : FR ,TH ,DELTH ,DFIM ,DFIMFR , DFIMFR2, & & COSTH ,SINTH ,WETAIL USE YOWPARAM , ONLY : NANG ,NFRE @@ -67,7 +67,6 @@ SUBROUTINE W_MAXH (KIJS, KIJL, F, DEPTH, WAVNUM, & INTEGER(KIND=JWIM), PARAMETER :: MAXIT = 10 -REAL(KIND=JWRB), PARAMETER :: GAMMA_E = 0.57721566_JWRB !! EULER CONSTANT REAL(KIND=JWRB), PARAMETER :: GRRM1 = 2._JWRB/(1._JWRB+SQRT(5._JWRB)) !! INVERSE OF GOLDEN RATIO REAL(KIND=JWRB), PARAMETER :: THREEHALF = 3._JWRB/2._JWRB REAL(KIND=JWRB), PARAMETER :: XNWVP = 100._JWRB !! NUMBER OF WAVE PERIODS TO SET WMDUR_ST (if constant value is not used) diff --git a/src/ecwam/ei.F90 b/src/ecwam/wvei.F90 similarity index 82% rename from src/ecwam/ei.F90 rename to src/ecwam/wvei.F90 index 48e869817..3e68fd5d6 100644 --- a/src/ecwam/ei.F90 +++ b/src/ecwam/wvei.F90 @@ -6,7 +6,7 @@ ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. - FUNCTION EI(x) RESULT(res) + FUNCTION WVEI(x) RESULT(res) ! ---------------------------------------------------------------------------- ! @@ -23,24 +23,19 @@ FUNCTION EI(x) RESULT(res) ! ORIGIN. ! ---------- -! Adapted from Babanin Young Donelan & Banner (ZBRY) physics -! as implemented as ST6 in WAVEWATCH-III -! WW3 module: W3SRC6MD -! WW3 subroutine: TAUWINDS -! Implementation into ECWAM DECEMBER 2021 by J. Kousal +! Implementation into ECWAM DECEMBER 2025 by J. Kousal based on available online solvers ! ---------------------------------------------------------------------------- ! USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU + USE YOWPCONS , ONLY : GAMMA_E USE YOMHOOK , ONLY : LHOOK ,DR_HOOK, JPHOOK !---------------------------------------------------------------------- IMPLICIT NONE - REAL(KIND=JWRB), INTENT(IN) :: x - REAL(KIND=JWRB), PARAMETER :: EULER = 0.57721566490153286060651209_JWRB REAL(KIND=JWRB) :: term, sum, res INTEGER(KIND=JWIM) :: k, kmax REAL(KIND=JWRB) :: eps @@ -50,7 +45,7 @@ FUNCTION EI(x) RESULT(res) ! ---------------------------------------------------------------------------- ! - IF (LHOOK) CALL DR_HOOK('EI',0,ZHOOK_HANDLE) + IF (LHOOK) CALL DR_HOOK('WVEI',0,ZHOOK_HANDLE) eps = 1.0E-12_JWRB @@ -70,7 +65,7 @@ FUNCTION EI(x) RESULT(res) if (abs(term/real(k+1,kind=JWRB)) < abs(sum)*eps) exit k = k + 1 end do - res = EULER + log(abs(x)) + sum + res = GAMMA_E + log(abs(x)) + sum else ! asymptotic for large positive x: Ei(x) ~ exp(x)/x * (1 + 1/x + 2!/x^2 + 6/x^3 + ...) kmax = 50 @@ -84,6 +79,6 @@ FUNCTION EI(x) RESULT(res) res = exp(x) / x * sum end if - IF (LHOOK) CALL DR_HOOK('EI',1,ZHOOK_HANDLE) + IF (LHOOK) CALL DR_HOOK('WVEI',1,ZHOOK_HANDLE) - END FUNCTION EI \ No newline at end of file + END FUNCTION WVEI \ No newline at end of file diff --git a/src/ecwam/yowpcons.F90 b/src/ecwam/yowpcons.F90 index 23b95d461..fbe4bd1f5 100644 --- a/src/ecwam/yowpcons.F90 +++ b/src/ecwam/yowpcons.F90 @@ -18,6 +18,7 @@ MODULE YOWPCONS REAL(KIND=JWRB) :: G = 9.806_JWRB REAL(KIND=JWRB) :: GM1 = 0.101978381_JWRB + REAL(KIND=JWRB) :: GAMMA_E = 0.57721566_JWRB !! EULER CONSTANT REAL(KIND=JWRB), PARAMETER :: OLDPI = 3.1415927_JWRB REAL(KIND=JWRB) :: PI = OLDPI REAL(KIND=JWRB), PARAMETER :: CIRC = 40007993.95_JWRB From 0ce1ecd3a293f14de4ec71192777430b3a94b2c5 Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Tue, 28 Oct 2025 17:53:40 +0000 Subject: [PATCH 59/89] zbry, set FRQMAX=10 always --- src/ecwam/setwavphys.F90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/ecwam/setwavphys.F90 b/src/ecwam/setwavphys.F90 index 51dfb80fa..8513fb806 100644 --- a/src/ecwam/setwavphys.F90 +++ b/src/ecwam/setwavphys.F90 @@ -225,13 +225,11 @@ SUBROUTINE SETWAVPHYS ALPHAPMAX = 1.0_JWRB ! i.e. no cap on max spectral steepness TAILFACTOR=6.0_JWRB ! SIN6FC = 6.0 from WW3-ST6 TAILFACTOR_PM=4.0_JWRB ! FXPM = 4.0 from WW3 (all) - FRQMAX = 10.0_JWRB ! extend to 10Hz for LFACTOR CASE(2,3) NGST=2 ALPHAPMAX = 0.031_JWRB ! cap on spectral steepness as in ARD TAILFACTOR=2.5_JWRB TAILFACTOR_PM=3.0_JWRB ! as in ARD - FRQMAX = 5.0_JWRB ! 5Hz also works well (TODO: could do with further testing) CASE DEFAULT WRITE (IU06,*) '*************************************' WRITE (IU06,*) '* *' @@ -253,6 +251,7 @@ SUBROUTINE SETWAVPHYS ZSWL6B1 = 0.0041_JWRB ZSIN6A0 = 9.0E-2_JWRB LLFACT = .TRUE. + FRQMAX = 10.0_JWRB ! extend to 10Hz for LFACTOR ELSE WRITE (IU06,*) '*************************************' WRITE (IU06,*) '* *' From c86c955276dd1fa9c2e12e9ceeace50b2578ffcc Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Tue, 28 Oct 2025 18:18:09 +0000 Subject: [PATCH 60/89] remove uproxy output because it conflicts with the same arguments/functions used in Wam_oper... --- src/ecwam/implsch.F90 | 6 +++--- src/ecwam/outblock.F90 | 7 +++---- src/ecwam/outbs.F90 | 2 +- src/ecwam/outbs_loki_gpu.F90 | 2 +- src/ecwam/outstep0.F90 | 2 +- src/ecwam/sinflx.F90 | 5 ++--- src/ecwam/sinflx_zbry.F90 | 8 ++------ src/ecwam/wamintgr.F90 | 2 +- src/ecwam/wamintgr_loki_gpu.F90 | 2 +- src/ecwam/wdfluxes.F90 | 6 +++--- src/ecwam/yowdrvtype_config.yml | 2 +- tests/etopo1_oper_an_fc_O48_cy50r1_zbry.yml | 1 - 12 files changed, 19 insertions(+), 26 deletions(-) diff --git a/src/ecwam/implsch.F90 b/src/ecwam/implsch.F90 index 7965b87e4..ccc9df640 100644 --- a/src/ecwam/implsch.F90 +++ b/src/ecwam/implsch.F90 @@ -19,7 +19,7 @@ SUBROUTINE IMPLSCH (KIJS, KIJL, FL1, & & WSEMEAN, WSFMEAN, USTOKES, VSTOKES, STRNMS, & & TAUXD, TAUYD, TAUOCXD, TAUOCYD, TAUOC, & & TAUICX, TAUICY, & - & PHIOCD, PHIEPS, PHIAW, UPROXY, & + & PHIOCD, PHIEPS, PHIAW, & & MIJ, XLLWS) ! ---------------------------------------------------------------------- @@ -130,7 +130,7 @@ SUBROUTINE IMPLSCH (KIJS, KIJL, FL1, & INTEGER(KIND=JWIM), DIMENSION(KIJL), INTENT(IN) :: IOBND REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: AIRD, WDWAVE, CICOVER, WSWAVE, WSTAR, USTRA, VSTRA - REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: UFRIC, UPROXY, TAUW, TAUWDIR, Z0M, Z0B, CHRNCK, CITHICK + REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: UFRIC, TAUW, TAUWDIR, Z0M, Z0B, CHRNCK, CITHICK REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: WSEMEAN, WSFMEAN, USTOKES, VSTOKES, STRNMS REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: TAUXD, TAUYD, TAUOCXD, TAUOCYD, TAUOC, PHIOCD REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: TAUICX, TAUICY @@ -270,7 +270,7 @@ SUBROUTINE IMPLSCH (KIJS, KIJL, FL1, & & COSWDIF, SINWDIF2, & & FMEAN, HALP, FMEANWS, & & FLM, & - & UFRIC, UPROXY, TAUW, TAUWDIR, & + & UFRIC, TAUW, TAUWDIR, & & Z0M, Z0B, CHRNCK, PHIWA, & & FLD, SL, SPOS, & & MIJ, RHOWGDFTH, XLLWS) diff --git a/src/ecwam/outblock.F90 b/src/ecwam/outblock.F90 index 0ab8c1481..d7e5a3059 100644 --- a/src/ecwam/outblock.F90 +++ b/src/ecwam/outblock.F90 @@ -16,7 +16,7 @@ SUBROUTINE OUTBLOCK (KIJS, KIJL, MIJ, & & TAUXD, TAUYD, TAUOCXD, & & TAUOCYD, TAUOC, & & TAUICX, TAUICY, PHIOCD, & - & PHIEPS, PHIAW, UPROXY, & + & PHIEPS, PHIAW, & & AIRD, WDWAVE, CICOVER, & & WSWAVE, WSTAR, & & UFRIC, TAUW, & @@ -110,7 +110,7 @@ SUBROUTINE OUTBLOCK (KIJS, KIJL, MIJ, & REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: IBRMEM REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: AIRD, WDWAVE, CICOVER, WSWAVE, WSTAR - REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: UFRIC, UPROXY, TAUW, Z0M, Z0B, CHRNCK, CITHICK + REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: UFRIC, TAUW, Z0M, Z0B, CHRNCK, CITHICK REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: ALTWH, CALTWH, RALTCOR, USTOKES, VSTOKES, STRNMS REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: TAUXD, TAUYD, TAUOCXD, TAUOCYD, TAUOC, PHIOCD REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: TAUICX, TAUICY @@ -575,8 +575,7 @@ SUBROUTINE OUTBLOCK (KIJS, KIJL, MIJ, & ENDIF IF (IPFGTBL(66 + 3*NTRAIN + NTEWH) /= 0) THEN - ! BOUT(KIJS:KIJL,ITOBOUT(66 + 3*NTRAIN + NTEWH))=HMAX_ST(KIJS:KIJL) - BOUT(KIJS:KIJL,ITOBOUT(66 + 3*NTRAIN + NTEWH))=UPROXY(KIJS:KIJL) ! josh hack + BOUT(KIJS:KIJL,ITOBOUT(66 + 3*NTRAIN + NTEWH))=HMAX_ST(KIJS:KIJL) ENDIF IF (IPFGTBL(67 + 3*NTRAIN + NTEWH) /= 0) THEN diff --git a/src/ecwam/outbs.F90 b/src/ecwam/outbs.F90 index da3f80a8f..317ec1103 100644 --- a/src/ecwam/outbs.F90 +++ b/src/ecwam/outbs.F90 @@ -106,7 +106,7 @@ SUBROUTINE OUTBS (MIJ, FL1, XLLWS, & & INTFLDS%TAUXD(:,ICHNK), INTFLDS%TAUYD(:,ICHNK), INTFLDS%TAUOCXD(:,ICHNK), & & INTFLDS%TAUOCYD(:,ICHNK), INTFLDS%TAUOC(:,ICHNK), & & INTFLDS%TAUICX(:,ICHNK), INTFLDS%TAUICY(:,ICHNK), INTFLDS%PHIOCD(:,ICHNK), & - & INTFLDS%PHIEPS(:,ICHNK), INTFLDS%PHIAW(:,ICHNK), INTFLDS%UPROXY(:,ICHNK), & + & INTFLDS%PHIEPS(:,ICHNK), INTFLDS%PHIAW(:,ICHNK), & & FF_NOW%AIRD(:,ICHNK), FF_NOW%WDWAVE(:,ICHNK), FF_NOW%CICOVER(:,ICHNK), & & FF_NOW%WSWAVE(:,ICHNK), FF_NOW%WSTAR(:,ICHNK), & & FF_NOW%UFRIC(:,ICHNK), FF_NOW%TAUW(:,ICHNK), & diff --git a/src/ecwam/outbs_loki_gpu.F90 b/src/ecwam/outbs_loki_gpu.F90 index 66a517ad6..a0336a04b 100644 --- a/src/ecwam/outbs_loki_gpu.F90 +++ b/src/ecwam/outbs_loki_gpu.F90 @@ -112,7 +112,7 @@ SUBROUTINE OUTBS_LOKI_GPU (MIJ, FL1, XLLWS, & & INTFLDS%TAUXD(:,ICHNK), INTFLDS%TAUYD(:,ICHNK), INTFLDS%TAUOCXD(:,ICHNK), & & INTFLDS%TAUOCYD(:,ICHNK), INTFLDS%TAUOC(:,ICHNK), & & INTFLDS%TAUICX(:,ICHNK), INTFLDS%TAUICY(:,ICHNK), INTFLDS%PHIOCD(:,ICHNK), & - & INTFLDS%PHIEPS(:,ICHNK), INTFLDS%PHIAW(:,ICHNK), INTFLDS%UPROXY(:,ICHNK), & + & INTFLDS%PHIEPS(:,ICHNK), INTFLDS%PHIAW(:,ICHNK), & & FF_NOW%AIRD(:,ICHNK), FF_NOW%WDWAVE(:,ICHNK), FF_NOW%CICOVER(:,ICHNK), & & FF_NOW%WSWAVE(:,ICHNK), FF_NOW%WSTAR(:,ICHNK), & & FF_NOW%UFRIC(:,ICHNK), FF_NOW%TAUW(:,ICHNK), & diff --git a/src/ecwam/outstep0.F90 b/src/ecwam/outstep0.F90 index 5e00e51b3..a99d946e1 100644 --- a/src/ecwam/outstep0.F90 +++ b/src/ecwam/outstep0.F90 @@ -126,7 +126,7 @@ SUBROUTINE OUTSTEP0 (WVENVI, WVPRPT, FF_NOW, INTFLDS, & & INTFLDS%TAUXD(:,ICHNK), INTFLDS%TAUYD(:,ICHNK), INTFLDS%TAUOCXD(:,ICHNK), & & INTFLDS%TAUOCYD(:,ICHNK), INTFLDS%TAUOC(:,ICHNK), & & INTFLDS%TAUICX(:,ICHNK), INTFLDS%TAUICY(:,ICHNK), INTFLDS%PHIOCD(:,ICHNK), & - & INTFLDS%PHIEPS(:,ICHNK), INTFLDS%PHIAW(:,ICHNK), INTFLDS%UPROXY(:,ICHNK), & + & INTFLDS%PHIEPS(:,ICHNK), INTFLDS%PHIAW(:,ICHNK), & & WAM2NEMO%NEMOUSTOKES(:,ICHNK), WAM2NEMO%NEMOVSTOKES(:,ICHNK), WAM2NEMO%NEMOSTRN(:,ICHNK), & & WAM2NEMO%NPHIEPS(:,ICHNK), WAM2NEMO%NTAUOC(:,ICHNK), WAM2NEMO%NSWH(:,ICHNK), & & WAM2NEMO%NMWP(:,ICHNK), WAM2NEMO%NEMOTAUX(:,ICHNK), WAM2NEMO%NEMOTAUY(:,ICHNK), & diff --git a/src/ecwam/sinflx.F90 b/src/ecwam/sinflx.F90 index a069384a0..66fdd5327 100644 --- a/src/ecwam/sinflx.F90 +++ b/src/ecwam/sinflx.F90 @@ -16,7 +16,7 @@ SUBROUTINE SINFLX (ICALL, NCALL, KIJS, KIJL, & & COSWDIF, SINWDIF2, & & FMEAN, HALP, FMEANWS, & & FLM, & - & UFRIC, UPROXY, TAUW, TAUWDIR, & + & UFRIC, TAUW, TAUWDIR, & & Z0M, Z0B, CHRNCK, PHIWA, & & FLD, SL, SPOS, & & MIJ, RHOWGDFTH, XLLWS) @@ -68,7 +68,6 @@ SUBROUTINE SINFLX (ICALL, NCALL, KIJS, KIJL, & REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(OUT) :: FMEANWS !! MEAN FREQUENCY OF THE WINDSEA. REAL(KIND=JWRB), DIMENSION(KIJL,NANG), INTENT(IN) :: FLM !! SPECTAL DENSITY MINIMUM VALUE REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: UFRIC !! FRICTION VELOCITY IN M/S. -REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: UPROXY !! FRICTION VELOCITY IN M/S. REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: TAUW !! WAVE STRESS IN (M/S)**2 REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: TAUWDIR !! WAVE STRESS DIRECTION. REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: Z0M !! ROUGHNESS LENGTH IN M. @@ -124,7 +123,7 @@ SUBROUTINE SINFLX (ICALL, NCALL, KIJS, KIJL, & & COSWDIF, SINWDIF2, & & FMEAN, HALP, FMEANWS, & & FLM, & - & UFRIC, UPROXY, TAUW, TAUWDIR, & + & UFRIC, TAUW, TAUWDIR, & & Z0M, Z0B, CHRNCK, PHIWA, & & FLD, SL, SPOS, & & MIJ, RHOWGDFTH, XLLWS) diff --git a/src/ecwam/sinflx_zbry.F90 b/src/ecwam/sinflx_zbry.F90 index 84096dcd7..b5c2ccf4c 100644 --- a/src/ecwam/sinflx_zbry.F90 +++ b/src/ecwam/sinflx_zbry.F90 @@ -16,7 +16,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & & COSWDIF, SINWDIF2, & & FMEAN, HALP, FMEANWS, & & FLM, & - & UFRIC, UPROXY, TAUW, TAUWDIR, & + & UFRIC, TAUW, TAUWDIR, & & Z0M, Z0B, CHRNCK, PHIWA, & & FLD, SL, SPOS, & & MIJ, RHOWGDFTH, XLLWS) @@ -151,7 +151,6 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(OUT) :: FMEANWS !! MEAN FREQUENCY OF THE WINDSEA. REAL(KIND=JWRB), DIMENSION(KIJL,NANG), INTENT(IN) :: FLM !! SPECTAL DENSITY MINIMUM VALUE REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: UFRIC !! FRICTION VELOCITY IN M/S. -REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: UPROXY !! FRICTION VELOCITY IN M/S. REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: TAUW !! WAVE STRESS IN (M/S)**2 REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: TAUWDIR !! WAVE STRESS DIRECTION. REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: Z0M !! ROUGHNESS LENGTH IN M. @@ -222,7 +221,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & ! For GUSTINESS REAL(KIND=JWRB) :: AVG_GST -REAL(KIND=JWRB), DIMENSION(KIJL) :: SIG_N, SIG_U10, TAUWGST_AVG, TAUWDIRGST_AVG, USTARGST_AVG, UPROXYGST_AVG +REAL(KIND=JWRB), DIMENSION(KIJL) :: SIG_N, SIG_U10, TAUWGST_AVG, TAUWDIRGST_AVG, USTARGST_AVG REAL(KIND=JWRB), DIMENSION(KIJL,NGST) :: TAUWGST, TAUWDIRGST, UABSGST, USTARGST, Z0GST ! REAL(KIND=JWRB), DIMENSION(KIJL,NGST) :: TAUNWGST REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE) :: SLGST_AVG, SPOSGST_AVG, FLGST_AVG @@ -570,7 +569,6 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & TAUWDIRGST_AVG(IJ) = TAUWDIRGST(IJ,IGST) ! TAUNWGST_AVG(IJ) = TAUNWGST(IJ,IGST) USTARGST_AVG(IJ) = USTARGST(IJ,IGST) - UPROXYGST_AVG(IJ) = UPROXYGST(IJ,IGST) SLGST_AVG(IJ,:,:) = SLGST(IJ,:,:,IGST) SPOSGST_AVG(IJ,:,:) = SPOSGST(IJ,:,:,IGST) FLGST_AVG(IJ,:,:) = FLGST(IJ,:,:,IGST) @@ -581,7 +579,6 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & TAUWDIRGST_AVG(IJ) = TAUWDIRGST_AVG(IJ) + TAUWDIRGST(IJ,IGST) ! TAUNWGST_AVG(IJ) = TAUNWGST_AVG(IJ) + TAUNWGST(IJ,IGST) USTARGST_AVG(IJ) = USTARGST_AVG(IJ) + USTARGST(IJ,IGST) - UPROXYGST_AVG(IJ) = UPROXYGST_AVG(IJ) + UPROXYGST(IJ,IGST) SLGST_AVG(IJ,:,:) = SLGST_AVG(IJ,:,:) + SLGST(IJ,:,:,IGST) SPOSGST_AVG(IJ,:,:) = SPOSGST_AVG(IJ,:,:) + SPOSGST(IJ,:,:,IGST) FLGST_AVG(IJ,:,:) = FLGST_AVG(IJ,:,:) + FLGST(IJ,:,:,IGST) @@ -593,7 +590,6 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & TAUWDIR(IJ) = AVG_GST*TAUWDIRGST_AVG(IJ) ! TAUNW(IJ) = AVG_GST*TAUNWGST_AVG(IJ) UFRIC(IJ) = AVG_GST*USTARGST_AVG(IJ) - UPROXY(IJ) = AVG_GST*UPROXYGST_AVG(IJ) SL(IJ,:,:) = AVG_GST*SLGST_AVG(IJ,:,:) SPOS(IJ,:,:) = AVG_GST*SPOSGST_AVG(IJ,:,:) FLD(IJ,:,:) = AVG_GST*FLGST_AVG(IJ,:,:) diff --git a/src/ecwam/wamintgr.F90 b/src/ecwam/wamintgr.F90 index 8d3e9ef5b..ac1cf6041 100644 --- a/src/ecwam/wamintgr.F90 +++ b/src/ecwam/wamintgr.F90 @@ -139,7 +139,7 @@ SUBROUTINE WAMINTGR (CDTPRA, CDATE, CDATEWH, CDTIMP, CDTIMPNEXT, & & INTFLDS%TAUXD(:,ICHNK), INTFLDS%TAUYD(:,ICHNK), INTFLDS%TAUOCXD(:,ICHNK), & & INTFLDS%TAUOCYD(:,ICHNK), INTFLDS%TAUOC(:,ICHNK), & & INTFLDS%TAUICX(:,ICHNK), INTFLDS%TAUICY(:,ICHNK), INTFLDS%PHIOCD(:,ICHNK), & - & INTFLDS%PHIEPS(:,ICHNK), INTFLDS%PHIAW(:,ICHNK), INTFLDS%UPROXY(:,ICHNK), & + & INTFLDS%PHIEPS(:,ICHNK), INTFLDS%PHIAW(:,ICHNK), & & MIJ%PTR(:,ICHNK), VARS_4D%XLLWS(:,:,:,ICHNK) ) ENDDO diff --git a/src/ecwam/wamintgr_loki_gpu.F90 b/src/ecwam/wamintgr_loki_gpu.F90 index 4237185b1..2c139b197 100644 --- a/src/ecwam/wamintgr_loki_gpu.F90 +++ b/src/ecwam/wamintgr_loki_gpu.F90 @@ -184,7 +184,7 @@ SUBROUTINE WAMINTGR_LOKI_GPU(CDTPRA, CDATE, CDATEWH, CDTIMP, CDTIMPNEXT, & & INTFLDS%TAUXD(:,ICHNK), INTFLDS%TAUYD(:,ICHNK), INTFLDS%TAUOCXD(:,ICHNK), & & INTFLDS%TAUOCYD(:,ICHNK), INTFLDS%TAUOC(:,ICHNK), & & INTFLDS%TAUICX(:,ICHNK), INTFLDS%TAUICY(:,ICHNK), INTFLDS%PHIOCD(:,ICHNK), & - & INTFLDS%PHIEPS(:,ICHNK), INTFLDS%PHIAW(:,ICHNK), INTFLDS%UPROXY(:,ICHNK), & + & INTFLDS%PHIEPS(:,ICHNK), INTFLDS%PHIAW(:,ICHNK), & & MIJ%PTR(:,ICHNK), VARS_4D%XLLWS(:,:,:,ICHNK) ) END DO diff --git a/src/ecwam/wdfluxes.F90 b/src/ecwam/wdfluxes.F90 index e18cc1c7a..dd2310d42 100644 --- a/src/ecwam/wdfluxes.F90 +++ b/src/ecwam/wdfluxes.F90 @@ -23,7 +23,7 @@ SUBROUTINE WDFLUXES (KIJS, KIJL, & & USTOKES, VSTOKES, STRNMS, & & TAUXD, TAUYD, TAUOCXD, & & TAUOCYD, TAUOC, TAUICX, TAUICY, & - & PHIOCD, PHIEPS, PHIAW, UPROXY, & + & PHIOCD, PHIEPS, PHIAW, & & NEMOUSTOKES, NEMOVSTOKES, NEMOSTRN, & & NPHIEPS, NTAUOC, NSWH, & & NMWP,NEMOTAUX, NEMOTAUY, & @@ -107,7 +107,7 @@ SUBROUTINE WDFLUXES (KIJS, KIJL, & REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: AIRD, WSTAR REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: USTRA, VSTRA REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: CICOVER - REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: UFRIC, UPROXY, Z0M, Z0B, CHRNCK, CITHICK + REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: UFRIC, Z0M, Z0B, CHRNCK, CITHICK REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: TAUXD, TAUYD, TAUOCXD, TAUOCYD, TAUOC REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: TAUICX, TAUICY REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: PHIOCD, PHIEPS, PHIAW, USTOKES, VSTOKES @@ -209,7 +209,7 @@ SUBROUTINE WDFLUXES (KIJS, KIJL, & & COSWDIF, SINWDIF2, & & FMEAN, HALP, FMEANWS, & & FLM, & - & UFRIC, UPROXY, TAUW_LOC, TAUWDIR_LOC, & + & UFRIC, TAUW_LOC, TAUWDIR_LOC, & & Z0M, Z0B, CHRNCK, PHIWA, & & FLD, SL, SPOS, & & MIJ, RHOWGDFTH, XLLWS) diff --git a/src/ecwam/yowdrvtype_config.yml b/src/ecwam/yowdrvtype_config.yml index 8a11e8ec7..011089c3c 100644 --- a/src/ecwam/yowdrvtype_config.yml +++ b/src/ecwam/yowdrvtype_config.yml @@ -31,7 +31,7 @@ objtypes: intgt_param_fields: rank: 2 types: [real] - vars: [[wsemean, wsfmean, ustokes, vstokes, phieps, phiocd, phiaw, uproxy, tauoc, tauxd, tauyd, + vars: [[wsemean, wsfmean, ustokes, vstokes, phieps, phiocd, phiaw, tauoc, tauxd, tauyd, tauocxd, tauocyd, tauicx, tauicy, strnms, altwh, caltwh, raltcor]] wvgridglo: rank: 1 diff --git a/tests/etopo1_oper_an_fc_O48_cy50r1_zbry.yml b/tests/etopo1_oper_an_fc_O48_cy50r1_zbry.yml index 68566a74d..afcb0e517 100644 --- a/tests/etopo1_oper_an_fc_O48_cy50r1_zbry.yml +++ b/tests/etopo1_oper_an_fc_O48_cy50r1_zbry.yml @@ -52,7 +52,6 @@ output: - '076' # vtauo - '039' # phioc - '077' # wphio - - '081' # uproxy format: grib # (default : grib) or binary at: - timestep: 01:00 From 37d2a24a296f606cfabc5f57c262658a501bfb3e Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Wed, 29 Oct 2025 13:00:06 +0000 Subject: [PATCH 61/89] more fixes lfactor_wvei, still broken --- src/ecwam/lfactor_wvei.F90 | 78 ++++++++++++++++++++------------------ 1 file changed, 42 insertions(+), 36 deletions(-) diff --git a/src/ecwam/lfactor_wvei.F90 b/src/ecwam/lfactor_wvei.F90 index 4cd92a3ad..04813d63d 100644 --- a/src/ecwam/lfactor_wvei.F90 +++ b/src/ecwam/lfactor_wvei.F90 @@ -118,7 +118,7 @@ SUBROUTINE LFACTORXY(S, CINV, U10, USTAR, UPROXY, USDIR, ROAIRN, & REAL(KIND=JWRB) :: RTAU, DRTAU, ERR LOGICAL :: OVERSHOT - LOGICAL :: LLFRQHF + LOGICAL :: LLFRQMF INTEGER(KIND=JWIM) :: IK, ITH, M, SIGN_NEW, SIGN_OLD INTEGER(KIND=JWIM) :: NK, NTH, NSPEC !num. of freqs, dirs, spec. bins @@ -136,13 +136,6 @@ SUBROUTINE LFACTORXY(S, CINV, U10, USTAR, UPROXY, USDIR, ROAIRN, & NSPEC = NK * NTH ! NUMBER OF SPECTRAL BINS FRQMID = MIN(FRQMAX,G/(ZPI*UPROXY)) ! dynamic cutoff frequency, capped at FRQMAX - - ! Determines if we need special treatment for some of the high frequencies to account for LFAC - IF (FRQMID>FR(NFRE)) THEN - LLFRQHF = .TRUE. - ELSE - LLFRQHF = .FALSE. - END IF ITHN = IRANGE(1,NTH,1) ! Index vector 1:NTH DO IK = 1, NK @@ -184,9 +177,9 @@ SUBROUTINE LFACTORXY(S, CINV, U10, USTAR, UPROXY, USDIR, ROAIRN, & ! integral collapses into easy analytic solution ! ! - ! Th=2pi,ω=ZPI*FRQMID + ! Th=2pi,ω=ZPI*FRQMAX ! / / - ! | | S(f,Th)/c df dTh = (LOG(ZPI*FRQMID) - LOG(SIG(NFRE))) * SIG(NFRE)**2 * DELTH * SUM(S(:,NFRE)) * ZPI * GM1 + ! | | S(f,Th)/c df dTh = (LOG(ZPI*FRQMAX) - LOG(SIG(NFRE))) * SIG(NFRE)**2 * DELTH * SUM(S(:,NFRE)) * ZPI * GM1 ! / / ! Th=0,ω=SIG(NFRE) ! @@ -208,9 +201,9 @@ SUBROUTINE LFACTORXY(S, CINV, U10, USTAR, UPROXY, USDIR, ROAIRN, & TAUWX = TAUWX_LF + TAUWX_MF_HF TAUWY = TAUWY_LF + TAUWY_MF_HF - ! WRITE (*,*) ' ' - ! WRITE (*,*) ' TAUWX_LF ',TAUWX_LF - ! WRITE (*,*) ' TAUWX_MF_HF ',TAUWX_MF_HF + WRITE (*,*) '!/ ----- PRE LFAC ----- / ' + WRITE (*,*) ' TAUWX_LF ',TAUWX_LF + WRITE (*,*) ' TAUWX_MF_HF ',TAUWX_MF_HF !/ ----------------------------------------------------------------- / !/ ----------------------------------------------------------------- / @@ -247,16 +240,22 @@ SUBROUTINE LFACTORXY(S, CINV, U10, USTAR, UPROXY, USDIR, ROAIRN, & LF = 1.0_JWRB IK = 0 - IF (LLFRQHF) THEN - ! mid frequency contributions (from FR(NFRE) to FRQMID) + ! Determines if we need special treatment for some of the high frequencies to account for LFAC + IF (FRQMID>FR(NFRE)) THEN + ! cut off falls between FR(NFRE) and FRQMAX, therefore have to use 3 solution branches (LF + MF + HF) + LLFRQMF = .TRUE. + + ! mid frequency (MF) contributions, FR(NFRE) Date: Wed, 29 Oct 2025 15:00:46 +0000 Subject: [PATCH 62/89] update to use angular frequency everywhere --- src/ecwam/lfactor_wvei.F90 | 61 +++++++++++++++++++------------------- 1 file changed, 31 insertions(+), 30 deletions(-) diff --git a/src/ecwam/lfactor_wvei.F90 b/src/ecwam/lfactor_wvei.F90 index 04813d63d..f2c86f55c 100644 --- a/src/ecwam/lfactor_wvei.F90 +++ b/src/ecwam/lfactor_wvei.F90 @@ -109,7 +109,7 @@ SUBROUTINE LFACTORXY(S, CINV, U10, USTAR, UPROXY, USDIR, ROAIRN, & REAL(KIND=JWRB) :: SDENSX_MF, SDENSY_MF REAL(KIND=JWRB) :: TAUWX_LF, TAUWY_LF, TAUWX_MF_HF, TAUWY_MF_HF REAL(KIND=JWRB) :: TAUWX_HF, TAUWY_HF - REAL(KIND=JWRB) :: ZA_EXP, ZWVEI, FRQMID + REAL(KIND=JWRB) :: ZA_EXP, ZWVEI, FRQMID, FRQMAXOM REAL(KIND=JWRB) :: TAU_TOT, TAU_VIS, TAU_WAV REAL(KIND=JWRB) :: TAUVX, TAUVY, TAUX, TAUY @@ -135,7 +135,8 @@ SUBROUTINE LFACTORXY(S, CINV, U10, USTAR, UPROXY, USDIR, ROAIRN, & NK = NFRE ! NUMBER OF FREQS, SAME AS ML NSPEC = NK * NTH ! NUMBER OF SPECTRAL BINS - FRQMID = MIN(FRQMAX,G/(ZPI*UPROXY)) ! dynamic cutoff frequency, capped at FRQMAX + FRQMAXOM = ZPI * FRQMAX ! max angular frequency corresponding to FRQMAX in Hz + FRQMIDOM = MIN(FRQMAXOM,G/UPROXY) ! dynamic cutoff frequency, capped at FRQMAX ITHN = IRANGE(1,NTH,1) ! Index vector 1:NTH DO IK = 1, NK @@ -153,11 +154,11 @@ SUBROUTINE LFACTORXY(S, CINV, U10, USTAR, UPROXY, USDIR, ROAIRN, & !/ 0) --- split integral into low/high frequency contributions ------------- / ! ! - ! Th=2pi,f=inf Th=2pi,f=FR(NFRE) Th=2pi,f=inf + ! Th=2pi,ω=inf Th=2pi,ω=SIG(NFRE) Th=2pi,ω=inf ! / / / / / / ! | | S(f,Th)/c df dTh = | | S(f,Th)/c df dTh + | | S(f,Th)/c df dTh ! / / / / / / - ! Th=0,f=0 Th=0,f=0 Th=0,f=FR(NFRE) + ! Th=0,ω=0 Th=0,ω=0 Th=0,ω=SIG(NFRE) ! ! ! = LF_contribution + HF_contribution @@ -179,7 +180,7 @@ SUBROUTINE LFACTORXY(S, CINV, U10, USTAR, UPROXY, USDIR, ROAIRN, & ! ! Th=2pi,ω=ZPI*FRQMAX ! / / - ! | | S(f,Th)/c df dTh = (LOG(ZPI*FRQMAX) - LOG(SIG(NFRE))) * SIG(NFRE)**2 * DELTH * SUM(S(:,NFRE)) * ZPI * GM1 + ! | | S(f,Th)/c df dTh = (LOG(ZPI*FRQMAX) - LOG(SIG(NFRE))) * SIG(NFRE)**2 * DELTH * SUM(S(:,NFRE)) * GM1 ! / / ! Th=0,ω=SIG(NFRE) ! @@ -191,8 +192,8 @@ SUBROUTINE LFACTORXY(S, CINV, U10, USTAR, UPROXY, USDIR, ROAIRN, & ZA_SY = SY(:,NFRE) ! mid + high frequency contributions - SDENSX_MF_HF = ZPI * GM1 * SIG(NFRE)**2 * (LOG(ZPI*FRQMAX) - LOG(SIG(NFRE))) * DELTH * SUM(ZA_SX) - SDENSY_MF_HF = ZPI * GM1 * SIG(NFRE)**2 * (LOG(ZPI*FRQMAX) - LOG(SIG(NFRE))) * DELTH * SUM(ZA_SY) + SDENSX_MF_HF = GM1 * SIG(NFRE)**2 * (LOG(FRQMAXOM) - LOG(SIG(NFRE))) * DELTH * SUM(ZA_SX) + SDENSY_MF_HF = GM1 * SIG(NFRE)**2 * (LOG(FRQMAXOM) - LOG(SIG(NFRE))) * DELTH * SUM(ZA_SY) TAUWX_MF_HF = G * ROWATER * ( SDENSX_MF_HF ) TAUWY_MF_HF = G * ROWATER * ( SDENSY_MF_HF ) @@ -201,9 +202,9 @@ SUBROUTINE LFACTORXY(S, CINV, U10, USTAR, UPROXY, USDIR, ROAIRN, & TAUWX = TAUWX_LF + TAUWX_MF_HF TAUWY = TAUWY_LF + TAUWY_MF_HF - WRITE (*,*) '!/ ----- PRE LFAC ----- / ' - WRITE (*,*) ' TAUWX_LF ',TAUWX_LF - WRITE (*,*) ' TAUWX_MF_HF ',TAUWX_MF_HF + ! WRITE (*,*) '!/ ----- PRE LFAC ----- / ' + ! WRITE (*,*) ' TAUWX_LF ',TAUWX_LF + ! WRITE (*,*) ' TAUWX_MF_HF ',TAUWX_MF_HF !/ ----------------------------------------------------------------- / !/ ----------------------------------------------------------------- / @@ -241,18 +242,18 @@ SUBROUTINE LFACTORXY(S, CINV, U10, USTAR, UPROXY, USDIR, ROAIRN, & IK = 0 ! Determines if we need special treatment for some of the high frequencies to account for LFAC - IF (FRQMID>FR(NFRE)) THEN - ! cut off falls between FR(NFRE) and FRQMAX, therefore have to use 3 solution branches (LF + MF + HF) + IF (FRQMIDOM>SIG(NFRE)) THEN + ! cut off falls between SIG(NFRE) and FRQMAXOM, therefore have to use 3 solution branches (LF + MF + HF) LLFRQMF = .TRUE. - ! mid frequency (MF) contributions, FR(NFRE) Date: Wed, 29 Oct 2025 17:30:19 +0000 Subject: [PATCH 63/89] bugfix on DF --- src/ecwam/initmdl.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/ecwam/initmdl.F90 b/src/ecwam/initmdl.F90 index db629df49..120ea425f 100644 --- a/src/ecwam/initmdl.F90 +++ b/src/ecwam/initmdl.F90 @@ -512,7 +512,7 @@ SUBROUTINE INITMDL (NADV, & IF (.NOT.ALLOCATED(DSII)) ALLOCATE(DSII(NFRE)) IF (.NOT.ALLOCATED(SIGM1)) ALLOCATE(SIGM1(NFRE)) DO M=1,NFRE - DF(M) = FR(M)*( FRATIO - 1.0_JWRB ) + DF(M) = DFIM(M)/DELTH SIG(M) = ZPI*FR(M) DSII(M) = ZPI*DF(M) DDEN(M) = ZPI*DFIM(M)*SIG(M) From 8367a37a856781914fa56d94a6b5e9f3390702e6 Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Wed, 29 Oct 2025 18:15:58 +0000 Subject: [PATCH 64/89] define some constants that might be needed in the initialization of the model although theyre not used for IPHYS=2 --- src/ecwam/lfactor_wvei.F90 | 4 ++-- src/ecwam/setwavphys.F90 | 34 ++++++++++++++++++++++++++++++++++ 2 files changed, 36 insertions(+), 2 deletions(-) diff --git a/src/ecwam/lfactor_wvei.F90 b/src/ecwam/lfactor_wvei.F90 index f2c86f55c..2f66edf80 100644 --- a/src/ecwam/lfactor_wvei.F90 +++ b/src/ecwam/lfactor_wvei.F90 @@ -109,7 +109,7 @@ SUBROUTINE LFACTORXY(S, CINV, U10, USTAR, UPROXY, USDIR, ROAIRN, & REAL(KIND=JWRB) :: SDENSX_MF, SDENSY_MF REAL(KIND=JWRB) :: TAUWX_LF, TAUWY_LF, TAUWX_MF_HF, TAUWY_MF_HF REAL(KIND=JWRB) :: TAUWX_HF, TAUWY_HF - REAL(KIND=JWRB) :: ZA_EXP, ZWVEI, FRQMID, FRQMAXOM + REAL(KIND=JWRB) :: ZA_EXP, ZWVEI, FRQMIDOM, FRQMAXOM REAL(KIND=JWRB) :: TAU_TOT, TAU_VIS, TAU_WAV REAL(KIND=JWRB) :: TAUVX, TAUVY, TAUX, TAUY @@ -329,7 +329,7 @@ SUBROUTINE LFACTORXY(S, CINV, U10, USTAR, UPROXY, USDIR, ROAIRN, & RTAU = RTAU * (DRTAU**SIGN_NEW) - CALL ABORT1 + ! CALL ABORT1 IF (ABS(ERR) .LT. 1.54E-4_JWRB) EXIT diff --git a/src/ecwam/setwavphys.F90 b/src/ecwam/setwavphys.F90 index 8513fb806..5a48c80ed 100644 --- a/src/ecwam/setwavphys.F90 +++ b/src/ecwam/setwavphys.F90 @@ -206,6 +206,40 @@ SUBROUTINE SETWAVPHYS ELSE IF (IPHYS.EQ.2) THEN + ! ---------------------------------------------------------------------- + ! ---------------------------------------------------------------------- + ! ---------------------------------------------------------------------- + ! Not used in IPHYS=2, but some needed to make sure code compiles/runs (also TODO for FRQMAX for IPHYS=0,1) + ZALP = 0.008_JWRB + ANG_GC_A = 0.35_JWRB + ANG_GC_B = 0.65_JWRB + ANG_GC_C = 3.0_JWRB + RN1_RN = 0.25_JWRB + + DELTA_THETA_RN = 0.75_JWRB + DTHRN_A = 0.60_JWRB + DTHRN_U = 200.0_JWRB ! i.e. not used + + Z0TUBMAX = 0.0005_JWRB + Z0RAT = 0.04_JWRB + SWELLF4 = 1.5E05_JWRB + SWELLF7 = 3.6E05_JWRB + SWELLF7M1 = 1.0_JWRB/SWELLF7 + + SSDSC5 = 0.0_JWRB + + BETAMAX = 1.39_JWRB + TAUWSHELTER = 0.0_JWRB + ALPHAMIN = 0.0005_JWRB + CHNKMIN_U = 30._JWRB + BETAMAX = 1.40_JWRB + TAUWSHELTER = 0.25_JWRB + ALPHAMIN = 0.0001_JWRB + CHNKMIN_U = 33._JWRB + ! ---------------------------------------------------------------------- + ! ---------------------------------------------------------------------- + ! ---------------------------------------------------------------------- + !!! EMPIRICAL CONSTANCE FOR SPECTRAL UPDATE FOLLOWING DATA ASSIMILATION ! TODO: THESE WILL REQUIRE RECALIBRATION IF USING W. DATA ASSIMILATION EGRCRV = 1065.0_JWRB From e837ffc00126366c29de30366280bb3cdedc1e4f Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Fri, 31 Oct 2025 11:02:39 +0000 Subject: [PATCH 65/89] set NGST=1 for all IPHYS2_AIRSEA for clean testing --- src/ecwam/setwavphys.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/ecwam/setwavphys.F90 b/src/ecwam/setwavphys.F90 index 5a48c80ed..234fdd544 100644 --- a/src/ecwam/setwavphys.F90 +++ b/src/ecwam/setwavphys.F90 @@ -260,7 +260,8 @@ SUBROUTINE SETWAVPHYS TAILFACTOR=6.0_JWRB ! SIN6FC = 6.0 from WW3-ST6 TAILFACTOR_PM=4.0_JWRB ! FXPM = 4.0 from WW3 (all) CASE(2,3) - NGST=2 + ! NGST=2 ! intend to use this later + NGST=1 ! keep NGST=1 for clean comparison ALPHAPMAX = 0.031_JWRB ! cap on spectral steepness as in ARD TAILFACTOR=2.5_JWRB TAILFACTOR_PM=3.0_JWRB ! as in ARD From f2479a03b670694d65aab5130841092b28e1cf59 Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Sun, 2 Nov 2025 19:14:10 +0000 Subject: [PATCH 66/89] should use WN2 instead of WAVNUM for operations with D --- src/ecwam/sinflx_zbry.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/ecwam/sinflx_zbry.F90 b/src/ecwam/sinflx_zbry.F90 index b5c2ccf4c..ecb534ebe 100644 --- a/src/ecwam/sinflx_zbry.F90 +++ b/src/ecwam/sinflx_zbry.F90 @@ -451,7 +451,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & ! IF (LLLOWWINDS .AND. UABSGST(IJ,IGST)<=1.5_JWRB) THEN ! Reduce growth rates for low winds (following Muhammad Yasrab's work) - D(IJ,:,IGST) = D(IJ,:,IGST) - (4._JWRB*(RNU_WATER)*(WAVNUM(IJ,:)**2)) + D(IJ,:,IGST) = D(IJ,:,IGST) - (4._JWRB*(RNU_WATER)*(WN2(IJ,:)**2)) S(IJ,:,IGST) = D(IJ,:,IGST) * A(IJ,:) ELSE ! Update spectrum as per normal From fcedff72e160a556ae566f75fd6c0bade8731963 Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Sun, 2 Nov 2025 19:08:12 +0000 Subject: [PATCH 67/89] ZCDFAC pass in thru nml --- src/ecwam/airsea_zbry.F90 | 6 +++--- src/ecwam/lfactor.F90 | 1 - src/ecwam/lfactor_ext.F90 | 1 - src/ecwam/lfactor_wvei.F90 | 2 +- src/ecwam/mpuserin.F90 | 5 +++-- src/ecwam/outbeta.F90 | 2 +- src/ecwam/setwavphys.F90 | 3 +-- src/ecwam/sinflx_zbry.F90 | 8 ++++---- src/ecwam/userin.F90 | 6 +++--- src/ecwam/yowphys.F90 | 3 --- src/ecwam/yowstat.F90 | 4 +++- 11 files changed, 19 insertions(+), 22 deletions(-) diff --git a/src/ecwam/airsea_zbry.F90 b/src/ecwam/airsea_zbry.F90 index 3f7f4f48a..8d48ab959 100644 --- a/src/ecwam/airsea_zbry.F90 +++ b/src/ecwam/airsea_zbry.F90 @@ -53,8 +53,8 @@ SUBROUTINE AIRSEA_ZBRY (KIJS, KIJL, & USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU USE YOWPARAM, ONLY : NANG ,NFRE - USE YOWPHYS, ONLY : XKAPPA, XNLEV, CDFAC - USE YOWSTAT, ONLY : IPHYS2_AIRSEA + USE YOWPHYS, ONLY : XKAPPA, XNLEV + USE YOWSTAT, ONLY : IPHYS2_AIRSEA, ZCDFAC USE YOWPCONS, ONLY : G USE YOWTEST, ONLY : IU06 USE YOWWIND, ONLY : WSPMIN @@ -120,7 +120,7 @@ SUBROUTINE AIRSEA_ZBRY (KIJS, KIJL, & ! implementation of Hwang (2011) as in ST6 CASE(0,1) ! IPHYS2_AIRSEA=0,1 use Hwang (2011) as in ST6 - FLX4A0 = CDFAC + FLX4A0 = ZCDFAC DO IJ=KIJS,KIJL IF (U10(IJ) .GE. 50.33_JWRB) THEN US(IJ) = 2.026_JWRB * SQRT(FLX4A0) diff --git a/src/ecwam/lfactor.F90 b/src/ecwam/lfactor.F90 index 06dcb1f46..7debd45b6 100644 --- a/src/ecwam/lfactor.F90 +++ b/src/ecwam/lfactor.F90 @@ -77,7 +77,6 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, UPROXY, USDIR, ROAIRN, & & DF ,NFRE_EXT ,DSII_EXT ,SIG_EXT USE YOWPARAM , ONLY : NANG ,NFRE USE YOWPCONS , ONLY : G ,ZPI ,ROWATER ,EPSMIN, GM1 - USE YOWPHYS , ONLY : CDFAC USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK ! ---------------------------------------------------------------------- diff --git a/src/ecwam/lfactor_ext.F90 b/src/ecwam/lfactor_ext.F90 index a32d5b1ce..0dc1a9f63 100644 --- a/src/ecwam/lfactor_ext.F90 +++ b/src/ecwam/lfactor_ext.F90 @@ -77,7 +77,6 @@ SUBROUTINE LFACTORXX(S, CINV, U10, USTAR, UPROXY, USDIR, ROAIRN, & & DF ,NFRE_EXT ,DSII_EXT ,SIG_EXT USE YOWPARAM , ONLY : NANG ,NFRE USE YOWPCONS , ONLY : G ,ZPI ,ROWATER ,EPSMIN, GM1 - USE YOWPHYS , ONLY : CDFAC USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK ! ---------------------------------------------------------------------- diff --git a/src/ecwam/lfactor_wvei.F90 b/src/ecwam/lfactor_wvei.F90 index 2f66edf80..98b966f4e 100644 --- a/src/ecwam/lfactor_wvei.F90 +++ b/src/ecwam/lfactor_wvei.F90 @@ -77,7 +77,7 @@ SUBROUTINE LFACTORXY(S, CINV, U10, USTAR, UPROXY, USDIR, ROAIRN, & & DF ,NFRE_EXT ,DSII_EXT ,SIG_EXT USE YOWPARAM , ONLY : NANG ,NFRE USE YOWPCONS , ONLY : G ,ZPI ,ROWATER ,EPSMIN, GM1 - USE YOWPHYS , ONLY : CDFAC ,FRQMAX + USE YOWPHYS , ONLY : FRQMAX USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK ! ---------------------------------------------------------------------- diff --git a/src/ecwam/mpuserin.F90 b/src/ecwam/mpuserin.F90 index 53f152d27..f7d3412f4 100644 --- a/src/ecwam/mpuserin.F90 +++ b/src/ecwam/mpuserin.F90 @@ -98,7 +98,7 @@ SUBROUTINE MPUSERIN & IDELWO ,IDELALT ,IREST ,IDELRES ,IDELINT , & & IDELBC , & & ICASE ,ISHALLO , & - & IPHYS ,IPHYS2_AIRSEA,LLLOWWINDS, & + & IPHYS ,IPHYS2_AIRSEA,LLLOWWINDS ,ZCDFAC , & & ISNONLIN , & & IDAMPING , & & LBIWBK , & @@ -610,7 +610,8 @@ SUBROUTINE MPUSERIN ISHALLO = 0 !! depricated IPHYS = 1 IPHYS2_AIRSEA = 0 - LLLOWWINDS = .FALSE. ! .TRUE. if low winds are treated differently + LLLOWWINDS = .FALSE. + ZCDFAC = 1.5_JWRB ISNONLIN = 1 IDAMPING = 1 IPROPAGS = 0 diff --git a/src/ecwam/outbeta.F90 b/src/ecwam/outbeta.F90 index 69d1c2418..44dcdd982 100644 --- a/src/ecwam/outbeta.F90 +++ b/src/ecwam/outbeta.F90 @@ -68,7 +68,7 @@ SUBROUTINE OUTBETA (KIJS, KIJL, & USE YOWCOUP , ONLY : LLGCBZ0 USE YOWPCONS , ONLY : G , GM1, EPSUS - USE YOWPHYS , ONLY : XKAPPA, XNLEV, RNUM , PRCHAR, ALPHAMIN, ALPHAMAX, ALPHA, CDFAC + USE YOWPHYS , ONLY : XKAPPA, XNLEV, RNUM , PRCHAR, ALPHAMIN, ALPHAMAX, ALPHA USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK diff --git a/src/ecwam/setwavphys.F90 b/src/ecwam/setwavphys.F90 index 234fdd544..eaf4dce87 100644 --- a/src/ecwam/setwavphys.F90 +++ b/src/ecwam/setwavphys.F90 @@ -26,7 +26,7 @@ SUBROUTINE SETWAVPHYS & DELTA_THETA_RN, RN1_RN, DTHRN_A, DTHRN_U, & & ANG_GC_A, ANG_GC_B, ANG_GC_C, & & SWELLF4, SWELLF7, SWELLF7M1, Z0TUBMAX, Z0RAT, & - & SSDSC5, CDFAC, ZSIN6A0, LLSWL6CSTB1, ZSWL6B1, & + & SSDSC5, ZSIN6A0, LLSWL6CSTB1, ZSWL6B1, & & ZSDS6A1, ZSDS6A2, ISDS6P1, ISDS6P2, LLSDS6ET, & & NGST, FRQMAX, LLFACT @@ -276,7 +276,6 @@ SUBROUTINE SETWAVPHYS CALL ABORT1 END SELECT ALPHA = 0.0065_JWRB - CDFAC = 1.0_JWRB LLSDS6ET = .TRUE. ZSDS6A1 = 4.75E-6_JWRB ISDS6P1 = 4 diff --git a/src/ecwam/sinflx_zbry.F90 b/src/ecwam/sinflx_zbry.F90 index ecb534ebe..a36af6f82 100644 --- a/src/ecwam/sinflx_zbry.F90 +++ b/src/ecwam/sinflx_zbry.F90 @@ -104,11 +104,11 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & & RNU ,RNUM, & & SWELLF ,SWELLF2 ,SWELLF3 ,SWELLF4 , SWELLF5, & & SWELLF6 ,SWELLF7 ,SWELLF7M1, Z0RAT ,Z0TUBMAX , & - & ABMIN ,ABMAX, CDFAC, DTHRN_A ,DTHRN_U, RNU_WATER, & + & ABMIN ,ABMAX, DTHRN_A ,DTHRN_U, RNU_WATER, & & ZSIN6A0, FRQMAX, LLFACT USE YOWTEST , ONLY : IU06 USE YOWTABL , ONLY : IAB ,SWELLFT - USE YOWSTAT , ONLY : IPHYS2_AIRSEA, LLLOWWINDS + USE YOWSTAT , ONLY : IPHYS2_AIRSEA, LLLOWWINDS, ZCDFAC USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK @@ -380,12 +380,12 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & CASE(0,1,2) ! IPHYS2_AIRSEA=0,1,2 use USTAR DO IJ = KIJS,KIJL - UPROXYGST(IJ,IGST) = 32.0_JWRB * CDFAC * USTARGST(IJ,IGST) + UPROXYGST(IJ,IGST) = 32.0_JWRB * ZCDFAC * USTARGST(IJ,IGST) END DO CASE(3) ! IPHYS2_AIRSEA=3 is based on wind directly DO IJ = KIJS,KIJL - UPROXYGST(IJ,IGST) = UABSGST(IJ,IGST) * CDFAC ! because FRIC=1/sqrt(CD), then this turns to purely a wind dependence (USTARGST cancels out) + UPROXYGST(IJ,IGST) = UABSGST(IJ,IGST) * ZCDFAC ! because FRIC=1/sqrt(CD), then this turns to purely a wind dependence (USTARGST cancels out) ENDDO END SELECT END DO diff --git a/src/ecwam/userin.F90 b/src/ecwam/userin.F90 index 1f90ae7ed..90048bf74 100644 --- a/src/ecwam/userin.F90 +++ b/src/ecwam/userin.F90 @@ -121,7 +121,7 @@ SUBROUTINE USERIN (IFORCA, LWCUR) & CHNKMIN_U, CDIS ,DELTA_SDIS, CDISVIS, & & TAUWSHELTER, TAILFACTOR, TAILFACTOR_PM, & & DELTA_THETA_RN, DTHRN_A, DTHRN_U, & - & SWELLF4, SWELLF7, SSDSC5, CDFAC, & + & SWELLF4, SWELLF7, SSDSC5, & & ZSIN6A0, LLSWL6CSTB1, ZSWL6B1, & & ZSDS6A1, ZSDS6A2, ISDS6P1, ISDS6P2, LLSDS6ET USE YOWSHAL , ONLY : NDEPTH ,DEPTHA ,DEPTHD ,BATHYMAX @@ -144,7 +144,7 @@ SUBROUTINE USERIN (IFORCA, LWCUR) & LSMSSIG_WAM,CMETER ,CEVENT , & & LRELWIND , & & IDELWI_LST, IDELWO_LST, CDTW_LST, NDELW_LST, & - & LLLOWWINDS, IPHYS2_AIRSEA + & LLLOWWINDS, IPHYS2_AIRSEA, ZCDFAC USE YOWTEST , ONLY : IU06 USE YOWTEXT , ONLY : LRESTARTED,ICPLEN ,USERID ,RUNID , & & PATH ,CPATH ,CWI @@ -788,7 +788,7 @@ SUBROUTINE USERIN (IFORCA, LWCUR) WRITE(IU06,*) ' SSDSC5 = ....... ', SSDSC5 ELSEIF (IPHYS == 2) THEN WRITE(IU06,*) ' IPHYS2_AIRSEA = .', IPHYS2_AIRSEA - WRITE(IU06,*) ' CDFAC = ........ ', CDFAC + WRITE(IU06,*) ' ZCDFAC = ....... ', ZCDFAC WRITE(IU06,*) ' LLSDS6ET = ..... ', LLSDS6ET WRITE(IU06,*) ' ZSDS6A1 = ...... ', ZSDS6A1 WRITE(IU06,*) ' ISDS6P1 = ...... ', ISDS6P1 diff --git a/src/ecwam/yowphys.F90 b/src/ecwam/yowphys.F90 index c94c98d82..293b098a7 100644 --- a/src/ecwam/yowphys.F90 +++ b/src/ecwam/yowphys.F90 @@ -152,9 +152,6 @@ MODULE YOWPHYS ! ZBRY PHYS :: ! ========== - -! *CDFAC* PARAMETER FOR WIND INPUT FOR ZBRY PHYS. - REAL(KIND=JWRB) :: CDFAC ! *SIN6A0* PARAMETER FOR NEGATIVE WIND INPUT (a0) FOR ZBRY PHYS REAL(KIND=JWRB) :: ZSIN6A0 diff --git a/src/ecwam/yowstat.F90 b/src/ecwam/yowstat.F90 index 75fe02682..85835ce30 100644 --- a/src/ecwam/yowstat.F90 +++ b/src/ecwam/yowstat.F90 @@ -38,6 +38,7 @@ MODULE YOWSTAT INTEGER(KIND=JWIM) :: IFRELFMAX REAL(KIND=JWRB) :: DELPRO_LF + REAL(KIND=JWRB) :: ZCDFAC INTEGER(KIND=JWIM) :: IDELPRO INTEGER(KIND=JWIM) :: IDELT INTEGER(KIND=JWIM) :: IDELWI @@ -89,7 +90,6 @@ MODULE YOWSTAT LOGICAL :: LSMSSIG_WAM LOGICAL :: LUPDATE_GPU_GLOBALS = .TRUE. LOGICAL :: LUPDATE_GPU_GLOBALS_OUTBS = .TRUE. - LOGICAL :: IPHYS2_LOWWINDS LOGICAL :: LLLOWWINDS REAL(KIND=JWRB) :: TIME_PROPAG = 0._JWRB @@ -126,6 +126,7 @@ MODULE YOWSTAT ! *CDTINTT* CHAR*14 NEXT DATE TO WRITE INTEG. PARAMETERS. ! *IFRELFMAX* INTEGER FREQUENCY INDEX FOR THE LOW FREQUENCY WAVES (see DELPRO_LF below) +! *ZCDFAC* REAL PARAMETER FOR WIND INPUT FOR ZBRY PHYS. ! *DELPRO_LF* REAL TIMESTEP WAM PROPAGATION IN SECONDS FOR LOW FREQUENCY WAVES (can be fraction od seconds) ! FOR ALL WAVES WITH FREQUENCY <= FR(IFRELFMAX), IF IFRELFMAX>0 ! !!! this option is only possible when no refraction effects are used (IREFRA=0) @@ -225,6 +226,7 @@ MODULE YOWSTAT ! COMPUTED. ! *LNSESTART* LOGICAL IF TRUE INITIAL CONDITIONS WILL BE SET TO ! NOISE LEVEL. +! *LLLOWWINDS*LOGICAL IF TRUE LOW WINDS ARE TREATED DIFFERENTLY FOR IPHYS=2 ! *NLOCGRB* INTEGER LOCAL GRIB TABLE NUMBER. ! *NCONCENSUS*INTEGER ONLY USED IN THE CONTEXT OF MULTI-ANALYSIS ! ENSEMBLE FORECASTS. IT SPECIFIED WHETHER From 32acfea6ae073112b1ce01a0c19eeab72710628a Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Sun, 2 Nov 2025 21:17:09 +0000 Subject: [PATCH 68/89] add ZCDFAC to namelist --- src/ecwam/mpuserin.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/ecwam/mpuserin.F90 b/src/ecwam/mpuserin.F90 index f7d3412f4..ee197647c 100644 --- a/src/ecwam/mpuserin.F90 +++ b/src/ecwam/mpuserin.F90 @@ -231,7 +231,7 @@ SUBROUTINE MPUSERIN & LWCOUNORMS, LLNORMIFS2WAM, LLNORMWAM2IFS, LLNORMWAMOUT, & & LLNORMWAMOUT_GLOBAL, CNORMWAMOUT_FILE, & & LICERUN, LCIWA1, LCIWA2, LCIWA3, LCISCAL, & - & LICETH, ZALPFACB, ZALPFACX, ZALPWRS, ZIBRW_THRSH, & + & LICETH, ZALPFACB, ZALPFACX, ZALPWRS, ZCDFAC, ZIBRW_THRSH, & & LWVFLX_SNL, & & LWNEMOCOU, NEMOFRCO, & & LWNEMOCOUSEND, LWNEMOCOUSTK, LWNEMOCOUSTRN, LWNEMOCOUWRS, & From 29f6a97191b6527357b70728901e309d85ac3a09 Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Mon, 10 Nov 2025 14:17:03 +0000 Subject: [PATCH 69/89] default zcdfac=1.0 --- src/ecwam/mpuserin.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/ecwam/mpuserin.F90 b/src/ecwam/mpuserin.F90 index ee197647c..12af24535 100644 --- a/src/ecwam/mpuserin.F90 +++ b/src/ecwam/mpuserin.F90 @@ -611,7 +611,7 @@ SUBROUTINE MPUSERIN IPHYS = 1 IPHYS2_AIRSEA = 0 LLLOWWINDS = .FALSE. - ZCDFAC = 1.5_JWRB + ZCDFAC = 1.0_JWRB ISNONLIN = 1 IDAMPING = 1 IPROPAGS = 0 From 24647897385218eab15da378ed22d95469aab6d3 Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Fri, 14 Nov 2025 16:53:22 +0000 Subject: [PATCH 70/89] avoid duplication of kinematic viscosity of water --- src/ecwam/airsea_zbry.F90 | 2 +- src/ecwam/sinflx_zbry.F90 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/ecwam/airsea_zbry.F90 b/src/ecwam/airsea_zbry.F90 index 8d48ab959..3e1aef84e 100644 --- a/src/ecwam/airsea_zbry.F90 +++ b/src/ecwam/airsea_zbry.F90 @@ -77,7 +77,7 @@ SUBROUTINE AIRSEA_ZBRY (KIJS, KIJL, & REAL(KIND=JWRB) :: ZNLEV REAL(KIND=JWRB), PARAMETER :: RKAP = 0.4_JWRB - REAL(KIND=JWRB), PARAMETER :: ZRN=1.65E-6_JWRB ! effective kinematic viscosity (0.11*1.5e-5) + REAL(KIND=JWRB), PARAMETER :: ZRN=1.65E-6_JWRB ! effective kinematic viscosity (0.11*1.5e-5) ! TODO: use instead RNU_WATER ! for the ietrative scheme INTEGER(KIND=JWIM), PARAMETER :: NITER=15 diff --git a/src/ecwam/sinflx_zbry.F90 b/src/ecwam/sinflx_zbry.F90 index a36af6f82..37d49201a 100644 --- a/src/ecwam/sinflx_zbry.F90 +++ b/src/ecwam/sinflx_zbry.F90 @@ -199,7 +199,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & ! For USTAR, Z0, CHNK REAL(KIND=JWRB), DIMENSION(KIJL,NGST) :: TAU -REAL(KIND=JWRB), PARAMETER :: ZRN=1.65E-6_JWRB ! effective kinematic viscosity (0.11*1.5e-5) +REAL(KIND=JWRB), PARAMETER :: ZRN=1.65E-6_JWRB ! effective kinematic viscosity (0.11*1.5e-5) ! TODO: use instead RNU_WATER REAL(KIND=JWRB), PARAMETER :: RKAP = 0.4_JWRB REAL(KIND=JWRB) :: ZNLEV, Z0, KUOUST, USTM1, USTM2 REAL(KIND=JWRB), PARAMETER :: XEPS=0.00001_JWRB From 5cc7338b06536c38e0d59f864b76cf74a95bf6fd Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Fri, 14 Nov 2025 18:49:59 +0000 Subject: [PATCH 71/89] delete unnecessary Z0GST --- src/ecwam/sinflx_zbry.F90 | 13 +------------ 1 file changed, 1 insertion(+), 12 deletions(-) diff --git a/src/ecwam/sinflx_zbry.F90 b/src/ecwam/sinflx_zbry.F90 index 37d49201a..1361de59e 100644 --- a/src/ecwam/sinflx_zbry.F90 +++ b/src/ecwam/sinflx_zbry.F90 @@ -222,7 +222,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & ! For GUSTINESS REAL(KIND=JWRB) :: AVG_GST REAL(KIND=JWRB), DIMENSION(KIJL) :: SIG_N, SIG_U10, TAUWGST_AVG, TAUWDIRGST_AVG, USTARGST_AVG -REAL(KIND=JWRB), DIMENSION(KIJL,NGST) :: TAUWGST, TAUWDIRGST, UABSGST, USTARGST, Z0GST +REAL(KIND=JWRB), DIMENSION(KIJL,NGST) :: TAUWGST, TAUWDIRGST, UABSGST, USTARGST ! REAL(KIND=JWRB), DIMENSION(KIJL,NGST) :: TAUNWGST REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE) :: SLGST_AVG, SPOSGST_AVG, FLGST_AVG REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE,NGST) :: SLGST, SPOSGST, FLGST @@ -322,17 +322,6 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & ROAIRN(IJ) = RAORW(IJ)*ROWATER END DO -! Define Z0GST associated with USTARGST (as in airsea_zbry) -DO IGST=1,NGST - DO IJ=KIJS,KIJL - UST = USTARGST(IJ,IGST) - PCHAROG = MIN(CHNKOG(IJ),PCHARMAX/G) - Z0CH = PCHAROG*UST**2 - Z0VIS = ZRN/UST - Z0GST(IJ,IGST) = Z0CH+Z0VIS - ENDDO -ENDDO - !/ --- Main loop over LOC ----------------------------------- / DO K = 1, NANG From 519d1250ebd3cc705a4e964d74a9603327d3ca4d Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Mon, 9 Mar 2026 12:44:48 +0000 Subject: [PATCH 72/89] add a reasonable default Z0B to enable LWCOUHMF for ZBRY --- src/ecwam/airsea_zbry.F90 | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/ecwam/airsea_zbry.F90 b/src/ecwam/airsea_zbry.F90 index 3e1aef84e..13a4ecf65 100644 --- a/src/ecwam/airsea_zbry.F90 +++ b/src/ecwam/airsea_zbry.F90 @@ -53,7 +53,7 @@ SUBROUTINE AIRSEA_ZBRY (KIJS, KIJL, & USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU USE YOWPARAM, ONLY : NANG ,NFRE - USE YOWPHYS, ONLY : XKAPPA, XNLEV + USE YOWPHYS, ONLY : XKAPPA, XNLEV, ALPHA USE YOWSTAT, ONLY : IPHYS2_AIRSEA, ZCDFAC USE YOWPCONS, ONLY : G USE YOWTEST, ONLY : IU06 @@ -131,6 +131,8 @@ SUBROUTINE AIRSEA_ZBRY (KIJS, KIJL, & END IF ! Z0(IJ) = ZNLEV * EXP ( -0.4_JWRB / SQRT(CD) ) + Z0B(IJ) = ALPHA * (US(IJ)**2) / G ! background roughness: Charnock + ENDDO ! implementation of iterative scheme From 1799cb3680b46dc8b9d35c982dfe4ba251dae431 Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Fri, 24 Apr 2026 16:42:40 +0000 Subject: [PATCH 73/89] major restructure for ZBRY to homogenize with ecWAM --- src/ecwam/CMakeLists.txt | 1 - src/ecwam/initmdl.F90 | 3 +- src/ecwam/irange.F90 | 52 ------ src/ecwam/lfactor.F90 | 73 +++----- src/ecwam/lfactor_ext.F90 | 233 ------------------------ src/ecwam/lfactor_wvei.F90 | 344 ----------------------------------- src/ecwam/sdissip_zbry.F90 | 37 +--- src/ecwam/setwavphys.F90 | 24 +-- src/ecwam/sinflx.F90 | 4 + src/ecwam/sinflx_zbry.F90 | 106 ++++------- src/ecwam/swldissip_zbry.F90 | 36 +--- src/ecwam/tau_wave_atmos.F90 | 24 +-- src/ecwam/tauwinds.F90 | 2 - 13 files changed, 98 insertions(+), 841 deletions(-) delete mode 100644 src/ecwam/irange.F90 delete mode 100644 src/ecwam/lfactor_ext.F90 delete mode 100644 src/ecwam/lfactor_wvei.F90 diff --git a/src/ecwam/CMakeLists.txt b/src/ecwam/CMakeLists.txt index adb060fde..811a51afd 100644 --- a/src/ecwam/CMakeLists.txt +++ b/src/ecwam/CMakeLists.txt @@ -115,7 +115,6 @@ list( APPEND ecwam_srcs intrpolchk.F90 intspec.F90 inwgrib.F90 - irange.F90 iwam_get_unit.F90 jafu.F90 jonswap.F90 diff --git a/src/ecwam/initmdl.F90 b/src/ecwam/initmdl.F90 index 120ea425f..d1abc594f 100644 --- a/src/ecwam/initmdl.F90 +++ b/src/ecwam/initmdl.F90 @@ -248,7 +248,6 @@ SUBROUTINE INITMDL (NADV, & #include "initdpthflds.intfb.h" #include "initnemocpl.intfb.h" #include "iniwcst.intfb.h" -#include "irange.intfb.h" #include "iwam_get_unit.intfb.h" #include "mcout.intfb.h" #include "outstep0.intfb.h" @@ -522,7 +521,7 @@ SUBROUTINE INITMDL (NADV, & ! DETERMINE THE NUMBER OF FREQUENCIES TO EXTEND TO NFRE_EXT = CEILING(LOG(FRQMAX/FR(1))/LOG(FRATIO))+1 NFRE_EXT = MAX(NFRE,NFRE_EXT) - IFRE_EXT = REAL( IRANGE(1,NFRE_EXT,1) ) + IFRE_EXT(1:NFRE_EXT) = (/ (REAL(M, KIND=JWRB), M=1,NFRE_EXT) /) IF (.NOT.ALLOCATED(SIG_EXT)) ALLOCATE(SIG_EXT(NFRE_EXT)) IF (.NOT.ALLOCATED(DSII_EXT)) ALLOCATE(DSII_EXT(NFRE_EXT)) IF (NFRE .LT. NFRE_EXT) THEN diff --git a/src/ecwam/irange.F90 b/src/ecwam/irange.F90 deleted file mode 100644 index 9d94cd2d3..000000000 --- a/src/ecwam/irange.F90 +++ /dev/null @@ -1,52 +0,0 @@ -FUNCTION IRANGE(X0,X1,DX) RESULT(IX) - - ! ---------------------------------------------------------------------------- - ! - ! 1. Purpose : - ! - ! Generate a sequence of linear-spaced integer numbers. - ! Used for instance array addressing (indexing). - ! ---------------------------------------------------------------------------- - ! - ! INTERFACE VARIABLES. - ! -------------------- - - ! ORIGIN. - ! ---------- - ! Adapted from Babanin Young Donelan & Banner (ZBRY) physics - ! as implemented as ST6 in WAVEWATCH-III - ! WW3 module: W3SRC6MD - ! WW3 subroutine: IRANGE - ! Implementation into ECWAM DECEMBER 2021 by J. Kousal - - ! ---------------------------------------------------------------------------- - - USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU - USE YOMHOOK , ONLY : LHOOK ,DR_HOOK, JPHOOK - - ! ---------------------------------------------------------------------------- - - IMPLICIT NONE - - INTEGER(KIND=JWIM), INTENT(IN) :: X0, X1, DX - - INTEGER(KIND=JWIM), ALLOCATABLE :: IX(:) - INTEGER(KIND=JWIM) :: N, I - - REAL(KIND=JPHOOK) :: ZHOOK_HANDLE - - ! ---------------------------------------------------------------------------- - ! - - IF (LHOOK) CALL DR_HOOK('IRANGE',0,ZHOOK_HANDLE) - - N = INT(REAL(X1-X0)/REAL(DX))+1 - ALLOCATE(IX(N)) - DO I = 1, N - IX(I) = X0+ (I-1)*DX - END DO - - IF (LHOOK) CALL DR_HOOK('IRANGE',1,ZHOOK_HANDLE) - - END FUNCTION IRANGE - \ No newline at end of file diff --git a/src/ecwam/lfactor.F90 b/src/ecwam/lfactor.F90 index 7debd45b6..44573f901 100644 --- a/src/ecwam/lfactor.F90 +++ b/src/ecwam/lfactor.F90 @@ -59,14 +59,11 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, UPROXY, USDIR, ROAIRN, & ! EXTERNALS. ! ---------- ! TAUWINDS -! IRANGE ! ORIGIN. ! ---------- ! Adapted from Babanin Young Donelan & Banner (ZBRY) physics ! as implemented as ST6 in WAVEWATCH-III -! WW3 module: W3SRC6MD -! WW3 subroutine: LFACTOR ! Implementation into ECWAM DECEMBER 2021 by J. Kousal ! ---------------------------------------------------------------------- @@ -82,9 +79,7 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, UPROXY, USDIR, ROAIRN, & ! ---------------------------------------------------------------------- IMPLICIT NONE -#include "irange.intfb.h" #include "tauwinds.intfb.h" -#include "abort1.intfb.h" REAL(KIND=JWRB), DIMENSION(NANG,NFRE), INTENT(IN) :: S ! Sin(sigma) in [m2/rad-Hz] REAL(KIND=JWRB), DIMENSION(NFRE), INTENT(IN) :: CINV @@ -96,7 +91,6 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, UPROXY, USDIR, ROAIRN, & INTEGER(KIND=JWIM), PARAMETER :: ITERMAX = 80 ! Max. no. iterations ! to find numerical LFACT soln - REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: ECOS2, ESIN2 REAL(KIND=JWRB), DIMENSION(NFRE_EXT) :: LF_EXT, CINV_EXT REAL(KIND=JWRB), DIMENSION(NFRE_EXT) :: SDENS_EXT, SDENSX_EXT, SDENSY_EXT REAL(KIND=JWRB), DIMENSION(NFRE_EXT) :: UCINV_EXT @@ -106,12 +100,8 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, UPROXY, USDIR, ROAIRN, & REAL(KIND=JWRB) :: TAU_NND, TAU_INIT(2) REAL(KIND=JWRB) :: RTAU, DRTAU, ERR LOGICAL :: OVERSHOT - CHARACTER(LEN=23) :: IDTIME - INTEGER(KIND=JWIM) :: IK, ITH, M, SIGN_NEW, SIGN_OLD - INTEGER(KIND=JWIM) :: NK, NTH, NSPEC !num. of freqs, dirs, spec. bins - INTEGER(KIND=JWIM), DIMENSION(NANG) :: ITHN - INTEGER(KIND=JWIM), DIMENSION(NFRE) :: IKN + INTEGER(KIND=JWIM) :: IK, K, SIGN_NEW, SIGN_OLD REAL(KIND=JPHOOK) :: ZHOOK_HANDLE @@ -119,34 +109,36 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, UPROXY, USDIR, ROAIRN, & IF (LHOOK) CALL DR_HOOK('LFACTOR',0,ZHOOK_HANDLE) - NTH = NANG ! NUMBER OF DIRS , SAME AS KL - NK = NFRE ! NUMBER OF FREQS, SAME AS ML - NSPEC = NK * NTH ! NUMBER OF SPECTRAL BINS - - ITHN = IRANGE(1,NTH,1) ! Index vector 1:NTH - DO IK = 1, NK - ECOS2 (ITHN+(IK-1)*NTH) = COSTH - ESIN2 (ITHN+(IK-1)*NTH) = SINTH - END DO - !/ 1) --- Either extrapolate arrays up to 10Hz or use discrete spectral ! grid per se. Limit the constraint to the positive part of the ! wind input only. ---------------------------------------------- / IF (NFRE .LT. NFRE_EXT) THEN - CINV_EXT(1:NK) = CINV - SDENS_EXT(1:NK) = SUM(S,1) * DELTH - SDENSX_EXT(1:NK) = SUM(MAX(0.0_JWRB,S)*RESHAPE(ECOS2,(/NTH,NK/)),1) * DELTH - SDENSY_EXT(1:NK) = SUM(MAX(0.0_JWRB,S)*RESHAPE(ESIN2,(/NTH,NK/)),1) * DELTH - ! --- Spectral slope for S_IN(F) is proportional to F**(-2) ------ / - CINV_EXT(NK+1:NFRE_EXT) = SIG_EXT(NK+1:NFRE_EXT)*GM1 ! 1/c=σ/g - SDENS_EXT(NK+1:NFRE_EXT) = SDENS_EXT(NK) * (SIG_EXT(NK)/SIG_EXT(NK+1:NFRE_EXT))**2 - SDENSX_EXT(NK+1:NFRE_EXT) = SDENSX_EXT(NK) * (SIG_EXT(NK)/SIG_EXT(NK+1:NFRE_EXT))**2 - SDENSY_EXT(NK+1:NFRE_EXT) = SDENSY_EXT(NK) * (SIG_EXT(NK)/SIG_EXT(NK+1:NFRE_EXT))**2 + CINV_EXT(1:NFRE) = CINV + SDENS_EXT(1:NFRE) = SUM(S,1) * DELTH + SDENSX_EXT(1:NFRE) = 0.0_JWRB + SDENSY_EXT(1:NFRE) = 0.0_JWRB + DO K = 1, NANG + SDENSX_EXT(1:NFRE) = SDENSX_EXT(1:NFRE) + MAX(0.0_JWRB,S(K,1:NFRE))*COSTH(K) + SDENSY_EXT(1:NFRE) = SDENSY_EXT(1:NFRE) + MAX(0.0_JWRB,S(K,1:NFRE))*SINTH(K) + END DO + SDENSX_EXT(1:NFRE) = SDENSX_EXT(1:NFRE) * DELTH + SDENSY_EXT(1:NFRE) = SDENSY_EXT(1:NFRE) * DELTH +! --- Spectral slope for S_IN(F) is proportional to F**(-2) ------ / + CINV_EXT(NFRE+1:NFRE_EXT) = SIG_EXT(NFRE+1:NFRE_EXT)*GM1 ! 1/c=σ/g + SDENS_EXT(NFRE+1:NFRE_EXT) = SDENS_EXT(NFRE) * (SIG_EXT(NFRE)/SIG_EXT(NFRE+1:NFRE_EXT))**2 + SDENSX_EXT(NFRE+1:NFRE_EXT) = SDENSX_EXT(NFRE) * (SIG_EXT(NFRE)/SIG_EXT(NFRE+1:NFRE_EXT))**2 + SDENSY_EXT(NFRE+1:NFRE_EXT) = SDENSY_EXT(NFRE) * (SIG_EXT(NFRE)/SIG_EXT(NFRE+1:NFRE_EXT))**2 ELSE CINV_EXT = CINV - SDENS_EXT(1:NK) = SUM(S,1) * DELTH - SDENSX_EXT(1:NK) = SUM(MAX(0.0_JWRB,S)*RESHAPE(ECOS2,(/NTH,NK/)),1) * DELTH - SDENSY_EXT(1:NK) = SUM(MAX(0.0_JWRB,S)*RESHAPE(ESIN2,(/NTH,NK/)),1) * DELTH + SDENS_EXT(1:NFRE) = SUM(S,1) * DELTH + SDENSX_EXT(1:NFRE) = 0.0_JWRB + SDENSY_EXT(1:NFRE) = 0.0_JWRB + DO K = 1, NANG + SDENSX_EXT(1:NFRE) = SDENSX_EXT(1:NFRE) + MAX(0.0_JWRB,S(K,1:NFRE))*COSTH(K) + SDENSY_EXT(1:NFRE) = SDENSY_EXT(1:NFRE) + MAX(0.0_JWRB,S(K,1:NFRE))*SINTH(K) + END DO + SDENSX_EXT(1:NFRE) = SDENSX_EXT(1:NFRE) * DELTH + SDENSY_EXT(1:NFRE) = SDENSY_EXT(1:NFRE) * DELTH END IF ! !/ 2) --- Stress calculation ----------------------------------------- / @@ -156,7 +148,6 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, UPROXY, USDIR, ROAIRN, & ! --- The viscous stress and check that it does not exceed ! the total stress. ------------------------------------------ / TAU_VIS = MAX(0.0_JWRB, -5.0E-5_JWRB*U10 + 1.1E-3_JWRB) * U10**2 * ROAIRN -! TAU_VIS = MIN(0.9 * TAU_TOT, TAU_VIS) TAU_VIS = MIN(0.95_JWRB * TAU_TOT, TAU_VIS) ! TAUVX = TAU_VIS * COS(USDIR) @@ -165,9 +156,6 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, UPROXY, USDIR, ROAIRN, & ! --- The wave supported stress. --------------------------------- / TAUWX = TAUWINDS(SDENSX_EXT,CINV_EXT,DSII_EXT) ! normal stress (x-component) TAUWY = TAUWINDS(SDENSY_EXT,CINV_EXT,DSII_EXT) ! normal stress (y-component) - ! WRITE (*,*) ' ' - ! WRITE (*,*) ' TAUWX_LF ',TAUWINDS(SDENSX_EXT(1:NK),CINV_EXT(1:NK),DSII_EXT(1:NK)) - ! WRITE (*,*) ' TAUWX_MF_HF ',TAUWINDS(SDENSX_EXT(NK+1:NFRE_EXT),CINV_EXT(1:NK),DSII_EXT(NK+1:NFRE_EXT)) TAU_NND = TAUWINDS(SDENS_EXT, CINV_EXT,DSII_EXT) ! normal stress (non-directional) TAU_WAV = SQRT(TAUWX**2 + TAUWY**2) ! normal stress (magnitude) TAU_INIT = (/TAUWX,TAUWY/) ! unadjusted normal stress components @@ -179,7 +167,6 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, UPROXY, USDIR, ROAIRN, & ! !/ 3) --- Find reduced Sin(f) = L(f)*Sin(f) to satisfy our constraint !/ TAU <= TAU_TOT --------------------------------------------- / - !CALL STME21 ( TIME , IDTIME ) LF_EXT = 1.0_JWRB IK = 0 ! @@ -199,9 +186,6 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, UPROXY, USDIR, ROAIRN, & TAU_NND = TAUWINDS(SDENS_EXT *LF_EXT,CINV_EXT,DSII_EXT) TAUWX = TAUWINDS(SDENSX_EXT*LF_EXT,CINV_EXT,DSII_EXT) TAUWY = TAUWINDS(SDENSY_EXT*LF_EXT,CINV_EXT,DSII_EXT) - ! WRITE (*,*) ' ' - ! WRITE (*,*) ' TAUWX_LF ',TAUWINDS(SDENSX_EXT(1:NK)*LF_EXT(1:NK),CINV_EXT(1:NK),DSII_EXT(1:NK)) - ! WRITE (*,*) ' TAUWX_MF_HF ',TAUWINDS(SDENSX_EXT(NK+1:NFRE_EXT)*LF_EXT(NK+1:NFRE_EXT),CINV_EXT(1:NK),DSII_EXT(NK+1:NFRE_EXT)) TAU_WAV = SQRT(TAUWX**2 + TAUWY**2) TAUX = TAUVX + TAUWX TAUY = TAUVY + TAUWY @@ -215,10 +199,7 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, UPROXY, USDIR, ROAIRN, & IF (SIGN_NEW .NE. SIGN_OLD) OVERSHOT = .TRUE. IF (OVERSHOT) DRTAU = MAX(0.5_JWRB*(1.0_JWRB+DRTAU),1.00010_JWRB) - RTAU = RTAU * (DRTAU**SIGN_NEW) - - ! CALL ABORT1 - + RTAU = RTAU * (DRTAU**SIGN_NEW) IF (ABS(ERR) .LT. 1.54E-4_JWRB) EXIT @@ -226,7 +207,7 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, UPROXY, USDIR, ROAIRN, & END IF - LFACT(1:NK) = LF_EXT(1:NK) + LFACT(1:NFRE) = LF_EXT(1:NFRE) IF (LHOOK) CALL DR_HOOK('LFACTOR',1,ZHOOK_HANDLE) diff --git a/src/ecwam/lfactor_ext.F90 b/src/ecwam/lfactor_ext.F90 deleted file mode 100644 index 0dc1a9f63..000000000 --- a/src/ecwam/lfactor_ext.F90 +++ /dev/null @@ -1,233 +0,0 @@ -! (C) Copyright 1989- ECMWF. -! -! This software is licensed under the terms of the Apache Licence Version 2.0 -! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. -! In applying this licence, ECMWF does not waive the privileges and immunities -! granted to it by virtue of its status as an intergovernmental organisation -! nor does it submit to any jurisdiction. - - SUBROUTINE LFACTORXX(S, CINV, U10, USTAR, UPROXY, USDIR, ROAIRN, & - & LFACT, TAUWX, TAUWY, TAU) - -! ---------------------------------------------------------------------------- -! -! 1. Purpose : -! -! Numerical approximation for the reduction factor LFACTOR(f) to -! reduce energy in the high-frequency part of the resolved part -! of the spectrum to meet the constraint on total stress (TAU). -! The constraint is TAU <= TAU_TOT (TAU_TOT = TAU_WAV + TAU_VIS), -! thus the wind input is reduced to match our constraint. -! -! 2. Method : -! -! 1) If required, extend resolved part of the spectrum to 10Hz using -! an approximation for the spectral slope at the high frequency -! limit: Sin(F) prop. F**(-2) and for E(F) prop. F**(-5). -! 2) Calculate stresses: -! total stress: TAU_TOT = DAIR * USTAR**2 -! viscous stress: TAU_VIS = DAIR * Cv * U10**2 -! viscous stress (x,y-components): -! TAUV_X = TAU_VIS * COS(USDIR) -! TAUV_Y = TAU_VIS * SIN(USDIR) -! wave supported stress (x,y-components): /10Hz -! TAUW_X,Y = GRAV * DWAT * | [SinX,Y(F)]/C(F) dF -! / -! total stress (input): TAU = SQRT( (TAUW_X + TAUV_X)**2 -! + (TAUW_Y + TAUV_Y)**2 ) -! 3) If TAU does not meet our constraint reduce the wind input -! using reduction factor: -! LFACT(F) = MIN(1,exp((1-U/C(F))*RTAU)) -! Then alter RTAU and repeat 3) until our constraint is matched. -! -! ---------------------------------------------------------------------------- -! -!** INTERFACE. -! ---------- - -! *CALL* *LFACTOR(S, CINV, U10, USTAR, USDIR, ROAIRN, SIG, DSII, & -! & LFACT, TAUWX, TAUWY, TAU) -! *S* - NEG. WIND INPUT ENERGY DENSITY SPECTRUM. -! *CINV* - INVERSE PHASE SPEED CALC. IN INPUT ROUTINE -! *UABS* - 10M WIND SPEED -! *USTAR* - NEW FRICTION VELOCITY IN M/S. -! *USDIR* - WIND DIRECTION -! *ROAIRN* - AIR DENSITY IN KG/M3 -! *LFACT* - CORRECTION FACTOR -! *TAUNWX, TAUNWY* - NEGATIVE WAVE NORMAL STRESS COMPONENTS - -! EXTERNALS. -! ---------- -! TAUWINDS -! IRANGE - -! ORIGIN. -! ---------- -! Adapted from Babanin Young Donelan & Banner (ZBRY) physics -! as implemented as ST6 in WAVEWATCH-III -! WW3 module: W3SRC6MD -! WW3 subroutine: LFACTOR -! Implementation into ECWAM DECEMBER 2021 by J. Kousal - -! ---------------------------------------------------------------------- - USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU - - USE YOWFRED , ONLY : FR ,TH ,DFIM ,COSTH ,SINTH,& -& FRATIO ,DELTH ,FRIC, SIG,DSII ,SIGM1,& -& DF ,NFRE_EXT ,DSII_EXT ,SIG_EXT - USE YOWPARAM , ONLY : NANG ,NFRE - USE YOWPCONS , ONLY : G ,ZPI ,ROWATER ,EPSMIN, GM1 - USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK - -! ---------------------------------------------------------------------- - - IMPLICIT NONE -#include "irange.intfb.h" -#include "tauwinds.intfb.h" -#include "abort1.intfb.h" - - REAL(KIND=JWRB), DIMENSION(NANG,NFRE), INTENT(IN) :: S ! Sin(sigma) in [m2/rad-Hz] - REAL(KIND=JWRB), DIMENSION(NFRE), INTENT(IN) :: CINV - REAL(KIND=JWRB), INTENT(IN) :: U10, USTAR, UPROXY, USDIR, ROAIRN - - REAL(KIND=JWRB), DIMENSION(NFRE), INTENT(OUT) :: LFACT - REAL(KIND=JWRB), INTENT(OUT) :: TAUWX, TAUWY, TAU - - INTEGER(KIND=JWIM), PARAMETER :: ITERMAX = 80 ! Max. no. iterations - ! to find numerical LFACT soln - - REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: ECOS2, ESIN2 - REAL(KIND=JWRB), DIMENSION(NFRE_EXT) :: LF_EXT, CINV_EXT - REAL(KIND=JWRB), DIMENSION(NFRE_EXT) :: SDENS_EXT, SDENSX_EXT, SDENSY_EXT - REAL(KIND=JWRB), DIMENSION(NFRE_EXT) :: UCINV_EXT - - REAL(KIND=JWRB) :: TAU_TOT, TAU_VIS, TAU_WAV - REAL(KIND=JWRB) :: TAUVX, TAUVY, TAUX, TAUY - REAL(KIND=JWRB) :: TAU_NND, TAU_INIT(2) - REAL(KIND=JWRB) :: RTAU, DRTAU, ERR - LOGICAL :: OVERSHOT - CHARACTER(LEN=23) :: IDTIME - - INTEGER(KIND=JWIM) :: IK, ITH, M, SIGN_NEW, SIGN_OLD - INTEGER(KIND=JWIM) :: NK, NTH, NSPEC !num. of freqs, dirs, spec. bins - INTEGER(KIND=JWIM), DIMENSION(NANG) :: ITHN - INTEGER(KIND=JWIM), DIMENSION(NFRE) :: IKN - - REAL(KIND=JPHOOK) :: ZHOOK_HANDLE - -! ---------------------------------------------------------------------- - - IF (LHOOK) CALL DR_HOOK('LFACTOR',0,ZHOOK_HANDLE) - - NTH = NANG ! NUMBER OF DIRS , SAME AS KL - NK = NFRE ! NUMBER OF FREQS, SAME AS ML - NSPEC = NK * NTH ! NUMBER OF SPECTRAL BINS - - ITHN = IRANGE(1,NTH,1) ! Index vector 1:NTH - DO IK = 1, NK - ECOS2 (ITHN+(IK-1)*NTH) = COSTH - ESIN2 (ITHN+(IK-1)*NTH) = SINTH - END DO - -!/ 1) --- Either extrapolate arrays up to 10Hz or use discrete spectral -! grid per se. Limit the constraint to the positive part of the -! wind input only. ---------------------------------------------- / - IF (NFRE .LT. NFRE_EXT) THEN - CINV_EXT(1:NK) = CINV - SDENS_EXT(1:NK) = SUM(S,1) * DELTH - SDENSX_EXT(1:NK) = SUM(MAX(0.0_JWRB,S)*RESHAPE(ECOS2,(/NTH,NK/)),1) * DELTH - SDENSY_EXT(1:NK) = SUM(MAX(0.0_JWRB,S)*RESHAPE(ESIN2,(/NTH,NK/)),1) * DELTH - ! --- Spectral slope for S_IN(F) is proportional to F**(-2) ------ / - CINV_EXT(NK+1:NFRE_EXT) = SIG_EXT(NK+1:NFRE_EXT)*GM1 ! 1/c=σ/g - SDENS_EXT(NK+1:NFRE_EXT) = SDENS_EXT(NK) * (SIG_EXT(NK)/SIG_EXT(NK+1:NFRE_EXT))**2 - SDENSX_EXT(NK+1:NFRE_EXT) = SDENSX_EXT(NK) * (SIG_EXT(NK)/SIG_EXT(NK+1:NFRE_EXT))**2 - SDENSY_EXT(NK+1:NFRE_EXT) = SDENSY_EXT(NK) * (SIG_EXT(NK)/SIG_EXT(NK+1:NFRE_EXT))**2 - ELSE - CINV_EXT = CINV - SDENS_EXT(1:NK) = SUM(S,1) * DELTH - SDENSX_EXT(1:NK) = SUM(MAX(0.0_JWRB,S)*RESHAPE(ECOS2,(/NTH,NK/)),1) * DELTH - SDENSY_EXT(1:NK) = SUM(MAX(0.0_JWRB,S)*RESHAPE(ESIN2,(/NTH,NK/)),1) * DELTH - END IF -! -!/ 2) --- Stress calculation ----------------------------------------- / -! --- The total stress ------------------------------------------- / - TAU_TOT = USTAR**2 * ROAIRN -! -! --- The viscous stress and check that it does not exceed -! the total stress. ------------------------------------------ / - TAU_VIS = MAX(0.0_JWRB, -5.0E-5_JWRB*U10 + 1.1E-3_JWRB) * U10**2 * ROAIRN -! TAU_VIS = MIN(0.9 * TAU_TOT, TAU_VIS) - TAU_VIS = MIN(0.95_JWRB * TAU_TOT, TAU_VIS) -! - TAUVX = TAU_VIS * COS(USDIR) - TAUVY = TAU_VIS * SIN(USDIR) -! -! --- The wave supported stress. --------------------------------- / - TAUWX = TAUWINDS(SDENSX_EXT,CINV_EXT,DSII_EXT) ! normal stress (x-component) - TAUWY = TAUWINDS(SDENSY_EXT,CINV_EXT,DSII_EXT) ! normal stress (y-component) - ! WRITE (*,*) ' ' - ! WRITE (*,*) ' TAUWX_LF ',TAUWINDS(SDENSX_EXT(1:NK),CINV_EXT(1:NK),DSII_EXT(1:NK)) - ! WRITE (*,*) ' TAUWX_MF_HF ',TAUWINDS(SDENSX_EXT(NK+1:NFRE_EXT),CINV_EXT(1:NK),DSII_EXT(NK+1:NFRE_EXT)) - TAU_NND = TAUWINDS(SDENS_EXT, CINV_EXT,DSII_EXT) ! normal stress (non-directional) - TAU_WAV = SQRT(TAUWX**2 + TAUWY**2) ! normal stress (magnitude) - TAU_INIT = (/TAUWX,TAUWY/) ! unadjusted normal stress components -! - TAUX = TAUVX + TAUWX ! total stress (x-component) - TAUY = TAUVY + TAUWY ! total stress (y-component) - TAU = SQRT(TAUX**2 + TAUY**2) ! total stress (magnitude) - ERR = (TAU-TAU_TOT)/TAU_TOT ! initial error -! -!/ 3) --- Find reduced Sin(f) = L(f)*Sin(f) to satisfy our constraint -!/ TAU <= TAU_TOT --------------------------------------------- / - !CALL STME21 ( TIME , IDTIME ) - LF_EXT = 1.0_JWRB - IK = 0 -! - IF (TAU .GT. TAU_TOT) THEN - - OVERSHOT = .FALSE. - RTAU = ERR / 90.0_JWRB - DRTAU = 2.0_JWRB - - SIGN_NEW = INT(SIGN(1.0_JWRB,ERR)) - - UCINV_EXT = 1.0_JWRB - (UPROXY * CINV_EXT) - - DO IK=1,ITERMAX - - LF_EXT = MIN(1.0_JWRB, EXP(UCINV_EXT * RTAU) ) - TAU_NND = TAUWINDS(SDENS_EXT *LF_EXT,CINV_EXT,DSII_EXT) - TAUWX = TAUWINDS(SDENSX_EXT*LF_EXT,CINV_EXT,DSII_EXT) - TAUWY = TAUWINDS(SDENSY_EXT*LF_EXT,CINV_EXT,DSII_EXT) - ! WRITE (*,*) ' ' - ! WRITE (*,*) ' TAUWX_LF ',TAUWINDS(SDENSX_EXT(1:NK)*LF_EXT(1:NK),CINV_EXT(1:NK),DSII_EXT(1:NK)) - ! WRITE (*,*) ' TAUWX_MF_HF ',TAUWINDS(SDENSX_EXT(NK+1:NFRE_EXT)*LF_EXT(NK+1:NFRE_EXT),CINV_EXT(1:NK),DSII_EXT(NK+1:NFRE_EXT)) - TAU_WAV = SQRT(TAUWX**2 + TAUWY**2) - TAUX = TAUVX + TAUWX - TAUY = TAUVY + TAUWY - TAU = SQRT(TAUX**2 + TAUY**2) - ERR = (TAU-TAU_TOT) / TAU_TOT - SIGN_OLD = SIGN_NEW - SIGN_NEW = INT(SIGN(1.0_JWRB, ERR)) - -! --- Slow down DRTAU when overshot. -------------------------- / - - IF (SIGN_NEW .NE. SIGN_OLD) OVERSHOT = .TRUE. - IF (OVERSHOT) DRTAU = MAX(0.5_JWRB*(1.0_JWRB+DRTAU),1.00010_JWRB) - - RTAU = RTAU * (DRTAU**SIGN_NEW) - - ! CALL ABORT1 - - - IF (ABS(ERR) .LT. 1.54E-4_JWRB) EXIT - - END DO - - END IF - - LFACT(1:NK) = LF_EXT(1:NK) - - IF (LHOOK) CALL DR_HOOK('LFACTOR',1,ZHOOK_HANDLE) - - END SUBROUTINE LFACTORXX diff --git a/src/ecwam/lfactor_wvei.F90 b/src/ecwam/lfactor_wvei.F90 deleted file mode 100644 index 98b966f4e..000000000 --- a/src/ecwam/lfactor_wvei.F90 +++ /dev/null @@ -1,344 +0,0 @@ -! (C) Copyright 1989- ECMWF. -! -! This software is licensed under the terms of the Apache Licence Version 2.0 -! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. -! In applying this licence, ECMWF does not waive the privileges and immunities -! granted to it by virtue of its status as an intergovernmental organisation -! nor does it submit to any jurisdiction. - - SUBROUTINE LFACTORXY(S, CINV, U10, USTAR, UPROXY, USDIR, ROAIRN, & - & LFACT, TAUWX, TAUWY, TAU) - -! ---------------------------------------------------------------------------- -! -! 1. Purpose : -! -! Numerical approximation for the reduction factor LFACTOR(f) to -! reduce energy in the high-frequency part of the resolved part -! of the spectrum to meet the constraint on total stress (TAU). -! The constraint is TAU <= TAU_TOT (TAU_TOT = TAU_WAV + TAU_VIS), -! thus the wind input is reduced to match our constraint. -! -! 2. Method : -! -! 1) If required, extend resolved part of the spectrum to 10Hz using -! an approximation for the spectral slope at the high frequency -! limit: Sin(F) prop. F**(-2) and for E(F) prop. F**(-5). -! 2) Calculate stresses: -! total stress: TAU_TOT = DAIR * USTAR**2 -! viscous stress: TAU_VIS = DAIR * Cv * U10**2 -! viscous stress (x,y-components): -! TAUV_X = TAU_VIS * COS(USDIR) -! TAUV_Y = TAU_VIS * SIN(USDIR) -! wave supported stress (x,y-components): /10Hz -! TAUW_X,Y = GRAV * DWAT * | [SinX,Y(F)]/C(F) dF -! / -! total stress (input): TAU = SQRT( (TAUW_X + TAUV_X)**2 -! + (TAUW_Y + TAUV_Y)**2 ) -! 3) If TAU does not meet our constraint reduce the wind input -! using reduction factor: -! LFACT(F) = MIN(1,exp((1-U/C(F))*RTAU)) -! Then alter RTAU and repeat 3) until our constraint is matched. -! -! ---------------------------------------------------------------------------- -! -!** INTERFACE. -! ---------- - -! *CALL* *LFACTOR(S, CINV, U10, USTAR, USDIR, ROAIRN, SIG, DSII, & -! & LFACT, TAUWX, TAUWY, TAU) -! *S* - NEG. WIND INPUT ENERGY DENSITY SPECTRUM. -! *CINV* - INVERSE PHASE SPEED CALC. IN INPUT ROUTINE -! *UABS* - 10M WIND SPEED -! *USTAR* - NEW FRICTION VELOCITY IN M/S. -! *USDIR* - WIND DIRECTION -! *ROAIRN* - AIR DENSITY IN KG/M3 -! *LFACT* - CORRECTION FACTOR -! *TAUNWX, TAUNWY* - NEGATIVE WAVE NORMAL STRESS COMPONENTS - -! EXTERNALS. -! ---------- -! TAUWINDS -! IRANGE - -! ORIGIN. -! ---------- -! Adapted from Babanin Young Donelan & Banner (ZBRY) physics -! as implemented as ST6 in WAVEWATCH-III -! WW3 module: W3SRC6MD -! WW3 subroutine: LFACTOR -! Implementation into ECWAM DECEMBER 2021 by J. Kousal - -! ---------------------------------------------------------------------- - USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU - - USE YOWFRED , ONLY : FR ,TH ,DFIM ,COSTH ,SINTH,& -& FRATIO ,DELTH ,FRIC, SIG,DSII ,SIGM1,& -& DF ,NFRE_EXT ,DSII_EXT ,SIG_EXT - USE YOWPARAM , ONLY : NANG ,NFRE - USE YOWPCONS , ONLY : G ,ZPI ,ROWATER ,EPSMIN, GM1 - USE YOWPHYS , ONLY : FRQMAX - USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK - -! ---------------------------------------------------------------------- - - IMPLICIT NONE -#include "irange.intfb.h" -#include "tauwinds.intfb.h" -#include "wvei.intfb.h" -#include "abort1.intfb.h" - - REAL(KIND=JWRB), DIMENSION(NANG,NFRE), INTENT(IN) :: S ! Sin(sigma) in omega - REAL(KIND=JWRB), DIMENSION(NFRE), INTENT(IN) :: CINV - REAL(KIND=JWRB), INTENT(IN) :: U10, USTAR, UPROXY, USDIR, ROAIRN - - REAL(KIND=JWRB), DIMENSION(NFRE), INTENT(OUT) :: LFACT - REAL(KIND=JWRB), INTENT(OUT) :: TAUWX, TAUWY, TAU - - INTEGER(KIND=JWIM), PARAMETER :: ITERMAX = 80 ! Max. no. iterations - ! to find numerical LFACT soln - - REAL(KIND=JWRB), DIMENSION(NANG*NFRE) :: ECOS2, ESIN2 - REAL(KIND=JWRB), DIMENSION(NANG,NFRE) :: SX, SY - REAL(KIND=JWRB), DIMENSION(NFRE) :: SDENSX_LF, SDENSY_LF - REAL(KIND=JWRB), DIMENSION(NFRE) :: ZA_SX, ZA_SY - REAL(KIND=JWRB), DIMENSION(NFRE) :: UCINV - REAL(KIND=JWRB), DIMENSION(NFRE) :: LF - - REAL(KIND=JWRB) :: SDENSX_HF, SDENSY_HF, SDENSX_MF_HF, SDENSY_MF_HF - REAL(KIND=JWRB) :: SDENSX_MF, SDENSY_MF - REAL(KIND=JWRB) :: TAUWX_LF, TAUWY_LF, TAUWX_MF_HF, TAUWY_MF_HF - REAL(KIND=JWRB) :: TAUWX_HF, TAUWY_HF - REAL(KIND=JWRB) :: ZA_EXP, ZWVEI, FRQMIDOM, FRQMAXOM - - REAL(KIND=JWRB) :: TAU_TOT, TAU_VIS, TAU_WAV - REAL(KIND=JWRB) :: TAUVX, TAUVY, TAUX, TAUY - - REAL(KIND=JWRB) :: TAU_NND, TAU_INIT(2) - - REAL(KIND=JWRB) :: RTAU, DRTAU, ERR - LOGICAL :: OVERSHOT - LOGICAL :: LLFRQMF - - INTEGER(KIND=JWIM) :: IK, ITH, M, SIGN_NEW, SIGN_OLD - INTEGER(KIND=JWIM) :: NK, NTH, NSPEC !num. of freqs, dirs, spec. bins - INTEGER(KIND=JWIM), DIMENSION(NANG) :: ITHN - INTEGER(KIND=JWIM), DIMENSION(NFRE) :: IKN - - REAL(KIND=JPHOOK) :: ZHOOK_HANDLE - -! ---------------------------------------------------------------------- - - IF (LHOOK) CALL DR_HOOK('LFACTOR',0,ZHOOK_HANDLE) - - NTH = NANG ! NUMBER OF DIRS , SAME AS KL - NK = NFRE ! NUMBER OF FREQS, SAME AS ML - NSPEC = NK * NTH ! NUMBER OF SPECTRAL BINS - - FRQMAXOM = ZPI * FRQMAX ! max angular frequency corresponding to FRQMAX in Hz - FRQMIDOM = MIN(FRQMAXOM,G/UPROXY) ! dynamic cutoff frequency, capped at FRQMAX - - ITHN = IRANGE(1,NTH,1) ! Index vector 1:NTH - DO IK = 1, NK - ECOS2 (ITHN+(IK-1)*NTH) = COSTH - ESIN2 (ITHN+(IK-1)*NTH) = SINTH - END DO - - SX = MAX(0.0_JWRB,S)*RESHAPE(ECOS2,(/NTH,NK/)) - SY = MAX(0.0_JWRB,S)*RESHAPE(ESIN2,(/NTH,NK/)) - -!/ ----------------------------------------------------------------- / -!/ ----------------------------------------------------------------- / -!/ Part I) --- low/high frequency contributions of TAU ------------- / - - !/ 0) --- split integral into low/high frequency contributions ------------- / - ! - ! - ! Th=2pi,ω=inf Th=2pi,ω=SIG(NFRE) Th=2pi,ω=inf - ! / / / / / / - ! | | S(f,Th)/c df dTh = | | S(f,Th)/c df dTh + | | S(f,Th)/c df dTh - ! / / / / / / - ! Th=0,ω=0 Th=0,ω=0 Th=0,ω=SIG(NFRE) - ! - ! - ! = LF_contribution + HF_contribution - ! - ! - !/ 1) --- low frequency contributions to the integral ---------------------- / - ! -- Direct summation over available freq. bins up to FR(NFRE) - - SDENSX_LF = SUM(SX,1) * DELTH - SDENSY_LF = SUM(SY,1) * DELTH - - TAUWX_LF = TAUWINDS(SDENSX_LF,CINV,DSII) ! x-component - TAUWY_LF = TAUWINDS(SDENSY_LF,CINV,DSII) ! y-component - - !/ 2) --- high frequency contributions to the integral --------------------- / - ! -- Assume spectral slope for S_IN(F) is proportional to F**(-2), then - ! integral collapses into easy analytic solution - ! - ! - ! Th=2pi,ω=ZPI*FRQMAX - ! / / - ! | | S(f,Th)/c df dTh = (LOG(ZPI*FRQMAX) - LOG(SIG(NFRE))) * SIG(NFRE)**2 * DELTH * SUM(S(:,NFRE)) * GM1 - ! / / - ! Th=0,ω=SIG(NFRE) - ! - ! - ! Determine value of spectrum at NFRE (i.e. at highest frequency). - ! - Note, direction dimension must remain - - ZA_SX = SX(:,NFRE) - ZA_SY = SY(:,NFRE) - - ! mid + high frequency contributions - SDENSX_MF_HF = GM1 * SIG(NFRE)**2 * (LOG(FRQMAXOM) - LOG(SIG(NFRE))) * DELTH * SUM(ZA_SX) - SDENSY_MF_HF = GM1 * SIG(NFRE)**2 * (LOG(FRQMAXOM) - LOG(SIG(NFRE))) * DELTH * SUM(ZA_SY) - - TAUWX_MF_HF = G * ROWATER * ( SDENSX_MF_HF ) - TAUWY_MF_HF = G * ROWATER * ( SDENSY_MF_HF ) - - !/ 3) --- summate low + mid + high frequency contributions to the integral ------- / - - TAUWX = TAUWX_LF + TAUWX_MF_HF - TAUWY = TAUWY_LF + TAUWY_MF_HF - ! WRITE (*,*) '!/ ----- PRE LFAC ----- / ' - ! WRITE (*,*) ' TAUWX_LF ',TAUWX_LF - ! WRITE (*,*) ' TAUWX_MF_HF ',TAUWX_MF_HF - -!/ ----------------------------------------------------------------- / -!/ ----------------------------------------------------------------- / -!/ Part II) --- USTAR based TAU calculation ------------- / -! -!/ 2) --- Stress calculation ----------------------------------------- / -! --- The total stress ------------------------------------------- / - - TAU_TOT = USTAR**2 * ROAIRN - -! --- The viscous stress and check that it does not exceed -! the total stress. ------------------------------------------ / - - TAU_VIS = MAX(0.0_JWRB, -5.0E-5_JWRB*U10 + 1.1E-3_JWRB) * U10**2 * ROAIRN -! TAU_VIS = MIN(0.9 * TAU_TOT, TAU_VIS) - TAU_VIS = MIN(0.95_JWRB * TAU_TOT, TAU_VIS) - - TAUVX = TAU_VIS * COS(USDIR) - TAUVY = TAU_VIS * SIN(USDIR) - -! --- The wave supported stress (using elements calculated in Part I). -- / -! - TAU_WAV = SQRT(TAUWX**2 + TAUWY**2) ! normal stress (magnitude) - TAU_INIT = (/TAUWX,TAUWY/) ! unadjusted normal stress components - - TAUX = TAUVX + TAUWX ! total stress (x-component) - TAUY = TAUVY + TAUWY ! total stress (y-component) - TAU = SQRT(TAUX**2 + TAUY**2) ! total stress (magnitude) - ERR = (TAU-TAU_TOT)/TAU_TOT ! initial error - -!/ 3) --- Find reduced Sin(f) = L(f)*Sin(f) to satisfy our constraint -!/ TAU <= TAU_TOT --------------------------------------------- / - - LF = 1.0_JWRB - IK = 0 - - ! Determines if we need special treatment for some of the high frequencies to account for LFAC - IF (FRQMIDOM>SIG(NFRE)) THEN - ! cut off falls between SIG(NFRE) and FRQMAXOM, therefore have to use 3 solution branches (LF + MF + HF) - LLFRQMF = .TRUE. - - ! mid frequency (MF) contributions, SIG(NFRE)<ω Date: Tue, 28 Apr 2026 15:01:04 +0000 Subject: [PATCH 74/89] handle allocation in initmdl --- src/ecwam/initmdl.F90 | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/ecwam/initmdl.F90 b/src/ecwam/initmdl.F90 index d1abc594f..05ba0f159 100644 --- a/src/ecwam/initmdl.F90 +++ b/src/ecwam/initmdl.F90 @@ -521,7 +521,11 @@ SUBROUTINE INITMDL (NADV, & ! DETERMINE THE NUMBER OF FREQUENCIES TO EXTEND TO NFRE_EXT = CEILING(LOG(FRQMAX/FR(1))/LOG(FRATIO))+1 NFRE_EXT = MAX(NFRE,NFRE_EXT) - IFRE_EXT(1:NFRE_EXT) = (/ (REAL(M, KIND=JWRB), M=1,NFRE_EXT) /) + IF (ALLOCATED(IFRE_EXT)) THEN + IF (SIZE(IFRE_EXT) /= NFRE_EXT) DEALLOCATE(IFRE_EXT) + END IF + IF (.NOT.ALLOCATED(IFRE_EXT)) ALLOCATE(IFRE_EXT(NFRE_EXT)) + IFRE_EXT = (/ (REAL(M, KIND=JWRB), M=1,NFRE_EXT) /) IF (.NOT.ALLOCATED(SIG_EXT)) ALLOCATE(SIG_EXT(NFRE_EXT)) IF (.NOT.ALLOCATED(DSII_EXT)) ALLOCATE(DSII_EXT(NFRE_EXT)) IF (NFRE .LT. NFRE_EXT) THEN From 421765bcc11de641c324f0108409620bdca6884b Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Tue, 28 Apr 2026 16:12:32 +0000 Subject: [PATCH 75/89] proper indexing and loops --- src/ecwam/sdissip_zbry.F90 | 132 +++++++++++------- src/ecwam/sinflx_zbry.F90 | 261 ++++++++++++++++++++++------------- src/ecwam/swldissip_zbry.F90 | 103 +++++++++----- 3 files changed, 314 insertions(+), 182 deletions(-) diff --git a/src/ecwam/sdissip_zbry.F90 b/src/ecwam/sdissip_zbry.F90 index 7280523df..d579a1267 100644 --- a/src/ecwam/sdissip_zbry.F90 +++ b/src/ecwam/sdissip_zbry.F90 @@ -110,6 +110,7 @@ SUBROUTINE SDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE) :: CG2 REAL(KIND=JWRB), DIMENSION(NANG,NFRE) :: SIG2 REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE) :: DDS + REAL(KIND=JWRB), DIMENSION(KIJL) :: CUMADF REAL(KIND=JPHOOK) :: ZHOOK_HANDLE @@ -117,66 +118,80 @@ SUBROUTINE SDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & IF (LHOOK) CALL DR_HOOK('SDISSIP_ZBRY',0,ZHOOK_HANDLE) - DO K = 1, NANG ! Apply to all directions - SIG2(K,:) = SIG - END DO - - DO K = 1, NANG ! Apply to all directions - DO IJ = KIJS,KIJL - CG2(IJ,K,:) = CGROUP(IJ,:) + DO M = 1, NFRE + DO K = 1, NANG ! Apply to all directions + SIG2(K,M) = SIG(M) + DO IJ = KIJS,KIJL + CG2(IJ,K,M) = CGROUP(IJ,M) + A(IJ,K,M) = FL1(IJ,K,M) * CG2(IJ,K,M) / ( ZPI * SIG2(K,M) ) ! ACTION DENSITY SPECTRUM + END DO END DO END DO - - DO IJ = KIJS,KIJL - A(IJ,:,:) = FL1(IJ,:,:) * CG2(IJ,:,:) / ( ZPI * SIG2(:,:) ) ! ACTION DENSITY SPECTRUM - END DO !/ 0) --- Initialize essential parameters ---------------------------- / FREQ = FR(1:NFRE) BNT = 0.035_JWRB**2 - DO IJ = KIJS,KIJL - ANAR(IJ,:) = 1.0_JWRB - T1(IJ,:) = 0.0_JWRB - T2(IJ,:) = 0.0_JWRB - NEXDENS(IJ,:) = 0.0_JWRB + DO M = 1, NFRE + DO IJ = KIJS,KIJL + ANAR(IJ,M) = 1.0_JWRB + T1(IJ,M) = 0.0_JWRB + T2(IJ,M) = 0.0_JWRB + NEXDENS(IJ,M) = 0.0_JWRB + END DO END DO ! !/ 1) --- Calculate threshold spectral density, spectral density, and !/ the level of exceedence EXDENS(f) -------------------------- / - DO IJ = KIJS,KIJL - ETDENS(IJ,:) = ( ZPI * BNT ) / ( ANAR(IJ,:) * CGROUP(IJ,:) * WAVNUM(IJ,:)**3 ) - EDENS(IJ,:) = SUM(FL1(IJ,:,:),1) * DELTH !E(f) - EXDENS(IJ,:) = MAX(0.0_JWRB,EDENS(IJ,:)-ETDENS(IJ,:)) - END DO + DO M = 1, NFRE + DO IJ = KIJS,KIJL + ETDENS(IJ,M) = ( ZPI * BNT ) / ( ANAR(IJ,M) * CGROUP(IJ,M) * WAVNUM(IJ,M)**3 ) + EDENS(IJ,M) = 0.0_JWRB + END DO + DO K = 1, NANG + DO IJ = KIJS,KIJL + EDENS(IJ,M) = EDENS(IJ,M) + FL1(IJ,K,M) + END DO + END DO + DO IJ = KIJS,KIJL + EDENS(IJ,M) = EDENS(IJ,M) * DELTH ! E(f) + EXDENS(IJ,M) = MAX(0.0_JWRB,EDENS(IJ,M)-ETDENS(IJ,M)) + END DO + END DO ! !/ --- normalise by a generic spectral density -------------------- / - DO IJ = KIJS,KIJL - IF (LLSDS6ET) THEN - NEXDENS(IJ,:) = EXDENS(IJ,:) / ETDENS(IJ,:) ! normalise by threshold spectral density - ELSE ! normalise by spectral density - EDENSMAX(IJ) = MAXVAL(EDENS(IJ,:))*1.0E-5_JWRB - IF (ALL(EDENS(IJ,:) .GT. EDENSMAX(IJ))) THEN - NEXDENS(IJ,:) = EXDENS(IJ,:) / EDENS(IJ,:) - ELSE - DO M = 1,NFRE - IF (EDENS(IJ,M) .GT. EDENSMAX(IJ)) THEN - NEXDENS(IJ,M) = EXDENS(IJ,M) / EDENS(IJ,M) - END IF - END DO - END IF - END IF - END DO + IF (LLSDS6ET) THEN + DO M = 1,NFRE + DO IJ = KIJS,KIJL + NEXDENS(IJ,M) = EXDENS(IJ,M) / ETDENS(IJ,M) ! normalise by threshold spectral density + END DO + END DO + ELSE ! normalise by spectral density + DO IJ = KIJS,KIJL + EDENSMAX(IJ) = MAXVAL(EDENS(IJ,1:NFRE))*1.0E-5_JWRB + END DO + DO M = 1,NFRE + DO IJ = KIJS,KIJL + IF (EDENS(IJ,M) .GT. EDENSMAX(IJ)) THEN + NEXDENS(IJ,M) = EXDENS(IJ,M) / EDENS(IJ,M) + END IF + END DO + END DO + END IF ! !/ 2) --- Calculate inherent breaking component T1 ------------------- / - DO IJ = KIJS,KIJL - T1(IJ,:) = ZSDS6A1 * ANAR(IJ,:) * FREQ * (NEXDENS(IJ,:)**ISDS6P1) - END DO + DO M = 1,NFRE + DO IJ = KIJS,KIJL + T1(IJ,M) = ZSDS6A1 * ANAR(IJ,M) * FREQ(M) * (NEXDENS(IJ,M)**ISDS6P1) + END DO + END DO ! !/ 3) --- Calculate T2, the dissipation of waves induced by !/ the breaking of longer waves T2 ---------------------------- / - DO IJ = KIJS,KIJL - ADF(IJ,:) = ANAR(IJ,:) * (NEXDENS(IJ,:)**ISDS6P2) - END DO + DO M = 1,NFRE + DO IJ = KIJS,KIJL + ADF(IJ,M) = ANAR(IJ,M) * (NEXDENS(IJ,M)**ISDS6P2) + END DO + END DO XFAC = (1.0_JWRB-1.0_JWRB/FRATIO)/(FRATIO-1.0_JWRB/FRATIO) DO M = 1,NFRE @@ -184,26 +199,37 @@ SUBROUTINE SDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & IF (M .GT. 1 .AND. M .LT. NFRE) THEN DFII(M) = DFII(M) * XFAC END IF + END DO + + DO M = 1,NFRE DO IJ = KIJS,KIJL - T2(IJ,M) = ZSDS6A2 * SUM( ADF(IJ,1:M)*DFII(1:M) ) + CUMADF(IJ) = 0.0_JWRB + END DO + DO I = 1,M + DO IJ = KIJS,KIJL + CUMADF(IJ) = CUMADF(IJ) + ADF(IJ,I)*DFII(I) + END DO + END DO + DO IJ = KIJS,KIJL + T2(IJ,M) = ZSDS6A2 * CUMADF(IJ) END DO END DO !/ 4) --- Sum up dissipation terms and apply to all directions ------- / - DO IJ = KIJS,KIJL - T12(IJ,:) = -1.0_JWRB * ( MAX(0.0_JWRB,T1(IJ,:))+MAX(0.0_JWRB,T2(IJ,:)) ) + DO M = 1,NFRE + DO IJ = KIJS,KIJL + T12(IJ,M) = -1.0_JWRB * ( MAX(0.0_JWRB,T1(IJ,M))+MAX(0.0_JWRB,T2(IJ,M)) ) + END DO END DO DO K = 1, NANG - DO IJ = KIJS,KIJL - D(IJ,K,:) = T12(IJ,:) + DO M = 1, NFRE + DO IJ = KIJS,KIJL + D(IJ,K,M) = T12(IJ,M) + DDS(IJ,K,M) = D(IJ,K,M) + END DO END DO END DO -! -! - DO IJ = KIJS,KIJL - DDS(IJ,:,:) = D(IJ,:,:) - END DO IF (LLLOWWINDS) THEN DO M = 1,NFRE diff --git a/src/ecwam/sinflx_zbry.F90 b/src/ecwam/sinflx_zbry.F90 index d771068eb..16b1064ca 100644 --- a/src/ecwam/sinflx_zbry.F90 +++ b/src/ecwam/sinflx_zbry.F90 @@ -207,6 +207,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & REAL(KIND=JWRB), PARAMETER :: AMAX=0.02_JWRB REAL(KIND=JWRB), PARAMETER :: BMAX=0.01_JWRB REAL(KIND=JWRB) :: ALPHAOGMAXU10 +REAL(KIND=JWRB) :: SUMDIR REAL(KIND=JWRB), DIMENSION(KIJL) :: ROAIRN, CHNKOG @@ -217,6 +218,8 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & ! REAL(KIND=JWRB), DIMENSION(KIJL,NGST) :: TAUNWGST REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE) :: SLGST_AVG, SPOSGST_AVG, FLGST_AVG REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE,NGST) :: SLGST, SPOSGST, FLGST +REAL(KIND=JWRB), DIMENSION(NANG,NFRE) :: SPOS_IJ, SNEG_IJ +LOGICAL, DIMENSION(KIJL) :: LREDUCE ! ---------------------------------------------------------------------- @@ -309,18 +312,19 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & !/ --- Main loop over LOC ----------------------------------- / -DO K = 1, NANG +DO M = 1, NFRE + DO K = 1, NANG + DO IJ = KIJS,KIJL + WN2(IJ,K,M) = WAVNUM(IJ,M) ! using WAM native WN,CG + CG2(IJ,K,M) = CGROUP(IJ,M) + CINV2(IJ,K,M) = WN2(IJ,K,M) / SIG2(K,M) ! inverse phase speed + END DO + END DO DO IJ = KIJS,KIJL - WN2(IJ,K,:) = WAVNUM(IJ,:) ! using WAM native WN,CG - CG2(IJ,K,:) = CGROUP(IJ,:) + CINV1(IJ,M) = CINV2(IJ,1,M) END DO END DO -DO IJ = KIJS,KIJL - CINV2(IJ,:,:) = WN2(IJ,:,:) / SIG2(:,:) ! inverse phase speed - CINV1(IJ,:) = CINV2(IJ,1,:) -END DO - !/ 0) --- set up a basic variables ----------------------------------- / DO IJ = KIJS,KIJL COSU(IJ) = COS(WDWAVE(IJ)) @@ -366,42 +370,64 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & ! START: using intrinsic frequency spectra ! -DO IJ = KIJS,KIJL - A(IJ,:,:) = FL1(IJ,:,:) * CG2(IJ,:,:) / ( ZPI * SIG2(:,:) ) ! ACTION DENSITY SPECTRUM ! !/ 1) --- calculate 1d action density spectrum (A(sigma)) and !/ zero-out values less than 1.0E-32 to avoid NaNs when !/ computing directional narrowness in step 4). --------------- / - KK(IJ,:,:) = A(IJ,:,:) - - ADENSIG(IJ,:) = SUM(KK(IJ,:,:),1) * SIG * DELTH ! Integrate over directions. - - KMAX(IJ,:) = MAXVAL(KK(IJ,:,:),1) -END DO + +DO M = 1, NFRE + DO K = 1, NANG + DO IJ = KIJS,KIJL + A(IJ,K,M) = FL1(IJ,K,M) * CG2(IJ,K,M) / ( ZPI * SIG2(K,M) ) ! ACTION DENSITY SPECTRUM + KK(IJ,K,M) = A(IJ,K,M) + END DO + END DO + + DO IJ = KIJS,KIJL + ADENSIG(IJ,M) = 0.0_JWRB + KMAX(IJ,M) = 0.0_JWRB + END DO + DO K = 1, NANG + DO IJ = KIJS,KIJL + ADENSIG(IJ,M) = ADENSIG(IJ,M) + KK(IJ,K,M) + KMAX(IJ,M) = MAX(KMAX(IJ,M), KK(IJ,K,M)) + END DO + END DO + DO IJ = KIJS,KIJL + ADENSIG(IJ,M) = ADENSIG(IJ,M) * SIG(M) * DELTH ! Integrate over directions. + END DO ! !/ 2) --- calculate normalised directional spectrum K(theta,sigma) --- / -DO M = 1,NFRE - DO IJ = KIJS,KIJL + + DO K = 1, NANG + DO IJ = KIJS,KIJL IF (KMAX(IJ,M).LT.1.0E-34_JWRB) THEN - KK(IJ,1:NANG,M) = 1.0_JWRB + KK(IJ,K,M) = 1.0_JWRB ELSE - KK(IJ,1:NANG,M) = KK(IJ,1:NANG,M)/KMAX(IJ,M) + KK(IJ,K,M) = KK(IJ,K,M)/KMAX(IJ,M) END IF + END DO END DO -END DO ! !/ 3) --- calculate normalised spectral saturation BN(M) ------------ / -DO IJ = KIJS,KIJL - ANAR(IJ,:) = 1.0_JWRB/( SUM(KK(IJ,:,:),1) * DELTH ) ! directional narrowness - ! - ! SQRTBN = SQRT( ANAR * ADENSIG * WN(IJ,:)**3 ) - SQRTBN(IJ,:) = SQRT( ANAR(IJ,:) * ADENSIG(IJ,:) * WAVNUM(IJ,:)**3 ) -END DO - -DO K = 1, NANG DO IJ = KIJS,KIJL - SQRTBN2(IJ,K,:) = SQRTBN(IJ,:) ! Calculate SQRTBN for - END DO ! the entire spectrum. + ANAR(IJ,M) = 0.0_JWRB + END DO + DO K = 1, NANG + DO IJ = KIJS,KIJL + ANAR(IJ,M) = ANAR(IJ,M) + KK(IJ,K,M) + END DO + END DO + DO IJ = KIJS,KIJL + ANAR(IJ,M) = 1.0_JWRB/( ANAR(IJ,M) * DELTH ) ! directional narrowness + SQRTBN(IJ,M) = SQRT( ANAR(IJ,M) * ADENSIG(IJ,M) * WAVNUM(IJ,M)**3 ) + END DO + + DO K = 1, NANG + DO IJ = KIJS,KIJL + SQRTBN2(IJ,K,M) = SQRTBN(IJ,M) ! Calculate SQRTBN for + END DO ! the entire spectrum. + END DO END DO ! !/ 4) --- calculate growth rate GAMMA and S for all directions for @@ -409,25 +435,24 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & !/ adverse winds (U10/c -1 is negative, W2). W1 and W2 !/ complement one another. ------------------------------------ / DO IGST=1,NGST - DO IJ = KIJS,KIJL - W1(IJ,:,:,IGST) = MAX(0.0_JWRB, & - & UPROXYGST(IJ,IGST)*CINV2(IJ,:,:)*(ECOS2(:,:)*COSU(IJ) + ESIN2(:,:)*SINU(IJ)) - 1.0_JWRB)**2 -! - D(IJ,:,:,IGST) = (RAORW(IJ)) * SIG2(:,:) * & - (2.8_JWRB-(1.0_JWRB+TANH(10.0_JWRB*SQRTBN2(IJ,:,:)*W1(IJ,:,:,IGST)-11.0_JWRB)))* & - & SQRTBN2(IJ,:,:)*W1(IJ,:,:,IGST) -! - IF (LLLOWWINDS .AND. UABSGST(IJ,IGST)<=1.5_JWRB) THEN - ! Reduce growth rates for low winds (following Muhammad Yasrab's work) - D(IJ,:,:,IGST) = D(IJ,:,:,IGST) - (4._JWRB*(RNU_WATER)*(WN2(IJ,:,:)**2)) - S(IJ,:,:,IGST) = D(IJ,:,:,IGST) * A(IJ,:,:) - ELSE - ! Update spectrum as per normal - S(IJ,:,:,IGST) = D(IJ,:,:,IGST) * A(IJ,:,:) - END IF - - ENDDO -ENDDO + DO M = 1, NFRE + DO K = 1, NANG + DO IJ = KIJS,KIJL + W1(IJ,K,M,IGST) = MAX(0.0_JWRB, & + & UPROXYGST(IJ,IGST)*CINV2(IJ,K,M)*(ECOS2(K,M)*COSU(IJ) + ESIN2(K,M)*SINU(IJ)) - 1.0_JWRB)**2 + D(IJ,K,M,IGST) = (RAORW(IJ)) * SIG2(K,M) * & + (2.8_JWRB-(1.0_JWRB+TANH(10.0_JWRB*SQRTBN2(IJ,K,M)*W1(IJ,K,M,IGST)-11.0_JWRB)))* & + & SQRTBN2(IJ,K,M)*W1(IJ,K,M,IGST) + + IF (LLLOWWINDS .AND. UABSGST(IJ,IGST)<=1.5_JWRB) THEN + ! Reduce growth rates for low winds (following Muhammad Yasrab's work) + D(IJ,K,M,IGST) = D(IJ,K,M,IGST) - (4._JWRB*(RNU_WATER)*(WN2(IJ,K,M)**2)) + END IF + S(IJ,K,M,IGST) = D(IJ,K,M,IGST) * A(IJ,K,M) + END DO + END DO + END DO +END DO IF (LLFACT) THEN ! TODO: how to make more efficient? is difficult... @@ -435,25 +460,35 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & ! spectral density of the wind input ------------------------- / DO IGST=1,NGST - - DO IJ = KIJS,KIJL - SDENSIG(IJ,:,:,IGST) = S(IJ,:,:,IGST)*SIG2(:,:)/CG2(IJ,:,:) + DO M = 1, NFRE + DO K = 1, NANG + DO IJ = KIJS,KIJL + SDENSIG(IJ,K,M,IGST) = S(IJ,K,M,IGST)*SIG2(K,M)/CG2(IJ,K,M) + END DO + END DO + END DO + DO IJ = KIJS,KIJL CALL LFACTOR(SDENSIG(IJ,:,:,IGST), CINV1(IJ,:), UABSGST(IJ,IGST), USTARGST(IJ,IGST), UPROXYGST(IJ,IGST), WDWAVE(IJ), & & ROAIRN(IJ), LFACT(IJ,:,IGST), TAUWX(IJ,IGST), TAUWY(IJ,IGST), TAU(IJ,IGST)) ENDDO !/ 6) --- apply reduction (LFACT) to the entire spectrum ------------- / - DO IJ = KIJS,KIJL - IF (SUM(LFACT(IJ,:,IGST)) .LT. NFRE) THEN - DO K = 1, NANG - D(IJ,K,:,IGST) = D(IJ,K,:,IGST) * LFACT(IJ,:,IGST) + DO IJ = KIJS,KIJL + LREDUCE(IJ) = SUM(LFACT(IJ,:,IGST)) .LT. NFRE + END DO + DO M = 1, NFRE + DO K = 1, NANG + DO IJ = KIJS,KIJL + IF (LREDUCE(IJ)) THEN + D(IJ,K,M,IGST) = D(IJ,K,M,IGST) * LFACT(IJ,M,IGST) + S(IJ,K,M,IGST) = D(IJ,K,M,IGST) * A(IJ,K,M) + END IF + DINPOS(IJ,K,M,IGST) = D(IJ,K,M,IGST) END DO - S(IJ,:,:,IGST) = D(IJ,:,:,IGST) * A(IJ,:,:) - END IF - DINPOS(IJ,:,:,IGST) = D(IJ,:,:,IGST) - ENDDO + END DO + END DO ENDDO END IF @@ -465,23 +500,31 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & !/ the factor is adjustable with namelist parameter ZSIN6A0 ---- / DO IGST=1,NGST IF (ZSIN6A0.GT.0.0_JWRB) THEN - DO IJ = KIJS,KIJL - W2(IJ,:,:,IGST) = MIN( 0.0_JWRB,UPROXYGST(IJ,IGST) * CINV2(IJ,:,:) * & - & (ECOS2(:,:)*COSU(IJ) + ESIN2(:,:)*SINU(IJ)) - 1.0_JWRB )**2 - D(IJ,:,:,IGST) = D(IJ,:,:,IGST) - ( RAORW(IJ) * SIG2(:,:) * ZSIN6A0 * & - (2.8_JWRB-(1.0_JWRB+TANH(10.0_JWRB*SQRTBN2(IJ,:,:)*W2(IJ,:,:,IGST) - 11.0_JWRB)))& - & *SQRTBN2(IJ,:,:)*W2(IJ,:,:,IGST) ) - DINTOT(IJ,:,:,IGST) = D(IJ,:,:,IGST) - S(IJ,:,:,IGST) = D(IJ,:,:,IGST) * A(IJ,:,:) + DO M = 1, NFRE + DO K = 1, NANG + DO IJ = KIJS,KIJL + W2(IJ,K,M,IGST) = MIN( 0.0_JWRB,UPROXYGST(IJ,IGST) * CINV2(IJ,K,M) * & + & (ECOS2(K,M)*COSU(IJ) + ESIN2(K,M)*SINU(IJ)) - 1.0_JWRB )**2 + D(IJ,K,M,IGST) = D(IJ,K,M,IGST) - ( RAORW(IJ) * SIG2(K,M) * ZSIN6A0 * & + (2.8_JWRB-(1.0_JWRB+TANH(10.0_JWRB*SQRTBN2(IJ,K,M)*W2(IJ,K,M,IGST) - 11.0_JWRB)))& + & *SQRTBN2(IJ,K,M)*W2(IJ,K,M,IGST) ) + DINTOT(IJ,K,M,IGST) = D(IJ,K,M,IGST) + S(IJ,K,M,IGST) = D(IJ,K,M,IGST) * A(IJ,K,M) ! ! --- compute negative component of the wave supported stresses ! ! from negative part of the wind input ---------------------- / - SDENSIG(IJ,:,:,IGST) = S(IJ,:,:,IGST)*SIG2(:,:)/CG2(IJ,:,:) - ENDDO + SDENSIG(IJ,K,M,IGST) = S(IJ,K,M,IGST)*SIG2(K,M)/CG2(IJ,K,M) + END DO + END DO + END DO ELSE - DO IJ = KIJS,KIJL - DINTOT(IJ,:,:,IGST)=DINPOS(IJ,:,:,IGST) - ENDDO + DO M = 1, NFRE + DO K = 1, NANG + DO IJ = KIJS,KIJL + DINTOT(IJ,K,M,IGST) = DINPOS(IJ,K,M,IGST) + END DO + END DO + END DO END IF ENDDO ! @@ -521,39 +564,65 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & END DO DO IGST=1,NGST - DO IJ = KIJS,KIJL - FLGST(IJ,:,:,IGST) = DINTOT(IJ,:,:,IGST) - ENDDO + DO M = 1,NFRE + DO K = 1, NANG + DO IJ = KIJS,KIJL + FLGST(IJ,K,M,IGST) = DINTOT(IJ,K,M,IGST) + END DO + END DO + END DO END DO ! 9) --- Averaging over gust components ------------- / -IGST=1 - DO IJ = KIJS,KIJL - TAUWGST_AVG(IJ) = TAUWGST(IJ,IGST) - TAUWDIRGST_AVG(IJ) = TAUWDIRGST(IJ,IGST) - USTARGST_AVG(IJ) = USTARGST(IJ,IGST) - SLGST_AVG(IJ,:,:) = SLGST(IJ,:,:,IGST) - SPOSGST_AVG(IJ,:,:) = SPOSGST(IJ,:,:,IGST) - FLGST_AVG(IJ,:,:) = FLGST(IJ,:,:,IGST) +DO IJ = KIJS,KIJL + TAUWGST_AVG(IJ) = 0.0_JWRB + TAUWDIRGST_AVG(IJ) = 0.0_JWRB + USTARGST_AVG(IJ) = 0.0_JWRB +END DO +DO M = 1,NFRE + DO K = 1, NANG + DO IJ = KIJS,KIJL + SLGST_AVG(IJ,K,M) = 0.0_JWRB + SPOSGST_AVG(IJ,K,M) = 0.0_JWRB + FLGST_AVG(IJ,K,M) = 0.0_JWRB + END DO END DO -DO IGST=2,NGST +END DO + +DO IGST=1,NGST DO IJ = KIJS,KIJL TAUWGST_AVG(IJ) = TAUWGST_AVG(IJ) + TAUWGST(IJ,IGST) TAUWDIRGST_AVG(IJ) = TAUWDIRGST_AVG(IJ) + TAUWDIRGST(IJ,IGST) USTARGST_AVG(IJ) = USTARGST_AVG(IJ) + USTARGST(IJ,IGST) - SLGST_AVG(IJ,:,:) = SLGST_AVG(IJ,:,:) + SLGST(IJ,:,:,IGST) - SPOSGST_AVG(IJ,:,:) = SPOSGST_AVG(IJ,:,:) + SPOSGST(IJ,:,:,IGST) - FLGST_AVG(IJ,:,:) = FLGST_AVG(IJ,:,:) + FLGST(IJ,:,:,IGST) ENDDO + DO M = 1,NFRE + DO K = 1, NANG + DO IJ = KIJS,KIJL + SLGST_AVG(IJ,K,M) = SLGST_AVG(IJ,K,M) + SLGST(IJ,K,M,IGST) + SPOSGST_AVG(IJ,K,M) = SPOSGST_AVG(IJ,K,M) + SPOSGST(IJ,K,M,IGST) + FLGST_AVG(IJ,K,M) = FLGST_AVG(IJ,K,M) + FLGST(IJ,K,M,IGST) + END DO + END DO + END DO END DO DO IJ = KIJS,KIJL TAUW(IJ) = AVG_GST*TAUWGST_AVG(IJ) TAUWDIR(IJ) = AVG_GST*TAUWDIRGST_AVG(IJ) UFRIC(IJ) = AVG_GST*USTARGST_AVG(IJ) - SL(IJ,:,:) = AVG_GST*SLGST_AVG(IJ,:,:) - SPOS(IJ,:,:) = AVG_GST*SPOSGST_AVG(IJ,:,:) - FLD(IJ,:,:) = AVG_GST*FLGST_AVG(IJ,:,:) +END DO + +DO M = 1,NFRE + DO K = 1, NANG + DO IJ = KIJS,KIJL + SL(IJ,K,M) = AVG_GST*SLGST_AVG(IJ,K,M) + SPOS(IJ,K,M) = AVG_GST*SPOSGST_AVG(IJ,K,M) + FLD(IJ,K,M) = AVG_GST*FLGST_AVG(IJ,K,M) + END DO + END DO +END DO + +DO IJ = KIJS,KIJL ! 10) --- Calculate roughness length and charnock ------------- / @@ -579,7 +648,13 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & ! 11) --- PHIWA calculation using non-directional ! spectral density of the wind input ---------------------- / ! CALCPHIWA(SPOS ,SNEG ) - PHIWA(IJ) = CALCPHIWA(SPOS(IJ,:,:),SL(IJ,:,:) - SPOS(IJ,:,:)) + DO M = 1,NFRE + DO K = 1, NANG + SPOS_IJ(K,M) = SPOS(IJ,K,M) + SNEG_IJ(K,M) = SL(IJ,K,M) - SPOS(IJ,K,M) + END DO + END DO + PHIWA(IJ) = CALCPHIWA(SPOS_IJ,SNEG_IJ) END DO ! XLLWS based on SL (mask for pos. input) diff --git a/src/ecwam/swldissip_zbry.F90 b/src/ecwam/swldissip_zbry.F90 index f6126c7b1..31363aa63 100644 --- a/src/ecwam/swldissip_zbry.F90 +++ b/src/ecwam/swldissip_zbry.F90 @@ -83,11 +83,12 @@ SUBROUTINE SWLDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & REAL(KIND=JWRB), DIMENSION(KIJL, NANG), INTENT(IN) :: COSWDIF INTEGER(KIND=JWIM) :: IJ, M, I, J, M2, K2, K, NANGD + INTEGER(KIND=JWIM), DIMENSION(KIJL) :: MPEAK REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: ABAND, KMAX, ANAR, BN, DDIS REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE) :: KK REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE) :: D, A, CG2 - REAL(KIND=JWRB), DIMENSION(KIJL) :: B1 + REAL(KIND=JWRB), DIMENSION(KIJL) :: B1, SUMDIR_IJ REAL(KIND=JWRB), DIMENSION(NANG,NFRE) :: SIG2 REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE) :: DSWL @@ -97,48 +98,72 @@ SUBROUTINE SWLDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & IF (LHOOK) CALL DR_HOOK('SWLDISSIP_ZBRY',0,ZHOOK_HANDLE) - DO K = 1, NANG ! Apply to all directions - SIG2(K,:) = SIG + DO M = 1, NFRE + DO K = 1, NANG ! Apply to all directions + SIG2(K,M) = SIG(M) + DO IJ = KIJS,KIJL + CG2(IJ,K,M) = CGROUP(IJ,M) + A(IJ,K,M) = FL1(IJ,K,M) * CG2(IJ,K,M) / ( ZPI * SIG2(K,M) ) ! ACTION DENSITY SPECTRUM + END DO + END DO END DO - DO K = 1, NANG + !/ 0) --- Initialize parameters -------------------------------------- / + DO M = 1, NFRE DO IJ = KIJS,KIJL - CG2(IJ,K,:) = CGROUP(IJ,:) + ABAND(IJ,M) = 0.0_JWRB + DDIS(IJ,M) = 0.0_JWRB END DO END DO - - DO IJ = KIJS,KIJL - A(IJ,:,:) = FL1(IJ,:,:) * CG2(IJ,:,:) / ( ZPI * SIG2(:,:) ) ! ACTION DENSITY SPECTRUM - END DO - - !/ 0) --- Initialize parameters -------------------------------------- / - DO IJ = KIJS,KIJL - ABAND(IJ,:) = SUM(A(IJ,:,:),1) ! action density as function of wavenumber - DDIS(IJ,:) = 0.0_JWRB - D(IJ,:,:) = 0.0_JWRB + DO M = 1, NFRE + DO K = 1, NANG + DO IJ = KIJS,KIJL + ABAND(IJ,M) = ABAND(IJ,M) + A(IJ,K,M) + D(IJ,K,M) = 0.0_JWRB + END DO + END DO END DO !/ 1) --- Choose calculation of steepness a*k ------------------------ / !/ Replace the measure of steepness with the spectral ! saturation after Banner et al. (2002) ---------------------- / - DO IJ = KIJS,KIJL - KK(IJ,:,:) = A(IJ,:,:) - KMAX(IJ,:) = MAXVAL(KK(IJ,:,:),1) + DO M = 1,NFRE + DO IJ = KIJS,KIJL + KMAX(IJ,M) = 0.0_JWRB + END DO + DO K = 1,NANG + DO IJ = KIJS,KIJL + KK(IJ,K,M) = A(IJ,K,M) + KMAX(IJ,M) = MAX(KMAX(IJ,M), KK(IJ,K,M)) + END DO + END DO END DO DO M = 1,NFRE - DO IJ = KIJS,KIJL - IF (KMAX(IJ,M).LT.1.0E-34_JWRB) THEN - KK(IJ,1:NANG,M) = 1.0_JWRB - ELSE - KK(IJ,1:NANG,M) = KK(IJ,1:NANG,M)/KMAX(IJ,M) - END IF + DO K = 1,NANG + DO IJ = KIJS,KIJL + IF (KMAX(IJ,M).LT.1.0E-34_JWRB) THEN + KK(IJ,K,M) = 1.0_JWRB + ELSE + KK(IJ,K,M) = KK(IJ,K,M)/KMAX(IJ,M) + END IF + END DO END DO END DO - DO IJ = KIJS,KIJL - ANAR(IJ,:) = 1.0_JWRB/( SUM(KK(IJ,:,:),1) * DELTH ) - BN(IJ,:) = ANAR(IJ,:) * ( ABAND(IJ,:) * SIG * DELTH ) * WAVNUM(IJ,:)**3 + DO M = 1,NFRE + DO IJ = KIJS,KIJL + SUMDIR_IJ(IJ) = 0.0_JWRB + END DO + DO K = 1,NANG + DO IJ = KIJS,KIJL + SUMDIR_IJ(IJ) = SUMDIR_IJ(IJ) + KK(IJ,K,M) + END DO + END DO + DO IJ = KIJS,KIJL + ANAR(IJ,M) = 1.0_JWRB/( SUMDIR_IJ(IJ) * DELTH ) + BN(IJ,M) = ANAR(IJ,M) * ( ABAND(IJ,M) * SIG(M) * DELTH ) * WAVNUM(IJ,M)**3 + END DO END DO ! @@ -149,9 +174,16 @@ SUBROUTINE SWLDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & !/ the peak wavenumber. ZSWL6B1 remains a scaling constant, but !/ with different magnitude. --------------------------------- / DO IJ = KIJS,KIJL - M = MAXLOC(ABAND(IJ,:),1) ! Index for peak - B1(IJ) = ZSWL6B1*(2.0_JWRB*SQRT(SUM(ABAND(IJ,:)*DDEN/CGROUP(IJ,:)))*& - & WAVNUM(IJ,M)) + MPEAK(IJ) = MAXLOC(ABAND(IJ,:),1) ! Index for peak + SUMDIR_IJ(IJ) = 0.0_JWRB + END DO + DO K = 1,NFRE + DO IJ = KIJS,KIJL + SUMDIR_IJ(IJ) = SUMDIR_IJ(IJ) + ABAND(IJ,K)*DDEN(K)/CGROUP(IJ,K) + END DO + END DO + DO IJ = KIJS,KIJL + B1(IJ) = ZSWL6B1*(2.0_JWRB*SQRT(SUMDIR_IJ(IJ))*WAVNUM(IJ,MPEAK(IJ))) END DO END IF ! @@ -166,14 +198,13 @@ SUBROUTINE SWLDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & ! !/ 3) --- Apply dissipation term of derivative to all directions ----- / DO K = 1, NANG - DO IJ = KIJS,KIJL - D(IJ,K,:) = DDIS(IJ,:) + DO M = 1,NFRE + DO IJ = KIJS,KIJL + D(IJ,K,M) = DDIS(IJ,M) + DSWL(IJ,K,M) = D(IJ,K,M) + END DO END DO END DO -! - DO IJ = KIJS,KIJL - DSWL(IJ,:,:) = D(IJ,:,:) - END DO DO M = 1,NFRE DO K = 1, NANG From cc3c78c37c9b3ab5537cae547f89bcf65a564171 Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Tue, 28 Apr 2026 16:31:32 +0000 Subject: [PATCH 76/89] refactoring for efficiency --- src/ecwam/sdissip_zbry.F90 | 38 ++++++---------------- src/ecwam/sinflx_zbry.F90 | 61 ++++++++++-------------------------- src/ecwam/swldissip_zbry.F90 | 24 +++----------- 3 files changed, 31 insertions(+), 92 deletions(-) diff --git a/src/ecwam/sdissip_zbry.F90 b/src/ecwam/sdissip_zbry.F90 index d579a1267..63649269b 100644 --- a/src/ecwam/sdissip_zbry.F90 +++ b/src/ecwam/sdissip_zbry.F90 @@ -106,10 +106,7 @@ SUBROUTINE SDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & REAL(KIND=JWRB) :: XFAC ! temporary variableis REAL(KIND=JWRB), DIMENSION(KIJL) :: EDENSMAX ! temporary variable - REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE) :: D, A - REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE) :: CG2 - REAL(KIND=JWRB), DIMENSION(NANG,NFRE) :: SIG2 - REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE) :: DDS + REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE) :: A REAL(KIND=JWRB), DIMENSION(KIJL) :: CUMADF REAL(KIND=JPHOOK) :: ZHOOK_HANDLE @@ -120,10 +117,8 @@ SUBROUTINE SDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & DO M = 1, NFRE DO K = 1, NANG ! Apply to all directions - SIG2(K,M) = SIG(M) DO IJ = KIJS,KIJL - CG2(IJ,K,M) = CGROUP(IJ,M) - A(IJ,K,M) = FL1(IJ,K,M) * CG2(IJ,K,M) / ( ZPI * SIG2(K,M) ) ! ACTION DENSITY SPECTRUM + A(IJ,K,M) = FL1(IJ,K,M) * CGROUP(IJ,M) / ( ZPI * SIG(M) ) ! ACTION DENSITY SPECTRUM END DO END DO END DO @@ -201,16 +196,12 @@ SUBROUTINE SDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & END IF END DO + DO IJ = KIJS,KIJL + CUMADF(IJ) = 0.0_JWRB + END DO DO M = 1,NFRE DO IJ = KIJS,KIJL - CUMADF(IJ) = 0.0_JWRB - END DO - DO I = 1,M - DO IJ = KIJS,KIJL - CUMADF(IJ) = CUMADF(IJ) + ADF(IJ,I)*DFII(I) - END DO - END DO - DO IJ = KIJS,KIJL + CUMADF(IJ) = CUMADF(IJ) + ADF(IJ,M)*DFII(M) T2(IJ,M) = ZSDS6A2 * CUMADF(IJ) END DO END DO @@ -222,23 +213,14 @@ SUBROUTINE SDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & END DO END DO - DO K = 1, NANG - DO M = 1, NFRE - DO IJ = KIJS,KIJL - D(IJ,K,M) = T12(IJ,M) - DDS(IJ,K,M) = D(IJ,K,M) - END DO - END DO - END DO - IF (LLLOWWINDS) THEN DO M = 1,NFRE DO K = 1, NANG DO IJ = KIJS,KIJL IF ( WSWAVE(IJ)>=5._JWRB) THEN ! no dissipation for winds<5m/s (following Muhammad Yasrab's work) - SL(IJ,K,M) = SL(IJ,K,M) + DDS(IJ,K,M)*FL1(IJ,K,M) - FLD(IJ,K,M) = FLD(IJ,K,M) + DDS(IJ,K,M) + SL(IJ,K,M) = SL(IJ,K,M) + T12(IJ,M)*FL1(IJ,K,M) + FLD(IJ,K,M) = FLD(IJ,K,M) + T12(IJ,M) END IF END DO END DO @@ -247,8 +229,8 @@ SUBROUTINE SDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & DO M = 1,NFRE DO K = 1, NANG DO IJ = KIJS,KIJL - SL(IJ,K,M) = SL(IJ,K,M) + DDS(IJ,K,M)*FL1(IJ,K,M) - FLD(IJ,K,M) = FLD(IJ,K,M) + DDS(IJ,K,M) + SL(IJ,K,M) = SL(IJ,K,M) + T12(IJ,M)*FL1(IJ,K,M) + FLD(IJ,K,M) = FLD(IJ,K,M) + T12(IJ,M) END DO END DO END DO diff --git a/src/ecwam/sinflx_zbry.F90 b/src/ecwam/sinflx_zbry.F90 index 16b1064ca..33bb23e37 100644 --- a/src/ecwam/sinflx_zbry.F90 +++ b/src/ecwam/sinflx_zbry.F90 @@ -171,12 +171,10 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & INTEGER(KIND=JWIM) :: IJ, K, M, IND, IGST -REAL(KIND=JWRB), DIMENSION(NANG,NFRE) :: ECOS2, ESIN2, SIG2 REAL(KIND=JWRB), DIMENSION(NANG,NFRE) :: SPOSDENSIG, SNEGDENSIG -REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE) :: CG2, WN2 -REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE) :: SQRTBN2, CINV2, A -REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: ADENSIG, KMAX, ANAR, SQRTBN, CINV1 +REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE) :: A +REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: ADENSIG, KMAX, ANAR, SQRTBN REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE) :: KK REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE,NGST) :: W1, W2, S, D REAL(KIND=JWRB), DIMENSION(KIJL,NFRE,NGST) :: LFACT @@ -268,15 +266,6 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & ENDDO -DO M = 1, NFRE - ECOS2(:,M) = COSTH - ESIN2(:,M) = SINTH -END DO -! -DO K = 1, NANG ! Apply to all directions - SIG2(K,:) = SIG -END DO - ! ESTIMATE THE STANDARD DEVIATION OF GUSTINESS. CALL WSIGSTAR (KIJS, KIJL, WSWAVE, UFRIC, Z0M, WSTAR, SIG_N, SIG_U10) AVG_GST = 1.0_JWRB/NGST @@ -312,19 +301,6 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & !/ --- Main loop over LOC ----------------------------------- / -DO M = 1, NFRE - DO K = 1, NANG - DO IJ = KIJS,KIJL - WN2(IJ,K,M) = WAVNUM(IJ,M) ! using WAM native WN,CG - CG2(IJ,K,M) = CGROUP(IJ,M) - CINV2(IJ,K,M) = WN2(IJ,K,M) / SIG2(K,M) ! inverse phase speed - END DO - END DO - DO IJ = KIJS,KIJL - CINV1(IJ,M) = CINV2(IJ,1,M) - END DO -END DO - !/ 0) --- set up a basic variables ----------------------------------- / DO IJ = KIJS,KIJL COSU(IJ) = COS(WDWAVE(IJ)) @@ -378,7 +354,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & DO M = 1, NFRE DO K = 1, NANG DO IJ = KIJS,KIJL - A(IJ,K,M) = FL1(IJ,K,M) * CG2(IJ,K,M) / ( ZPI * SIG2(K,M) ) ! ACTION DENSITY SPECTRUM + A(IJ,K,M) = FL1(IJ,K,M) * CGROUP(IJ,M) / ( ZPI * SIG(M) ) ! ACTION DENSITY SPECTRUM KK(IJ,K,M) = A(IJ,K,M) END DO END DO @@ -423,11 +399,6 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & SQRTBN(IJ,M) = SQRT( ANAR(IJ,M) * ADENSIG(IJ,M) * WAVNUM(IJ,M)**3 ) END DO - DO K = 1, NANG - DO IJ = KIJS,KIJL - SQRTBN2(IJ,K,M) = SQRTBN(IJ,M) ! Calculate SQRTBN for - END DO ! the entire spectrum. - END DO END DO ! !/ 4) --- calculate growth rate GAMMA and S for all directions for @@ -439,14 +410,14 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & DO K = 1, NANG DO IJ = KIJS,KIJL W1(IJ,K,M,IGST) = MAX(0.0_JWRB, & - & UPROXYGST(IJ,IGST)*CINV2(IJ,K,M)*(ECOS2(K,M)*COSU(IJ) + ESIN2(K,M)*SINU(IJ)) - 1.0_JWRB)**2 - D(IJ,K,M,IGST) = (RAORW(IJ)) * SIG2(K,M) * & - (2.8_JWRB-(1.0_JWRB+TANH(10.0_JWRB*SQRTBN2(IJ,K,M)*W1(IJ,K,M,IGST)-11.0_JWRB)))* & - & SQRTBN2(IJ,K,M)*W1(IJ,K,M,IGST) + & UPROXYGST(IJ,IGST)*CINV(IJ,M)*(COSTH(K)*COSU(IJ) + SINTH(K)*SINU(IJ)) - 1.0_JWRB)**2 + D(IJ,K,M,IGST) = (RAORW(IJ)) * SIG(M) * & + (2.8_JWRB-(1.0_JWRB+TANH(10.0_JWRB*SQRTBN(IJ,M)*W1(IJ,K,M,IGST)-11.0_JWRB)))* & + & SQRTBN(IJ,M)*W1(IJ,K,M,IGST) IF (LLLOWWINDS .AND. UABSGST(IJ,IGST)<=1.5_JWRB) THEN ! Reduce growth rates for low winds (following Muhammad Yasrab's work) - D(IJ,K,M,IGST) = D(IJ,K,M,IGST) - (4._JWRB*(RNU_WATER)*(WN2(IJ,K,M)**2)) + D(IJ,K,M,IGST) = D(IJ,K,M,IGST) - (4._JWRB*(RNU_WATER)*(WAVNUM(IJ,M)**2)) END IF S(IJ,K,M,IGST) = D(IJ,K,M,IGST) * A(IJ,K,M) END DO @@ -463,13 +434,13 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & DO M = 1, NFRE DO K = 1, NANG DO IJ = KIJS,KIJL - SDENSIG(IJ,K,M,IGST) = S(IJ,K,M,IGST)*SIG2(K,M)/CG2(IJ,K,M) + SDENSIG(IJ,K,M,IGST) = S(IJ,K,M,IGST)*SIG(M)/CGROUP(IJ,M) END DO END DO END DO DO IJ = KIJS,KIJL - CALL LFACTOR(SDENSIG(IJ,:,:,IGST), CINV1(IJ,:), UABSGST(IJ,IGST), USTARGST(IJ,IGST), UPROXYGST(IJ,IGST), WDWAVE(IJ), & + CALL LFACTOR(SDENSIG(IJ,:,:,IGST), CINV(IJ,:), UABSGST(IJ,IGST), USTARGST(IJ,IGST), UPROXYGST(IJ,IGST), WDWAVE(IJ), & & ROAIRN(IJ), LFACT(IJ,:,IGST), TAUWX(IJ,IGST), TAUWY(IJ,IGST), TAU(IJ,IGST)) ENDDO @@ -503,17 +474,17 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & DO M = 1, NFRE DO K = 1, NANG DO IJ = KIJS,KIJL - W2(IJ,K,M,IGST) = MIN( 0.0_JWRB,UPROXYGST(IJ,IGST) * CINV2(IJ,K,M) * & - & (ECOS2(K,M)*COSU(IJ) + ESIN2(K,M)*SINU(IJ)) - 1.0_JWRB )**2 - D(IJ,K,M,IGST) = D(IJ,K,M,IGST) - ( RAORW(IJ) * SIG2(K,M) * ZSIN6A0 * & - (2.8_JWRB-(1.0_JWRB+TANH(10.0_JWRB*SQRTBN2(IJ,K,M)*W2(IJ,K,M,IGST) - 11.0_JWRB)))& - & *SQRTBN2(IJ,K,M)*W2(IJ,K,M,IGST) ) + W2(IJ,K,M,IGST) = MIN( 0.0_JWRB,UPROXYGST(IJ,IGST) * CINV(IJ,M) * & + & (COSTH(K)*COSU(IJ) + SINTH(K)*SINU(IJ)) - 1.0_JWRB )**2 + D(IJ,K,M,IGST) = D(IJ,K,M,IGST) - ( RAORW(IJ) * SIG(M) * ZSIN6A0 * & + (2.8_JWRB-(1.0_JWRB+TANH(10.0_JWRB*SQRTBN(IJ,M)*W2(IJ,K,M,IGST) - 11.0_JWRB)))& + & *SQRTBN(IJ,M)*W2(IJ,K,M,IGST) ) DINTOT(IJ,K,M,IGST) = D(IJ,K,M,IGST) S(IJ,K,M,IGST) = D(IJ,K,M,IGST) * A(IJ,K,M) ! ! --- compute negative component of the wave supported stresses ! ! from negative part of the wind input ---------------------- / - SDENSIG(IJ,K,M,IGST) = S(IJ,K,M,IGST)*SIG2(K,M)/CG2(IJ,K,M) + SDENSIG(IJ,K,M,IGST) = S(IJ,K,M,IGST)*SIG(M)/CGROUP(IJ,M) END DO END DO END DO diff --git a/src/ecwam/swldissip_zbry.F90 b/src/ecwam/swldissip_zbry.F90 index 31363aa63..3b2344c5c 100644 --- a/src/ecwam/swldissip_zbry.F90 +++ b/src/ecwam/swldissip_zbry.F90 @@ -87,10 +87,8 @@ SUBROUTINE SWLDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: ABAND, KMAX, ANAR, BN, DDIS REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE) :: KK - REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE) :: D, A, CG2 + REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE) :: A REAL(KIND=JWRB), DIMENSION(KIJL) :: B1, SUMDIR_IJ - REAL(KIND=JWRB), DIMENSION(NANG,NFRE) :: SIG2 - REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE) :: DSWL REAL(KIND=JPHOOK) :: ZHOOK_HANDLE @@ -100,10 +98,8 @@ SUBROUTINE SWLDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & DO M = 1, NFRE DO K = 1, NANG ! Apply to all directions - SIG2(K,M) = SIG(M) DO IJ = KIJS,KIJL - CG2(IJ,K,M) = CGROUP(IJ,M) - A(IJ,K,M) = FL1(IJ,K,M) * CG2(IJ,K,M) / ( ZPI * SIG2(K,M) ) ! ACTION DENSITY SPECTRUM + A(IJ,K,M) = FL1(IJ,K,M) * CGROUP(IJ,M) / ( ZPI * SIG(M) ) ! ACTION DENSITY SPECTRUM END DO END DO END DO @@ -119,7 +115,6 @@ SUBROUTINE SWLDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & DO K = 1, NANG DO IJ = KIJS,KIJL ABAND(IJ,M) = ABAND(IJ,M) + A(IJ,K,M) - D(IJ,K,M) = 0.0_JWRB END DO END DO END DO @@ -197,21 +192,12 @@ SUBROUTINE SWLDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & END DO ! !/ 3) --- Apply dissipation term of derivative to all directions ----- / - DO K = 1, NANG - DO M = 1,NFRE - DO IJ = KIJS,KIJL - D(IJ,K,M) = DDIS(IJ,M) - DSWL(IJ,K,M) = D(IJ,K,M) - END DO - END DO - END DO - DO M = 1,NFRE DO K = 1, NANG DO IJ = KIJS,KIJL - SL(IJ,K,M) = SL(IJ,K,M) + DSWL(IJ,K,M)*FL1(IJ,K,M) - FLD(IJ,K,M) = FLD(IJ,K,M) + DSWL(IJ,K,M) - END DO + SL(IJ,K,M) = SL(IJ,K,M) + DDIS(IJ,M)*FL1(IJ,K,M) + FLD(IJ,K,M) = FLD(IJ,K,M) + DDIS(IJ,M) + END DO END DO END DO From 7e7667312e9de11527ebd85b4d455a6a0b7a4f29 Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Wed, 29 Apr 2026 07:51:17 +0000 Subject: [PATCH 77/89] tidy up in/out & comment documentation thereof --- src/ecwam/airsea_zbry.F90 | 4 +- src/ecwam/sdissip_zbry.F90 | 14 +++---- src/ecwam/sinflx_zbry.F90 | 77 ++++++++++++++++++++---------------- src/ecwam/swldissip_zbry.F90 | 10 ++--- 4 files changed, 55 insertions(+), 50 deletions(-) diff --git a/src/ecwam/airsea_zbry.F90 b/src/ecwam/airsea_zbry.F90 index 13a4ecf65..de0a34ce2 100644 --- a/src/ecwam/airsea_zbry.F90 +++ b/src/ecwam/airsea_zbry.F90 @@ -25,14 +25,12 @@ SUBROUTINE AIRSEA_ZBRY (KIJS, KIJL, & !** INTERFACE. ! ---------- -! *CALL* *AIRSEA_ZBRY (KIJS, KIJL, FL1, WAVNUM, +! *CALL* *AIRSEA_ZBRY (KIJS, KIJL, ! U10, U10DIR, TAUW, TAUWDIR, ! US, Z0, Z0B, CHRNCK, ICODE_WND, IUSFG)* ! *KIJS* - INDEX OF FIRST GRIDPOINT. ! *KIJL* - INDEX OF LAST GRIDPOINT. -! *FL1* - SPECTRA -! *WAVNUM* - WAVE NUMBER ! *U10* - WINDSPEED U10. ! *U10DIR* - WINDSPEED DIRECTION. ! *TAUW* - WAVE STRESS. diff --git a/src/ecwam/sdissip_zbry.F90 b/src/ecwam/sdissip_zbry.F90 index 63649269b..5e84f4844 100644 --- a/src/ecwam/sdissip_zbry.F90 +++ b/src/ecwam/sdissip_zbry.F90 @@ -9,7 +9,7 @@ SUBROUTINE SDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & & WSWAVE, WAVNUM, CGROUP, & - & UFRIC, COSWDIF, RAORW) + & UFRIC, RAORW) ! ---------------------------------------------------------------------- !**** *SDISSIP_ZBRY* - COMPUTATION OF DISSIPATION SOURCE FUNCTION. @@ -29,19 +29,19 @@ SUBROUTINE SDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & !** INTERFACE. ! ---------- -! *CALL* *SDISSIP_ZBRY (KIJS, KIJL, FL1, FLD,SL,* -! WAVNUM, CGROUP, -! UFRIC, COSWDIF, RAORW)* +! *CALL* *SDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL,* +! WSWAVE, WAVNUM, CGROUP, +! UFRIC, RAORW)* ! *KIJS* - INDEX OF FIRST GRIDPOINT ! *KIJL* - INDEX OF LAST GRIDPOINT ! *FL1* - SPECTRUM. ! *FLD* - DIAGONAL MATRIX OF FUNCTIONAL DERIVATIVE ! *SL* - TOTAL SOURCE FUNCTION ARRAY +! *WSWAVE* - WIND SPEED IN M/S. ! *WAVNUM* - WAVE NUMBER ! *CGROUP* - GROUP SPEED ! *UFRIC* - FRICTION VELOCITY IN M/S. ! *RAORW* - RATIO AIR DENSITY TO WATER DENSITY -! *COSWDIF*- COS(TH(K)-WDWAVE(IJ)) ! METHOD. @@ -87,7 +87,6 @@ SUBROUTINE SDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(INOUT) :: FLD, SL REAL(KIND=JWRB), DIMENSION(KIJL,NFRE), INTENT(IN) :: WAVNUM, CGROUP REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: WSWAVE, UFRIC, RAORW - REAL(KIND=JWRB), DIMENSION(KIJL, NANG), INTENT(IN) :: COSWDIF INTEGER(KIND=JWIM) :: IJ, K, M, I, J @@ -105,7 +104,6 @@ SUBROUTINE SDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & REAL(KIND=JWRB) :: BNT ! empirical constant for wave breaking probability REAL(KIND=JWRB) :: XFAC ! temporary variableis REAL(KIND=JWRB), DIMENSION(KIJL) :: EDENSMAX ! temporary variable - REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE) :: A REAL(KIND=JWRB), DIMENSION(KIJL) :: CUMADF @@ -124,7 +122,7 @@ SUBROUTINE SDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & END DO !/ 0) --- Initialize essential parameters ---------------------------- / - FREQ = FR(1:NFRE) + FREQ(:) = FR(1:NFRE) BNT = 0.035_JWRB**2 DO M = 1, NFRE DO IJ = KIJS,KIJL diff --git a/src/ecwam/sinflx_zbry.F90 b/src/ecwam/sinflx_zbry.F90 index 33bb23e37..da66860b6 100644 --- a/src/ecwam/sinflx_zbry.F90 +++ b/src/ecwam/sinflx_zbry.F90 @@ -13,7 +13,6 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & & WAVNUM,CGROUP, CINV, & & WSWAVE, WDWAVE, AIRD, & & RAORW, WSTAR, CICOVER, & - & COSWDIF, SINWDIF2, & & FMEAN, HALP, FMEANWS, & & FLM, & & UFRIC, TAUW, TAUWDIR, & @@ -37,36 +36,49 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & !** INTERFACE. ! ---------- -! *CALL* *SINFLX_ZBRY (NGST, LLSNEG, KIJS, KIJL, FL1, -! & WAVNUM, CGROUP, CINV, -! & WSWAVE, WDWAVE, UFRIC, Z0M, -! & COSWDIF, SINWDIF2, -! & RAORW, WSTAR, RNFAC, -! & FLD, SL, SPOS, XLLWS) -! *NGST* - IF = 1 THEN NO GUSTINESS PARAMETERISATION -! - IF = 2 THEN GUSTINESS PARAMETERISATION -! *LLSNEG- IF TRUE THEN THE NEGATIVE SINPUT (SWELL DAMPING) WILL BE COMPUTED -! *KIJS* - INDEX OF FIRST GRIDPOINT. -! *KIJL* - INDEX OF LAST GRIDPOINT. -! *FL1* - SPECTRUM. -! *WAVNUM* - WAVE NUMBER. -! *CGROUP* - GROUP SPEED -! *CINV* - INVERSE PHASE VELOCITY. -! *WDWAVE* - WIND DIRECTION IN RADIANS IN OCEANOGRAPHIC -! NOTATION (POINTING ANGLE OF WIND VECTOR, -! CLOCKWISE FROM NORTH). -! *UFRIC* - NEW FRICTION VELOCITY IN M/S. -! *Z0M* - ROUGHNESS LENGTH IN M. -! *COSWDIF* - COS(TH(K)-WDWAVE(IJ)) -! *SINWDIF2* - SIN(TH(K)-WDWAVE(IJ))**2 -! *RAORW* - RATIO AIR DENSITY TO WATER DENSITY. -! *WSTAR* - FREE CONVECTION VELOCITY SCALE (M/S). -! *RNFAC* - WIND DEPENDENT FACTOR USED IN THE GROWTH RENORMALISATION. -! *CHRNCK*- CHARNOCK COEFFICIENT -! *FLD* - DIAGONAL MATRIX OF FUNCTIONAL DERIVATIVE. -! *SL* - TOTAL SOURCE FUNCTION ARRAY. -! *SPOS* - POSITIVE SOURCE FUNCTION ARRAY. -! *XLLWS* - = 1 WHERE SINPUT IS POSITIVE +! *CALL* *SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, LUPDTUS,* +! & FL1, WAVNUM, CGROUP, CINV, +! & WSWAVE, WDWAVE, AIRD, +! & RAORW, WSTAR, CICOVER, +! & FMEAN, HALP, FMEANWS, +! & FLM, +! & UFRIC, TAUW, TAUWDIR, +! & Z0M, Z0B, CHRNCK, PHIWA, +! & FLD, SL, SPOS, +! & MIJ, RHOWGDFTH, XLLWS) +! *ICALL* - CALL NUMBER. +! *NCALL* - TOTAL NUMBER OF CALLS. +! *NGST* - NUMBER OF GUST COMPONENTS. +! *KIJS* - INDEX OF FIRST GRIDPOINT. +! *KIJL* - INDEX OF LAST GRIDPOINT. +! *LUPDTUS* - IF TRUE, UFRIC/Z0M ARE UPDATED VIA AIRSEA. +! *FL1* - WAVE SPECTRUM. +! *WAVNUM* - WAVE NUMBER. +! *CGROUP* - GROUP VELOCITY. +! *CINV* - INVERSE PHASE VELOCITY. +! *WSWAVE* - WIND SPEED IN M/S. +! *WDWAVE* - WIND DIRECTION (OCEANOGRAPHIC CONVENTION). +! *AIRD* - AIR DENSITY (KG/M**3). +! *RAORW* - AIR/WATER DENSITY RATIO. +! *WSTAR* - FREE CONVECTION VELOCITY SCALE (M/S). +! *CICOVER* - SEA ICE COVER. +! *FMEAN* - MEAN FREQUENCY. +! *HALP* - 1/2 PHILLIPS PARAMETER. +! *FMEANWS* - MEAN FREQUENCY OF WINDSEA. +! *FLM* - SPECTRAL DENSITY MINIMUM VALUE. +! *UFRIC* - FRICTION VELOCITY (M/S). +! *TAUW* - WAVE STRESS ((M/S)**2). +! *TAUWDIR* - WAVE STRESS DIRECTION. +! *Z0M* - ROUGHNESS LENGTH (M). +! *Z0B* - BACKGROUND ROUGHNESS LENGTH. +! *CHRNCK* - CHARNOCK COEFFICIENT. +! *PHIWA* - ENERGY FLUX FROM WIND INTO WAVES. +! *FLD* - DIAGONAL MATRIX OF FUNCTIONAL DERIVATIVE. +! *SL* - TOTAL SOURCE FUNCTION ARRAY. +! *SPOS* - POSITIVE INPUT SOURCE COMPONENT. +! *MIJ* - LAST FREQUENCY INDEX OF PROGNOSTIC RANGE. +! *RHOWGDFTH* - WATER DENSITY * G * DF * DTHETA. +! *XLLWS* - WINDSEA MASK FROM INPUT SOURCE TERM. ! METHOD. ! ------- @@ -140,8 +152,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: RAORW !! RATIO AIR DENSITY TO WATER DENSITY. REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: WSTAR !! FREE CONVECTION VELOCITY SCALE (M/S) REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: CICOVER !! SEA ICE COVER. -REAL(KIND=JWRB), DIMENSION(KIJL, NANG), INTENT(IN) :: COSWDIF !! COS(TH(K)-WDWAVE(IJ)) -REAL(KIND=JWRB), DIMENSION(KIJL, NANG), INTENT(IN) :: SINWDIF2 !! SIN(TH(K)-WDWAVE(IJ))**2 + REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: FMEAN !! MEAN FREQUENCY. REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(INOUT) :: HALP !! 1/2 PHILLIPS PARAMETER REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(OUT) :: FMEANWS !! MEAN FREQUENCY OF THE WINDSEA. diff --git a/src/ecwam/swldissip_zbry.F90 b/src/ecwam/swldissip_zbry.F90 index 3b2344c5c..a950c2c95 100644 --- a/src/ecwam/swldissip_zbry.F90 +++ b/src/ecwam/swldissip_zbry.F90 @@ -9,7 +9,7 @@ SUBROUTINE SWLDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & & WAVNUM, CGROUP, & - & UFRIC, COSWDIF, RAORW) + & UFRIC, RAORW) ! ---------------------------------------------------------------------- !**** *SWLDISSIP_ZBRY* - COMPUTATION OF DISSIPATION SOURCE FUNCTION. @@ -24,9 +24,9 @@ SUBROUTINE SWLDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & !** INTERFACE. ! ---------- -! *CALL* *SWLDISSIP_ZBRY (KIJS, KIJL, FL1, FLD,SL,* -! WAVNUM, CGROUP, -! UFRIC, COSWDIF, RAORW)* +! *CALL* *SWLDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL,* +! WAVNUM, CGROUP, +! UFRIC, RAORW)* ! *KIJS* - INDEX OF FIRST GRIDPOINT ! *KIJL* - INDEX OF LAST GRIDPOINT ! *FL1* - SPECTRUM. @@ -36,7 +36,6 @@ SUBROUTINE SWLDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & ! *CGROUP* - GROUP SPEED ! *UFRIC* - FRICTION VELOCITY IN M/S. ! *RAORW* - RATIO AIR DENSITY TO WATER DENSITY -! *COSWDIF*- COS(TH(K)-WDWAVE(IJ)) ! METHOD. @@ -80,7 +79,6 @@ SUBROUTINE SWLDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(INOUT) :: FLD, SL REAL(KIND=JWRB), DIMENSION(KIJL,NFRE), INTENT(IN) :: WAVNUM, CGROUP REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: UFRIC, RAORW - REAL(KIND=JWRB), DIMENSION(KIJL, NANG), INTENT(IN) :: COSWDIF INTEGER(KIND=JWIM) :: IJ, M, I, J, M2, K2, K, NANGD INTEGER(KIND=JWIM), DIMENSION(KIJL) :: MPEAK From 90ab5491eb2cf97e05f778de7f2bb2a1700e6a95 Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Wed, 29 Apr 2026 10:35:05 +0000 Subject: [PATCH 78/89] further optimizations and refactorizations --- src/ecwam/airsea.F90 | 22 +++++++----- src/ecwam/airsea_zbry.F90 | 5 ++- src/ecwam/initmdl.F90 | 66 +++++++++++++++++++----------------- src/ecwam/lfactor.F90 | 31 ++++++++++------- src/ecwam/sdissip.F90 | 4 +-- src/ecwam/sinflx.F90 | 1 - src/ecwam/sinflx_ard_jan.F90 | 4 +-- src/ecwam/sinflx_zbry.F90 | 34 ++++++------------- 8 files changed, 84 insertions(+), 83 deletions(-) diff --git a/src/ecwam/airsea.F90 b/src/ecwam/airsea.F90 index 8c3cb1576..247335e41 100644 --- a/src/ecwam/airsea.F90 +++ b/src/ecwam/airsea.F90 @@ -29,20 +29,17 @@ SUBROUTINE AIRSEA (KIJS, KIJL, & !** INTERFACE. ! ---------- -! *CALL* *AIRSEA (KIJS, KIJL, FL1, WAVNUM, -! HALP, U10, U10DIR, TAUW, TAUWDIR, RNFAC, -! US, Z0, Z0B, CHRNCK, ICODE_WND, IUSFG)* +! *CALL* *AIRSEA (KIJS, KIJL, +! U10, U10DIR, TAUW, TAUWDIR, +! US, Z0, Z0B, CHRNCK, ICODE_WND, IUSFG, +! HALP, RNFAC)* ! *KIJS* - INDEX OF FIRST GRIDPOINT. ! *KIJL* - INDEX OF LAST GRIDPOINT. -! *FL1* - SPECTRA -! *WAVNUM* - WAVE NUMBER -! *HALP* - 1/2 PHILLIPS PARAMETER ! *U10* - WINDSPEED U10. ! *U10DIR* - WINDSPEED DIRECTION. ! *TAUW* - WAVE STRESS. ! *TAUWDIR* - WAVE STRESS DIRECTION. -! *RNFAC* - WIND DEPENDENT FACTOR USED IN THE GROWTH RENORMALISATION. ! *US* - OUTPUT OR OUTPUT BLOCK OF FRICTION VELOCITY. ! *Z0* - OUTPUT BLOCK OF ROUGHNESS LENGTH. ! *Z0B* - BACKGROUND ROUGHNESS LENGTH. @@ -52,6 +49,8 @@ SUBROUTINE AIRSEA (KIJS, KIJL, & ! US: ICODE_WND=1 OR 2 --> U10 will be updated ! *IUSFG* - IF = 1 THEN USE THE FRICTION VELOCITY (US) AS FIRST GUESS in TAUT_Z0 ! 0 DO NOT USE THE FIELD US +! *HALP* - OPTIONAL 1/2 PHILLIPS PARAMETER (required for JAN branch). +! *RNFAC* - OPTIONAL WIND-DEPENDENT GROWTH RENORMALISATION FACTOR (required for JAN branch). ! ---------------------------------------------------------------------- @@ -74,7 +73,8 @@ SUBROUTINE AIRSEA (KIJS, KIJL, & #include "airsea_zbry.intfb.h" INTEGER(KIND=JWIM), INTENT(IN) :: KIJS, KIJL, ICODE_WND, IUSFG - REAL(KIND=JWRB), DIMENSION(KIJL), INTENT (IN) :: HALP, U10DIR, TAUW, TAUWDIR, RNFAC + REAL(KIND=JWRB), DIMENSION(KIJL), INTENT (IN), OPTIONAL :: HALP, RNFAC + REAL(KIND=JWRB), DIMENSION(KIJL), INTENT (IN) :: U10DIR, TAUW, TAUWDIR REAL(KIND=JWRB), DIMENSION(KIJL), INTENT (INOUT) :: U10, US, CHRNCK REAL(KIND=JWRB), DIMENSION(KIJL), INTENT (OUT) :: Z0, Z0B @@ -90,6 +90,12 @@ SUBROUTINE AIRSEA (KIJS, KIJL, & SELECT CASE (IPHYS) CASE(0,1) + IF ((.NOT.PRESENT(HALP)) .OR. (.NOT.PRESENT(RNFAC))) THEN + WRITE (IU06, * ) ' ++++++++++++++++++++++++++++++++++++++++++' + WRITE (IU06, * ) ' + AIRSEA : HALP/RNFAC REQUIRED FOR JAN +' + WRITE (IU06, * ) ' ++++++++++++++++++++++++++++++++++++++++++' + CALL ABORT1 + ENDIF CALL AIRSEA_JAN (KIJS, KIJL, & & HALP, U10, U10DIR, TAUW, TAUWDIR, RNFAC, & & US, Z0, Z0B, CHRNCK, ICODE_WND, IUSFG) diff --git a/src/ecwam/airsea_zbry.F90 b/src/ecwam/airsea_zbry.F90 index de0a34ce2..de6bd52af 100644 --- a/src/ecwam/airsea_zbry.F90 +++ b/src/ecwam/airsea_zbry.F90 @@ -51,7 +51,7 @@ SUBROUTINE AIRSEA_ZBRY (KIJS, KIJL, & USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU USE YOWPARAM, ONLY : NANG ,NFRE - USE YOWPHYS, ONLY : XKAPPA, XNLEV, ALPHA + USE YOWPHYS, ONLY : XKAPPA, XNLEV, ALPHA, RNU_WATER USE YOWSTAT, ONLY : IPHYS2_AIRSEA, ZCDFAC USE YOWPCONS, ONLY : G USE YOWTEST, ONLY : IU06 @@ -75,7 +75,6 @@ SUBROUTINE AIRSEA_ZBRY (KIJS, KIJL, & REAL(KIND=JWRB) :: ZNLEV REAL(KIND=JWRB), PARAMETER :: RKAP = 0.4_JWRB - REAL(KIND=JWRB), PARAMETER :: ZRN=1.65E-6_JWRB ! effective kinematic viscosity (0.11*1.5e-5) ! TODO: use instead RNU_WATER ! for the ietrative scheme INTEGER(KIND=JWIM), PARAMETER :: NITER=15 @@ -157,7 +156,7 @@ SUBROUTINE AIRSEA_ZBRY (KIJS, KIJL, & DO ITER=1,NITER USTOLD = MAX(UST,USTMIN) Z0CH = PCHAROG*UST**2 - Z0VIS = ZRN/UST + Z0VIS = RNU_WATER/UST Z0(IJ) = Z0CH+Z0VIS XZNLEV = ZNLEV/(ZNLEV+Z0(IJ)) XOLOGZ0 = 1.0_JWRB/LOG(1.0_JWRB+ZNLEV/Z0(IJ)) diff --git a/src/ecwam/initmdl.F90 b/src/ecwam/initmdl.F90 index 05ba0f159..33bb5e824 100644 --- a/src/ecwam/initmdl.F90 +++ b/src/ecwam/initmdl.F90 @@ -504,39 +504,41 @@ SUBROUTINE INITMDL (NADV, & ENDDO ! -------------------------------------------------- - ! TODO: ZBRY switch to not slow down runtime for IPHYS=0,1? - IF (.NOT.ALLOCATED(DF)) ALLOCATE(DF(NFRE)) - IF (.NOT.ALLOCATED(SIG)) ALLOCATE(SIG(NFRE)) - IF (.NOT.ALLOCATED(DDEN)) ALLOCATE(DDEN(NFRE)) - IF (.NOT.ALLOCATED(DSII)) ALLOCATE(DSII(NFRE)) - IF (.NOT.ALLOCATED(SIGM1)) ALLOCATE(SIGM1(NFRE)) - DO M=1,NFRE - DF(M) = DFIM(M)/DELTH - SIG(M) = ZPI*FR(M) - DSII(M) = ZPI*DF(M) - DDEN(M) = ZPI*DFIM(M)*SIG(M) - SIGM1(M) = 1.0_JWRB/SIG(M) - ENDDO + ! ZBRY-specific frequency-space setup (only needed for IPHYS=2). + IF (IPHYS == 2) THEN + IF (.NOT.ALLOCATED(DF)) ALLOCATE(DF(NFRE)) + IF (.NOT.ALLOCATED(SIG)) ALLOCATE(SIG(NFRE)) + IF (.NOT.ALLOCATED(DDEN)) ALLOCATE(DDEN(NFRE)) + IF (.NOT.ALLOCATED(DSII)) ALLOCATE(DSII(NFRE)) + IF (.NOT.ALLOCATED(SIGM1)) ALLOCATE(SIGM1(NFRE)) + DO M=1,NFRE + DF(M) = DFIM(M)/DELTH + SIG(M) = ZPI*FR(M) + DSII(M) = ZPI*DF(M) + DDEN(M) = ZPI*DFIM(M)*SIG(M) + SIGM1(M) = 1.0_JWRB/SIG(M) + ENDDO - ! DETERMINE THE NUMBER OF FREQUENCIES TO EXTEND TO - NFRE_EXT = CEILING(LOG(FRQMAX/FR(1))/LOG(FRATIO))+1 - NFRE_EXT = MAX(NFRE,NFRE_EXT) - IF (ALLOCATED(IFRE_EXT)) THEN - IF (SIZE(IFRE_EXT) /= NFRE_EXT) DEALLOCATE(IFRE_EXT) - END IF - IF (.NOT.ALLOCATED(IFRE_EXT)) ALLOCATE(IFRE_EXT(NFRE_EXT)) - IFRE_EXT = (/ (REAL(M, KIND=JWRB), M=1,NFRE_EXT) /) - IF (.NOT.ALLOCATED(SIG_EXT)) ALLOCATE(SIG_EXT(NFRE_EXT)) - IF (.NOT.ALLOCATED(DSII_EXT)) ALLOCATE(DSII_EXT(NFRE_EXT)) - IF (NFRE .LT. NFRE_EXT) THEN - SIG_EXT = SIG(1)*FRATIO**(IFRE_EXT-1.0_JWRB) - DSII_EXT = 0.5_JWRB * SIG_EXT * (FRATIO-1.0_JWRB/FRATIO) - ! The first and last frequency bin: - DSII_EXT(1) = 0.5_JWRB * SIG_EXT(1) * (FRATIO-1.0_JWRB) - DSII_EXT(NFRE_EXT) = 0.5_JWRB * SIG_EXT(NFRE_EXT) * (FRATIO-1.0_JWRB) / FRATIO - ELSE - SIG_EXT = SIG - DSII_EXT = DSII + ! DETERMINE THE NUMBER OF FREQUENCIES TO EXTEND TO + NFRE_EXT = CEILING(LOG(FRQMAX/FR(1))/LOG(FRATIO))+1 + NFRE_EXT = MAX(NFRE,NFRE_EXT) + IF (ALLOCATED(IFRE_EXT)) THEN + IF (SIZE(IFRE_EXT) /= NFRE_EXT) DEALLOCATE(IFRE_EXT) + END IF + IF (.NOT.ALLOCATED(IFRE_EXT)) ALLOCATE(IFRE_EXT(NFRE_EXT)) + IFRE_EXT = (/ (REAL(M, KIND=JWRB), M=1,NFRE_EXT) /) + IF (.NOT.ALLOCATED(SIG_EXT)) ALLOCATE(SIG_EXT(NFRE_EXT)) + IF (.NOT.ALLOCATED(DSII_EXT)) ALLOCATE(DSII_EXT(NFRE_EXT)) + IF (NFRE .LT. NFRE_EXT) THEN + SIG_EXT = SIG(1)*FRATIO**(IFRE_EXT-1.0_JWRB) + DSII_EXT = 0.5_JWRB * SIG_EXT * (FRATIO-1.0_JWRB/FRATIO) + ! The first and last frequency bin: + DSII_EXT(1) = 0.5_JWRB * SIG_EXT(1) * (FRATIO-1.0_JWRB) + DSII_EXT(NFRE_EXT) = 0.5_JWRB * SIG_EXT(NFRE_EXT) * (FRATIO-1.0_JWRB) / FRATIO + ELSE + SIG_EXT = SIG + DSII_EXT = DSII + END IF END IF ! -------------------------------------------------- diff --git a/src/ecwam/lfactor.F90 b/src/ecwam/lfactor.F90 index 44573f901..c68fcae77 100644 --- a/src/ecwam/lfactor.F90 +++ b/src/ecwam/lfactor.F90 @@ -7,7 +7,7 @@ ! nor does it submit to any jurisdiction. SUBROUTINE LFACTOR(S, CINV, U10, USTAR, UPROXY, USDIR, ROAIRN, & - & LFACT, TAUWX, TAUWY, TAU) + & LFACT, LREDUCE, TAUWX, TAUWY, TAU) ! ---------------------------------------------------------------------------- ! @@ -86,6 +86,7 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, UPROXY, USDIR, ROAIRN, & REAL(KIND=JWRB), INTENT(IN) :: U10, USTAR, UPROXY, USDIR, ROAIRN REAL(KIND=JWRB), DIMENSION(NFRE), INTENT(OUT) :: LFACT + LOGICAL, INTENT(OUT) :: LREDUCE REAL(KIND=JWRB), INTENT(OUT) :: TAUWX, TAUWY, TAU INTEGER(KIND=JWIM), PARAMETER :: ITERMAX = 80 ! Max. no. iterations @@ -97,11 +98,10 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, UPROXY, USDIR, ROAIRN, & REAL(KIND=JWRB) :: TAU_TOT, TAU_VIS, TAU_WAV REAL(KIND=JWRB) :: TAUVX, TAUVY, TAUX, TAUY - REAL(KIND=JWRB) :: TAU_NND, TAU_INIT(2) REAL(KIND=JWRB) :: RTAU, DRTAU, ERR LOGICAL :: OVERSHOT - INTEGER(KIND=JWIM) :: IK, K, SIGN_NEW, SIGN_OLD + INTEGER(KIND=JWIM) :: IK, K, M, SIGN_NEW, SIGN_OLD REAL(KIND=JPHOOK) :: ZHOOK_HANDLE @@ -114,13 +114,17 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, UPROXY, USDIR, ROAIRN, & ! wind input only. ---------------------------------------------- / IF (NFRE .LT. NFRE_EXT) THEN CINV_EXT(1:NFRE) = CINV - SDENS_EXT(1:NFRE) = SUM(S,1) * DELTH SDENSX_EXT(1:NFRE) = 0.0_JWRB SDENSY_EXT(1:NFRE) = 0.0_JWRB + SDENS_EXT(1:NFRE) = 0.0_JWRB DO K = 1, NANG - SDENSX_EXT(1:NFRE) = SDENSX_EXT(1:NFRE) + MAX(0.0_JWRB,S(K,1:NFRE))*COSTH(K) - SDENSY_EXT(1:NFRE) = SDENSY_EXT(1:NFRE) + MAX(0.0_JWRB,S(K,1:NFRE))*SINTH(K) + DO M = 1, NFRE + SDENS_EXT(M) = SDENS_EXT(M) + S(K,M) + SDENSX_EXT(M) = SDENSX_EXT(M) + MAX(0.0_JWRB,S(K,M))*COSTH(K) + SDENSY_EXT(M) = SDENSY_EXT(M) + MAX(0.0_JWRB,S(K,M))*SINTH(K) + END DO END DO + SDENS_EXT(1:NFRE) = SDENS_EXT(1:NFRE) * DELTH SDENSX_EXT(1:NFRE) = SDENSX_EXT(1:NFRE) * DELTH SDENSY_EXT(1:NFRE) = SDENSY_EXT(1:NFRE) * DELTH ! --- Spectral slope for S_IN(F) is proportional to F**(-2) ------ / @@ -130,13 +134,17 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, UPROXY, USDIR, ROAIRN, & SDENSY_EXT(NFRE+1:NFRE_EXT) = SDENSY_EXT(NFRE) * (SIG_EXT(NFRE)/SIG_EXT(NFRE+1:NFRE_EXT))**2 ELSE CINV_EXT = CINV - SDENS_EXT(1:NFRE) = SUM(S,1) * DELTH SDENSX_EXT(1:NFRE) = 0.0_JWRB SDENSY_EXT(1:NFRE) = 0.0_JWRB + SDENS_EXT(1:NFRE) = 0.0_JWRB DO K = 1, NANG - SDENSX_EXT(1:NFRE) = SDENSX_EXT(1:NFRE) + MAX(0.0_JWRB,S(K,1:NFRE))*COSTH(K) - SDENSY_EXT(1:NFRE) = SDENSY_EXT(1:NFRE) + MAX(0.0_JWRB,S(K,1:NFRE))*SINTH(K) + DO M = 1, NFRE + SDENS_EXT(M) = SDENS_EXT(M) + S(K,M) + SDENSX_EXT(M) = SDENSX_EXT(M) + MAX(0.0_JWRB,S(K,M))*COSTH(K) + SDENSY_EXT(M) = SDENSY_EXT(M) + MAX(0.0_JWRB,S(K,M))*SINTH(K) + END DO END DO + SDENS_EXT(1:NFRE) = SDENS_EXT(1:NFRE) * DELTH SDENSX_EXT(1:NFRE) = SDENSX_EXT(1:NFRE) * DELTH SDENSY_EXT(1:NFRE) = SDENSY_EXT(1:NFRE) * DELTH END IF @@ -156,9 +164,7 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, UPROXY, USDIR, ROAIRN, & ! --- The wave supported stress. --------------------------------- / TAUWX = TAUWINDS(SDENSX_EXT,CINV_EXT,DSII_EXT) ! normal stress (x-component) TAUWY = TAUWINDS(SDENSY_EXT,CINV_EXT,DSII_EXT) ! normal stress (y-component) - TAU_NND = TAUWINDS(SDENS_EXT, CINV_EXT,DSII_EXT) ! normal stress (non-directional) TAU_WAV = SQRT(TAUWX**2 + TAUWY**2) ! normal stress (magnitude) - TAU_INIT = (/TAUWX,TAUWY/) ! unadjusted normal stress components ! TAUX = TAUVX + TAUWX ! total stress (x-component) TAUY = TAUVY + TAUWY ! total stress (y-component) @@ -168,6 +174,7 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, UPROXY, USDIR, ROAIRN, & !/ 3) --- Find reduced Sin(f) = L(f)*Sin(f) to satisfy our constraint !/ TAU <= TAU_TOT --------------------------------------------- / LF_EXT = 1.0_JWRB + LREDUCE = .FALSE. IK = 0 ! IF (TAU .GT. TAU_TOT) THEN @@ -183,7 +190,6 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, UPROXY, USDIR, ROAIRN, & DO IK=1,ITERMAX LF_EXT = MIN(1.0_JWRB, EXP(UCINV_EXT * RTAU) ) - TAU_NND = TAUWINDS(SDENS_EXT *LF_EXT,CINV_EXT,DSII_EXT) TAUWX = TAUWINDS(SDENSX_EXT*LF_EXT,CINV_EXT,DSII_EXT) TAUWY = TAUWINDS(SDENSY_EXT*LF_EXT,CINV_EXT,DSII_EXT) TAU_WAV = SQRT(TAUWX**2 + TAUWY**2) @@ -208,6 +214,7 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, UPROXY, USDIR, ROAIRN, & END IF LFACT(1:NFRE) = LF_EXT(1:NFRE) + LREDUCE = ANY(LFACT(1:NFRE) .LT. 1.0_JWRB) IF (LHOOK) CALL DR_HOOK('LFACTOR',1,ZHOOK_HANDLE) diff --git a/src/ecwam/sdissip.F90 b/src/ecwam/sdissip.F90 index 668b937e1..7db531281 100644 --- a/src/ecwam/sdissip.F90 +++ b/src/ecwam/sdissip.F90 @@ -91,10 +91,10 @@ SUBROUTINE SDISSIP (KIJS, KIJL, FL1, FLD, SL, & !$loki inline CALL SDISSIP_ZBRY (KIJS, KIJL, FL1 ,FLD, SL, & & WSWAVE, WAVNUM, CGROUP, & - & UFRIC, COSWDIF, RAORW) + & UFRIC, RAORW) CALL SWLDISSIP_ZBRY(KIJS, KIJL, FL1 ,FLD, SL, & & WAVNUM, CGROUP, & - & UFRIC, COSWDIF, RAORW) + & UFRIC, RAORW) END SELECT IF (LHOOK) CALL DR_HOOK('SDISSIP',1,ZHOOK_HANDLE) diff --git a/src/ecwam/sinflx.F90 b/src/ecwam/sinflx.F90 index 5163f768a..571db65d8 100644 --- a/src/ecwam/sinflx.F90 +++ b/src/ecwam/sinflx.F90 @@ -121,7 +121,6 @@ SUBROUTINE SINFLX (ICALL, NCALL, KIJS, KIJL, & & WAVNUM,CGROUP, CINV, & & WSWAVE, WDWAVE, AIRD, & & RAORW, WSTAR, CICOVER, & - & COSWDIF, SINWDIF2, & & FMEAN, HALP, FMEANWS, & & FLM, & & UFRIC, TAUW, TAUWDIR, & diff --git a/src/ecwam/sinflx_ard_jan.F90 b/src/ecwam/sinflx_ard_jan.F90 index fe9cb24a3..ad4495bf9 100644 --- a/src/ecwam/sinflx_ard_jan.F90 +++ b/src/ecwam/sinflx_ard_jan.F90 @@ -140,8 +140,8 @@ SUBROUTINE SINFLX_ARD_JAN (ICALL, NCALL, KIJS, KIJL, & !$loki inline CALL AIRSEA (KIJS, KIJL, & -& HALP, WSWAVE, WDWAVE, TAUW, TAUWDIR, RNFAC, & -& UFRIC, Z0M, Z0B, CHRNCK, ICODE_WND, IUSFG) +& HALP=HALP, U10=WSWAVE, U10DIR=WDWAVE, TAUW=TAUW, TAUWDIR=TAUWDIR, RNFAC=RNFAC, & +& US=UFRIC, Z0=Z0M, Z0B=Z0B, CHRNCK=CHRNCK, ICODE_WND=ICODE_WND, IUSFG=IUSFG) ENDIF diff --git a/src/ecwam/sinflx_zbry.F90 b/src/ecwam/sinflx_zbry.F90 index da66860b6..75ed4e8b2 100644 --- a/src/ecwam/sinflx_zbry.F90 +++ b/src/ecwam/sinflx_zbry.F90 @@ -178,7 +178,6 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & INTEGER(KIND=JWIM) :: IUSFG, ICODE_WND REAL(KIND=JPHOOK) :: ZHOOK_HANDLE -REAL(KIND=JWRB), DIMENSION(KIJL) :: RNFAC INTEGER(KIND=JWIM) :: IJ, K, M, IND, IGST @@ -189,7 +188,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE) :: KK REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE,NGST) :: W1, W2, S, D REAL(KIND=JWRB), DIMENSION(KIJL,NFRE,NGST) :: LFACT -REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE,NGST) :: SDENSIG, DINPOS, DINTOT +REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE,NGST) :: DINPOS, DINTOT REAL(KIND=JWRB), DIMENSION(KIJL,NGST) :: TAUWX, TAUWY ! Component of the wave-supported stress @@ -200,7 +199,6 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & ! For USTAR, Z0, CHNK REAL(KIND=JWRB), DIMENSION(KIJL,NGST) :: TAU -REAL(KIND=JWRB), PARAMETER :: ZRN=1.65E-6_JWRB ! effective kinematic viscosity (0.11*1.5e-5) ! TODO: use instead RNU_WATER REAL(KIND=JWRB), PARAMETER :: RKAP = 0.4_JWRB REAL(KIND=JWRB) :: ZNLEV, Z0, KUOUST, USTM1, USTM2 REAL(KIND=JWRB), PARAMETER :: XEPS=0.00001_JWRB @@ -228,6 +226,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE) :: SLGST_AVG, SPOSGST_AVG, FLGST_AVG REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE,NGST) :: SLGST, SPOSGST, FLGST REAL(KIND=JWRB), DIMENSION(NANG,NFRE) :: SPOS_IJ, SNEG_IJ +REAL(KIND=JWRB), DIMENSION(NANG,NFRE) :: SDENSIG_IJ LOGICAL, DIMENSION(KIJL) :: LREDUCE ! ---------------------------------------------------------------------- @@ -248,14 +247,10 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & ENDIF IF(LUPDTUS) THEN - ! Dummy values for AIRSEA !TODO: implement these as optional arguments in AIRSEA - RNFAC(KIJS:KIJL) = 1.0_JWRB - HALP(KIJS:KIJL) = 0.0_JWRB - !$loki inline CALL AIRSEA (KIJS, KIJL, & -& HALP, WSWAVE, WDWAVE, TAUW, TAUWDIR, RNFAC, & -& UFRIC, Z0M, Z0B, CHRNCK, ICODE_WND, IUSFG) +& U10=WSWAVE, U10DIR=WDWAVE, TAUW=TAUW, TAUWDIR=TAUWDIR, & +& US=UFRIC, Z0=Z0M, Z0B=Z0B, CHRNCK=CHRNCK, ICODE_WND=ICODE_WND, IUSFG=IUSFG) ENDIF @@ -442,24 +437,18 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & ! spectral density of the wind input ------------------------- / DO IGST=1,NGST - DO M = 1, NFRE - DO K = 1, NANG - DO IJ = KIJS,KIJL - SDENSIG(IJ,K,M,IGST) = S(IJ,K,M,IGST)*SIG(M)/CGROUP(IJ,M) + DO IJ = KIJS,KIJL + DO M = 1, NFRE + DO K = 1, NANG + SDENSIG_IJ(K,M) = S(IJ,K,M,IGST)*SIG(M)/CGROUP(IJ,M) END DO END DO - END DO - - DO IJ = KIJS,KIJL - CALL LFACTOR(SDENSIG(IJ,:,:,IGST), CINV(IJ,:), UABSGST(IJ,IGST), USTARGST(IJ,IGST), UPROXYGST(IJ,IGST), WDWAVE(IJ), & - & ROAIRN(IJ), LFACT(IJ,:,IGST), TAUWX(IJ,IGST), TAUWY(IJ,IGST), TAU(IJ,IGST)) + CALL LFACTOR(SDENSIG_IJ, CINV(IJ,:), UABSGST(IJ,IGST), USTARGST(IJ,IGST), UPROXYGST(IJ,IGST), WDWAVE(IJ), & + & ROAIRN(IJ), LFACT(IJ,:,IGST), LREDUCE(IJ), TAUWX(IJ,IGST), TAUWY(IJ,IGST), TAU(IJ,IGST)) ENDDO !/ 6) --- apply reduction (LFACT) to the entire spectrum ------------- / - DO IJ = KIJS,KIJL - LREDUCE(IJ) = SUM(LFACT(IJ,:,IGST)) .LT. NFRE - END DO DO M = 1, NFRE DO K = 1, NANG DO IJ = KIJS,KIJL @@ -495,7 +484,6 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & ! ! --- compute negative component of the wave supported stresses ! ! from negative part of the wind input ---------------------- / - SDENSIG(IJ,K,M,IGST) = S(IJ,K,M,IGST)*SIG(M)/CGROUP(IJ,M) END DO END DO END DO @@ -614,7 +602,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & Z0 = ZNLEV / ( EXP(KUOUST) - 1.0_JWRB ) Z0 = MAX(Z0, 0.0000001_JWRB) Z0M(IJ) = Z0 ! Update z0 - CHNKOG(IJ) = ( Z0 - ZRN*USTM1 ) * USTM2 ! Update charnock (where Z0=Z0CH+Z0VIS from airsea_zbry) + CHNKOG(IJ) = ( Z0 - RNU_WATER*USTM1 ) * USTM2 ! Update charnock (where Z0=Z0CH+Z0VIS from airsea_zbry) ALPHAOGMAXU10 = MIN(ALPHAMAX,AMAX+BMAX*WSWAVE(IJ))*GM1 ! protective code taken from outbeta (incl /G) CHNKOG(IJ) = MIN(CHNKOG(IJ),ALPHAOGMAXU10) ! protective code taken from outbeta (incl /G) From d73ed523fcad70b1c0f019d6d143bae590d598c2 Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Wed, 29 Apr 2026 12:35:02 +0000 Subject: [PATCH 79/89] tauwinds into tauwindsxy for efficiency --- src/ecwam/CMakeLists.txt | 2 +- src/ecwam/calcphiwa.F90 | 2 +- src/ecwam/lfactor.F90 | 35 ++++++++++-------- src/ecwam/sinflx_zbry.F90 | 6 +-- src/ecwam/tau_wave_atmos.F90 | 9 ++--- src/ecwam/tauwinds.F90 | 9 ++++- src/ecwam/tauwindsxy.F90 | 72 ++++++++++++++++++++++++++++++++++++ src/ecwam/tauwxy.F90 | 72 ++++++++++++++++++++++++++++++++++++ 8 files changed, 179 insertions(+), 28 deletions(-) create mode 100644 src/ecwam/tauwindsxy.F90 create mode 100644 src/ecwam/tauwxy.F90 diff --git a/src/ecwam/CMakeLists.txt b/src/ecwam/CMakeLists.txt index 811a51afd..4814d231e 100644 --- a/src/ecwam/CMakeLists.txt +++ b/src/ecwam/CMakeLists.txt @@ -265,7 +265,7 @@ list( APPEND ecwam_srcs tau_phi_hf.F90 tau_wave_atmos.F90 taut_z0.F90 - tauwinds.F90 + tauwindsxy.F90 topoar.F90 transf.F90 transf_bfi.F90 diff --git a/src/ecwam/calcphiwa.F90 b/src/ecwam/calcphiwa.F90 index 4fa6a21d7..ac9c2b366 100644 --- a/src/ecwam/calcphiwa.F90 +++ b/src/ecwam/calcphiwa.F90 @@ -17,7 +17,7 @@ FUNCTION CALCPHIWA(SPOS,SNEG) RESULT(PHIWA) ! ORIGIN. ! ---------- -! Adapted from TAUWINDS +! Adapted from TAUWINDSXY ! Implementation into ECWAM DECEMBER 2021 by J. Kousal ! ---------------------------------------------------------------------------- diff --git a/src/ecwam/lfactor.F90 b/src/ecwam/lfactor.F90 index c68fcae77..0afad1fbb 100644 --- a/src/ecwam/lfactor.F90 +++ b/src/ecwam/lfactor.F90 @@ -45,20 +45,24 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, UPROXY, USDIR, ROAIRN, & !** INTERFACE. ! ---------- -! *CALL* *LFACTOR(S, CINV, U10, USTAR, USDIR, ROAIRN, SIG, DSII, & -! & LFACT, TAUWX, TAUWY, TAU) -! *S* - NEG. WIND INPUT ENERGY DENSITY SPECTRUM. -! *CINV* - INVERSE PHASE SPEED CALC. IN INPUT ROUTINE -! *UABS* - 10M WIND SPEED -! *USTAR* - NEW FRICTION VELOCITY IN M/S. -! *USDIR* - WIND DIRECTION -! *ROAIRN* - AIR DENSITY IN KG/M3 -! *LFACT* - CORRECTION FACTOR -! *TAUNWX, TAUNWY* - NEGATIVE WAVE NORMAL STRESS COMPONENTS +! *CALL* *LFACTOR(S, CINV, U10, USTAR, UPROXY, USDIR, ROAIRN, & +! & LFACT, LREDUCE, TAUWX, TAUWY, TAU) +! *S* - WIND INPUT ENERGY DENSITY SPECTRUM. +! *CINV* - INVERSE PHASE SPEED. +! *U10* - 10M WIND SPEED. +! *USTAR* - FRICTION VELOCITY IN M/S. +! *UPROXY* - PROXY WIND SPEED USED IN LFACT FORMULA. +! *USDIR* - WIND DIRECTION. +! *ROAIRN* - AIR DENSITY IN KG/M3. +! *LFACT* - CORRECTION FACTOR. +! *LREDUCE* - TRUE WHEN REDUCTION IS ACTUALLY APPLIED. +! *TAUWX* - WAVE-SUPPORTED STRESS X-COMPONENT. +! *TAUWY* - WAVE-SUPPORTED STRESS Y-COMPONENT. +! *TAU* - TOTAL STRESS MAGNITUDE. ! EXTERNALS. ! ---------- -! TAUWINDS +! TAUWINDSXY ! ORIGIN. ! ---------- @@ -79,7 +83,8 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, UPROXY, USDIR, ROAIRN, & ! ---------------------------------------------------------------------- IMPLICIT NONE -#include "tauwinds.intfb.h" + +#include "tauwindsxy.intfb.h" REAL(KIND=JWRB), DIMENSION(NANG,NFRE), INTENT(IN) :: S ! Sin(sigma) in [m2/rad-Hz] REAL(KIND=JWRB), DIMENSION(NFRE), INTENT(IN) :: CINV @@ -162,8 +167,7 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, UPROXY, USDIR, ROAIRN, & TAUVY = TAU_VIS * SIN(USDIR) ! ! --- The wave supported stress. --------------------------------- / - TAUWX = TAUWINDS(SDENSX_EXT,CINV_EXT,DSII_EXT) ! normal stress (x-component) - TAUWY = TAUWINDS(SDENSY_EXT,CINV_EXT,DSII_EXT) ! normal stress (y-component) + CALL TAUWINDSXY(SDENSX_EXT, SDENSY_EXT, CINV_EXT, DSII_EXT, NFRE_EXT, TAUWX, TAUWY) TAU_WAV = SQRT(TAUWX**2 + TAUWY**2) ! normal stress (magnitude) ! TAUX = TAUVX + TAUWX ! total stress (x-component) @@ -190,8 +194,7 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, UPROXY, USDIR, ROAIRN, & DO IK=1,ITERMAX LF_EXT = MIN(1.0_JWRB, EXP(UCINV_EXT * RTAU) ) - TAUWX = TAUWINDS(SDENSX_EXT*LF_EXT,CINV_EXT,DSII_EXT) - TAUWY = TAUWINDS(SDENSY_EXT*LF_EXT,CINV_EXT,DSII_EXT) + CALL TAUWINDSXY(SDENSX_EXT*LF_EXT, SDENSY_EXT*LF_EXT, CINV_EXT, DSII_EXT, NFRE_EXT, TAUWX, TAUWY) TAU_WAV = SQRT(TAUWX**2 + TAUWY**2) TAUX = TAUVX + TAUWX TAUY = TAUVY + TAUWY diff --git a/src/ecwam/sinflx_zbry.F90 b/src/ecwam/sinflx_zbry.F90 index 75ed4e8b2..d8e1128b9 100644 --- a/src/ecwam/sinflx_zbry.F90 +++ b/src/ecwam/sinflx_zbry.F90 @@ -260,7 +260,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & ! ---------------------------------------------------------------------- ! ---------------------------------------------------------------------- ! ---------------------------------------------------------------------- -! input source term!!!! (start) +! input source term (start) ! Wind height ZNLEV = 10._JWRB @@ -431,7 +431,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & END DO END DO -IF (LLFACT) THEN ! TODO: how to make more efficient? is difficult... +IF (LLFACT) THEN ! TODO: can this be made still more efficient? !/ 5) --- calculate reduction factor LFACT using non-directional ! spectral density of the wind input ------------------------- / @@ -641,7 +641,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & END DO ! --------------------- -! input source term!!!! (end) +! input source term (end) ! ---------------------------------------------------------------------- ! ---------------------------------------------------------------------- ! ---------------------------------------------------------------------- diff --git a/src/ecwam/tau_wave_atmos.F90 b/src/ecwam/tau_wave_atmos.F90 index 25d848d88..f394bd556 100644 --- a/src/ecwam/tau_wave_atmos.F90 +++ b/src/ecwam/tau_wave_atmos.F90 @@ -38,7 +38,7 @@ SUBROUTINE TAU_WAVE_ATMOS(S, CINV, TAUNWX, TAUNWY ) ! EXTERNALS. ! ---------- -! TAUWINDS +! TAUWINDSXY ! ORIGIN. ! ---------- @@ -60,7 +60,8 @@ SUBROUTINE TAU_WAVE_ATMOS(S, CINV, TAUNWX, TAUNWY ) ! ---------------------------------------------------------------------- IMPLICIT NONE -#include "tauwinds.intfb.h" + +#include "tauwindsxy.intfb.h" REAL(KIND=JWRB), DIMENSION(NANG,NFRE), INTENT(IN) :: S ! Sin(sigma) in [m2/rad-Hz] REAL(KIND=JWRB), DIMENSION(NFRE), INTENT(IN) :: CINV @@ -103,9 +104,7 @@ SUBROUTINE TAU_WAVE_ATMOS(S, CINV, TAUNWX, TAUNWY ) SDENSX_LF = SUM(SX,1) * DELTH SDENSY_LF = SUM(SY,1) * DELTH - - TAUNWX_LF = TAUWINDS(SDENSX_LF,CINV,DSII) ! x-component - TAUNWY_LF = TAUWINDS(SDENSY_LF,CINV,DSII) ! y-component + CALL TAUWINDSXY(SDENSX_LF, SDENSY_LF, CINV, DSII, NFRE, TAUNWX_LF, TAUNWY_LF) !/ 2) --- high frequency contributions to the integral --------------------- / ! -- Assume spectral slope for S_IN(F) is proportional to F**(-2), then diff --git a/src/ecwam/tauwinds.F90 b/src/ecwam/tauwinds.F90 index a004fa507..7cdd34eea 100644 --- a/src/ecwam/tauwinds.F90 +++ b/src/ecwam/tauwinds.F90 @@ -45,15 +45,20 @@ FUNCTION TAUWINDS(SDENSIG,CINV,DSII) RESULT(TAU_WINDS) REAL(KIND=JWRB), INTENT(IN) :: CINV(:) ! inverse phase speed REAL(KIND=JWRB), INTENT(IN) :: DSII(:) ! freq. bandwidths in [radians] - REAL(KIND=JWRB) :: TAU_WINDS + REAL(KIND=JWRB) :: TAU_WINDS REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + INTEGER(KIND=JWIM) :: M ! ---------------------------------------------------------------------------- ! IF (LHOOK) CALL DR_HOOK('TAUWINDS',0,ZHOOK_HANDLE) - TAU_WINDS = G * ROWATER * SUM(SDENSIG*CINV*DSII) + TAU_WINDS = 0.0_JWRB + DO M = 1, SIZE(SDENSIG) + TAU_WINDS = TAU_WINDS + SDENSIG(M) * CINV(M) * DSII(M) + END DO + TAU_WINDS = G * ROWATER * TAU_WINDS IF (LHOOK) CALL DR_HOOK('TAUWINDS',1,ZHOOK_HANDLE) diff --git a/src/ecwam/tauwindsxy.F90 b/src/ecwam/tauwindsxy.F90 new file mode 100644 index 000000000..951de3490 --- /dev/null +++ b/src/ecwam/tauwindsxy.F90 @@ -0,0 +1,72 @@ +! (C) Copyright 1989- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. + + SUBROUTINE TAUWINDSXY(SDENSX_IN, SDENSY_IN, CINV_IN, DSII_IN, NPTS, TAUWX_OUT, TAUWY_OUT) + +! ---------------------------------------------------------------------------- +! +! 1. Purpose : +! +! Wind stress (tau) computation from wind-momentum-input +! function which can be obtained from wind-energy-input (Sin). +! +! / FRMAX +! tau = g * rho_water * | Sin(f)/C(f) df +! / + +!---------------------------------------------------------------------- +! +! INTERFACE VARIABLES. +! -------------------- + +! ORIGIN. +! ---------- +! Adapted from Babanin Young Donelan & Banner (ZBRY) physics +! as implemented as ST6 in WAVEWATCH-III +! Implementation into ECWAM DECEMBER 2021 by J. Kousal + +! ---------------------------------------------------------------------------- +! + + USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU + USE YOWPCONS , ONLY : G, ROWATER + USE YOMHOOK , ONLY : LHOOK ,DR_HOOK, JPHOOK + +!---------------------------------------------------------------------- + + + IMPLICIT NONE + + REAL(KIND=JWRB), INTENT(IN) :: SDENSX_IN(*), SDENSY_IN(*) + REAL(KIND=JWRB), INTENT(IN) :: CINV_IN(*), DSII_IN(*) + INTEGER(KIND=JWIM), INTENT(IN) :: NPTS + REAL(KIND=JWRB), INTENT(OUT) :: TAUWX_OUT, TAUWY_OUT + + INTEGER(KIND=JWIM) :: M + REAL(KIND=JWRB) :: SUMX, SUMY + REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +!---------------------------------------------------------------------- +! + + IF (LHOOK) CALL DR_HOOK('TAUWINDSXY',0,ZHOOK_HANDLE) + + SUMX = 0.0_JWRB + SUMY = 0.0_JWRB + + DO M = 1, NPTS + SUMX = SUMX + SDENSX_IN(M) * CINV_IN(M) * DSII_IN(M) + SUMY = SUMY + SDENSY_IN(M) * CINV_IN(M) * DSII_IN(M) + END DO + + TAUWX_OUT = G * ROWATER * SUMX + TAUWY_OUT = G * ROWATER * SUMY + + IF (LHOOK) CALL DR_HOOK('TAUWINDSXY',1,ZHOOK_HANDLE) + + END SUBROUTINE TAUWINDSXY \ No newline at end of file diff --git a/src/ecwam/tauwxy.F90 b/src/ecwam/tauwxy.F90 new file mode 100644 index 000000000..741d1278f --- /dev/null +++ b/src/ecwam/tauwxy.F90 @@ -0,0 +1,72 @@ +! (C) Copyright 1989- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. + + SUBROUTINE TAUWXY(SDENSX_IN, SDENSY_IN, CINV_IN, DSII_IN, TAUWX_OUT, TAUWY_OUT) + +! ---------------------------------------------------------------------------- +! +! 1. Purpose : +! +! Wind stress (tau) computation from wind-momentum-input +! function which can be obtained from wind-energy-input (Sin). +! +! / FRMAX +! tau = g * rho_water * | Sin(f)/C(f) df +! / + +!---------------------------------------------------------------------- +! +! INTERFACE VARIABLES. +! -------------------- + +! ORIGIN. +! ---------- +! Adapted from Babanin Young Donelan & Banner (ZBRY) physics +! as implemented as ST6 in WAVEWATCH-III +! Implementation into ECWAM DECEMBER 2021 by J. Kousal + +! ---------------------------------------------------------------------------- +! + + USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU + USE YOWFRED , ONLY : NFRE_EXT + USE YOWPCONS , ONLY : G, ROWATER + USE YOMHOOK , ONLY : LHOOK ,DR_HOOK, JPHOOK + +!---------------------------------------------------------------------- + + + IMPLICIT NONE + + REAL(KIND=JWRB), INTENT(IN) :: SDENSX_IN(NFRE_EXT), SDENSY_IN(NFRE_EXT) + REAL(KIND=JWRB), INTENT(IN) :: CINV_IN(NFRE_EXT), DSII_IN(NFRE_EXT) + REAL(KIND=JWRB), INTENT(OUT) :: TAUWX_OUT, TAUWY_OUT + + INTEGER(KIND=JWIM) :: M + REAL(KIND=JWRB) :: SUMX, SUMY + REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +!---------------------------------------------------------------------- +! + + IF (LHOOK) CALL DR_HOOK('TAUWXY',0,ZHOOK_HANDLE) + + SUMX = 0.0_JWRB + SUMY = 0.0_JWRB + + DO M = 1, NFRE_EXT + SUMX = SUMX + SDENSX_IN(M) * CINV_IN(M) * DSII_IN(M) + SUMY = SUMY + SDENSY_IN(M) * CINV_IN(M) * DSII_IN(M) + END DO + + TAUWX_OUT = G * ROWATER * SUMX + TAUWY_OUT = G * ROWATER * SUMY + + IF (LHOOK) CALL DR_HOOK('TAUWXY',1,ZHOOK_HANDLE) + + END SUBROUTINE TAUWXY From 8d05114edacd11d2ca42c57da32d63a8cec18e43 Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Wed, 29 Apr 2026 12:50:58 +0000 Subject: [PATCH 80/89] modify indentation --- src/ecwam/airsea_zbry.F90 | 230 +++++++++++++++---------------- src/ecwam/calcphiwa.F90 | 130 +++++++++--------- src/ecwam/lfactor.F90 | 184 ++++++++++++------------- src/ecwam/sdissip_zbry.F90 | 258 +++++++++++++++++------------------ src/ecwam/swldissip_zbry.F90 | 212 ++++++++++++++-------------- src/ecwam/tau_wave_atmos.F90 | 152 ++++++++++----------- src/ecwam/tauwindsxy.F90 | 36 ++--- 7 files changed, 601 insertions(+), 601 deletions(-) diff --git a/src/ecwam/airsea_zbry.F90 b/src/ecwam/airsea_zbry.F90 index de6bd52af..a868e6fe5 100644 --- a/src/ecwam/airsea_zbry.F90 +++ b/src/ecwam/airsea_zbry.F90 @@ -66,149 +66,149 @@ SUBROUTINE AIRSEA_ZBRY (KIJS, KIJL, & #include "taut_z0.intfb.h" #include "z0wave.intfb.h" - INTEGER(KIND=JWIM), INTENT(IN) :: KIJS, KIJL, ICODE_WND, IUSFG - REAL(KIND=JWRB), DIMENSION(KIJL), INTENT (IN) :: U10DIR, TAUW, TAUWDIR - REAL(KIND=JWRB), DIMENSION(KIJL), INTENT (INOUT) :: U10, US, CHRNCK - REAL(KIND=JWRB), DIMENSION(KIJL), INTENT (OUT) :: Z0, Z0B +INTEGER(KIND=JWIM), INTENT(IN) :: KIJS, KIJL, ICODE_WND, IUSFG +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT (IN) :: U10DIR, TAUW, TAUWDIR +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT (INOUT) :: U10, US, CHRNCK +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT (OUT) :: Z0, Z0B - INTEGER(KIND=JWIM) :: IJ, I, J +INTEGER(KIND=JWIM) :: IJ, I, J - REAL(KIND=JWRB) :: ZNLEV - REAL(KIND=JWRB), PARAMETER :: RKAP = 0.4_JWRB +REAL(KIND=JWRB) :: ZNLEV +REAL(KIND=JWRB), PARAMETER :: RKAP = 0.4_JWRB - ! for the ietrative scheme - INTEGER(KIND=JWIM), PARAMETER :: NITER=15 +! for the ietrative scheme +INTEGER(KIND=JWIM), PARAMETER :: NITER=15 ! CD=ACD+BCD*U10 - REAL(KIND=JWRB), PARAMETER :: ACD=0.0008_JWRB - REAL(KIND=JWRB), PARAMETER :: BCD=0.00008_JWRB +REAL(KIND=JWRB), PARAMETER :: ACD=0.0008_JWRB +REAL(KIND=JWRB), PARAMETER :: BCD=0.00008_JWRB ! CD = ACDLIN + BCDLIN*SQRT(PCHAR) * U10 - REAL(KIND=JWRB), PARAMETER :: ACDLIN=0.0008_JWRB - REAL(KIND=JWRB), PARAMETER :: BCDLIN=0.00047_JWRB - REAL(KIND=JWRB), PARAMETER :: XEPS=0.00001_JWRB - REAL(KIND=JWRB), PARAMETER :: USTMIN=0.000001_JWRB - REAL(KIND=JWRB), PARAMETER :: PCHARMAX=0.1_JWRB - REAL(KIND=JWRB), PARAMETER :: Z0FG=0.01_JWRB - - INTEGER(KIND=JWIM) :: ITER - REAL(KIND=JWRB) :: XZNLEV, PCHAROG, XKUTOP, XOLOGZ0 - REAL(KIND=JWRB) :: CDLIN, UST, USTOLD, Z0CH, Z0VIS, F, DELF - - REAL(KIND=JWRB) :: XI, XJ, DELI1, DELI2, DELJ1, DELJ2, UST2, ARG, SQRTCDM1 - REAL(KIND=JWRB) :: XKAPPAD, XLOGLEV - REAL(KIND=JWRB) :: XLEV, FLX4A0, CD - REAL(KIND=JPHOOK) :: ZHOOK_HANDLE +REAL(KIND=JWRB), PARAMETER :: ACDLIN=0.0008_JWRB +REAL(KIND=JWRB), PARAMETER :: BCDLIN=0.00047_JWRB +REAL(KIND=JWRB), PARAMETER :: XEPS=0.00001_JWRB +REAL(KIND=JWRB), PARAMETER :: USTMIN=0.000001_JWRB +REAL(KIND=JWRB), PARAMETER :: PCHARMAX=0.1_JWRB +REAL(KIND=JWRB), PARAMETER :: Z0FG=0.01_JWRB + +INTEGER(KIND=JWIM) :: ITER +REAL(KIND=JWRB) :: XZNLEV, PCHAROG, XKUTOP, XOLOGZ0 +REAL(KIND=JWRB) :: CDLIN, UST, USTOLD, Z0CH, Z0VIS, F, DELF + +REAL(KIND=JWRB) :: XI, XJ, DELI1, DELI2, DELJ1, DELJ2, UST2, ARG, SQRTCDM1 +REAL(KIND=JWRB) :: XKAPPAD, XLOGLEV +REAL(KIND=JWRB) :: XLEV, FLX4A0, CD +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ---------------------------------------------------------------------- - IF (LHOOK) CALL DR_HOOK ('AIRSEA_ZBRY', 0, ZHOOK_HANDLE) +IF (LHOOK) CALL DR_HOOK ('AIRSEA_ZBRY', 0, ZHOOK_HANDLE) !* 2. DETERMINE TOTAL STRESS AND ROUGHNESS (if needed) ! ---------------------------------- - IF (ICODE_WND == 3) THEN +IF (ICODE_WND == 3) THEN ! Wind height - ZNLEV = 10._JWRB + ZNLEV = 10._JWRB + + !$loki inline + SELECT CASE (IPHYS2_AIRSEA) + + ! implementation of Hwang (2011) as in ST6 + CASE(0,1) + ! IPHYS2_AIRSEA=0,1 use Hwang (2011) as in ST6 + FLX4A0 = ZCDFAC + DO IJ=KIJS,KIJL + IF (U10(IJ) .GE. 50.33_JWRB) THEN + US(IJ) = 2.026_JWRB * SQRT(FLX4A0) + CD = (US(IJ)/U10(IJ))**2 + ELSE + CD = FLX4A0 * ( 8.058_JWRB + 0.967_JWRB*U10(IJ) - 0.016_JWRB*U10(IJ)**2 ) * 1E-4_JWRB + US(IJ) = U10(IJ) * SQRT(CD) + END IF +! + Z0(IJ) = ZNLEV * EXP ( -0.4_JWRB / SQRT(CD) ) + Z0B(IJ) = ALPHA * (US(IJ)**2) / G ! background roughness: Charnock + + ENDDO - !$loki inline - SELECT CASE (IPHYS2_AIRSEA) + ! implementation of iterative scheme + CASE(2,3) + ! (IPHYS2_AIRSEA=3 only needs this iteration to get USTARGST -> UABSGST , but there is probably a smarter way to do this) + DO IJ=KIJS,KIJL + ! -------------------------------------------- + ! Iterative method - ! implementation of Hwang (2011) as in ST6 - CASE(0,1) - ! IPHYS2_AIRSEA=0,1 use Hwang (2011) as in ST6 - FLX4A0 = ZCDFAC - DO IJ=KIJS,KIJL - IF (U10(IJ) .GE. 50.33_JWRB) THEN - US(IJ) = 2.026_JWRB * SQRT(FLX4A0) - CD = (US(IJ)/U10(IJ))**2 - ELSE - CD = FLX4A0 * ( 8.058_JWRB + 0.967_JWRB*U10(IJ) - 0.016_JWRB*U10(IJ)**2 ) * 1E-4_JWRB - US(IJ) = U10(IJ) * SQRT(CD) - END IF - ! - Z0(IJ) = ZNLEV * EXP ( -0.4_JWRB / SQRT(CD) ) - Z0B(IJ) = ALPHA * (US(IJ)**2) / G ! background roughness: Charnock - - ENDDO - - ! implementation of iterative scheme - CASE(2,3) - ! (IPHYS2_AIRSEA=3 only needs this iteration to get USTARGST -> UABSGST , but there is probably a smarter way to do this) - DO IJ=KIJS,KIJL - ! -------------------------------------------- - ! Iterative method - - XKUTOP = RKAP*U10(IJ) - - ! Start with old charnock (and protect the scheme) - PCHAROG = MIN(CHRNCK(IJ),PCHARMAX)/G - - ! Cd as a linear relation with slope function of Charnock - CDLIN= ACDLIN + BCDLIN*SQRT(PCHAROG*G) * U10(IJ) - - ! first guess for u* - ! UST = U10(IJ)*SQRT(ACD+BCD*U10(IJ)) ! Use linear approx - ! UST = SQRT(CD)*U10(IJ) ! Use Hersbach approx - UST = SQRT(CDLIN)*U10(IJ) ! Use Hersbach approx - - ! iterate - DO ITER=1,NITER - USTOLD = MAX(UST,USTMIN) - Z0CH = PCHAROG*UST**2 - Z0VIS = RNU_WATER/UST - Z0(IJ) = Z0CH+Z0VIS - XZNLEV = ZNLEV/(ZNLEV+Z0(IJ)) - XOLOGZ0 = 1.0_JWRB/LOG(1.0_JWRB+ZNLEV/Z0(IJ)) - F = UST-XKUTOP*XOLOGZ0 - DELF = 1.0_JWRB-XKUTOP*XOLOGZ0**2*XZNLEV* & - & (2.0_JWRB*Z0CH-Z0VIS)/(UST*Z0(IJ)) - IF(DELF /= 0.0_JWRB) UST = UST-F/DELF - - IF(ABS(UST-USTOLD)<=UST*XEPS .AND. ABS(F)<=XEPS) EXIT - ENDDO - - ! Update Z0, US and then charnock - IF(ITER > NITER) THEN - ! failed to iterate - Z0(IJ) = Z0FG - US(IJ) = XKUTOP/LOG(1.0+ZNLEV/Z0(IJ)) - ELSE - US(IJ) = MAX(UST,USTMIN) - ! Z0(IJ) = Z0CH ! Commented out -> Z0=Z0TOT - ENDIF - - + XKUTOP = RKAP*U10(IJ) + + ! Start with old charnock (and protect the scheme) + PCHAROG = MIN(CHRNCK(IJ),PCHARMAX)/G + + ! Cd as a linear relation with slope function of Charnock + CDLIN= ACDLIN + BCDLIN*SQRT(PCHAROG*G) * U10(IJ) + + ! first guess for u* +! UST = U10(IJ)*SQRT(ACD+BCD*U10(IJ)) ! Use linear approx +! UST = SQRT(CD)*U10(IJ) ! Use Hersbach approx + UST = SQRT(CDLIN)*U10(IJ) ! Use Hersbach approx + + ! iterate + DO ITER=1,NITER + USTOLD = MAX(UST,USTMIN) + Z0CH = PCHAROG*UST**2 + Z0VIS = RNU_WATER/UST + Z0(IJ) = Z0CH+Z0VIS + XZNLEV = ZNLEV/(ZNLEV+Z0(IJ)) + XOLOGZ0 = 1.0_JWRB/LOG(1.0_JWRB+ZNLEV/Z0(IJ)) + F = UST-XKUTOP*XOLOGZ0 + DELF = 1.0_JWRB-XKUTOP*XOLOGZ0**2*XZNLEV* & + & (2.0_JWRB*Z0CH-Z0VIS)/(UST*Z0(IJ)) + IF(DELF /= 0.0_JWRB) UST = UST-F/DELF + + IF(ABS(UST-USTOLD)<=UST*XEPS .AND. ABS(F)<=XEPS) EXIT ENDDO - END SELECT - ELSEIF (ICODE_WND == 1 .OR. ICODE_WND == 2) THEN + ! Update Z0, US and then charnock + IF(ITER > NITER) THEN + ! failed to iterate + Z0(IJ) = Z0FG + US(IJ) = XKUTOP/LOG(1.0+ZNLEV/Z0(IJ)) + ELSE + US(IJ) = MAX(UST,USTMIN) + ! Z0(IJ) = Z0CH ! Commented out -> Z0=Z0TOT + ENDIF + + + ENDDO + END SELECT + +ELSEIF (ICODE_WND == 1 .OR. ICODE_WND == 2) THEN !* 3. DETERMINE ROUGHNESS LENGTH (if needed). ! --------------------------- - !$loki inline - CALL Z0WAVE (KIJS, KIJL, US, TAUW, U10, Z0, Z0B, CHRNCK) + !$loki inline + CALL Z0WAVE (KIJS, KIJL, US, TAUW, U10, Z0, Z0B, CHRNCK) !* 3. DETERMINE U10 (if needed). ! --------------------------- - XKAPPAD = 1.0_JWRB / XKAPPA - XLOGLEV = LOG (XNLEV) + XKAPPAD = 1.0_JWRB / XKAPPA + XLOGLEV = LOG (XNLEV) - DO IJ = KIJS, KIJL - U10 (IJ) = XKAPPAD * US (IJ) * (XLOGLEV - LOG (Z0 (IJ))) - U10 (IJ) = MAX (U10 (IJ), WSPMIN) - ENDDO + DO IJ = KIJS, KIJL + U10 (IJ) = XKAPPAD * US (IJ) * (XLOGLEV - LOG (Z0 (IJ))) + U10 (IJ) = MAX (U10 (IJ), WSPMIN) + ENDDO - ELSE - WRITE (IU06, * ) ' ++++++++++++++++++++++++++++++++++++++++++' - WRITE (IU06, * ) ' + AIRSEA_ZBRY : INVALID VALUE OF ICODE_WND +' - WRITE (IU06, * ) ' ICODE_WND = ', ICODE_WND - WRITE (IU06, * ) ' ++++++++++++++++++++++++++++++++++++++++++' - CALL ABORT1 - ENDIF +ELSE + WRITE (IU06, * ) ' ++++++++++++++++++++++++++++++++++++++++++' + WRITE (IU06, * ) ' + AIRSEA_ZBRY : INVALID VALUE OF ICODE_WND +' + WRITE (IU06, * ) ' ICODE_WND = ', ICODE_WND + WRITE (IU06, * ) ' ++++++++++++++++++++++++++++++++++++++++++' + CALL ABORT1 +ENDIF - IF (LHOOK) CALL DR_HOOK ('AIRSEA_ZBRY', 1, ZHOOK_HANDLE) +IF (LHOOK) CALL DR_HOOK ('AIRSEA_ZBRY', 1, ZHOOK_HANDLE) - END SUBROUTINE AIRSEA_ZBRY +END SUBROUTINE AIRSEA_ZBRY diff --git a/src/ecwam/calcphiwa.F90 b/src/ecwam/calcphiwa.F90 index ac9c2b366..4a77b6be6 100644 --- a/src/ecwam/calcphiwa.F90 +++ b/src/ecwam/calcphiwa.F90 @@ -33,72 +33,72 @@ FUNCTION CALCPHIWA(SPOS,SNEG) RESULT(PHIWA) IMPLICIT NONE - REAL(KIND=JWRB), DIMENSION(NANG,NFRE), INTENT(IN) :: SPOS ! POS Sin(sigma) in [m2/Hz] - REAL(KIND=JWRB), DIMENSION(NANG,NFRE), INTENT(IN) :: SNEG ! NEG Sin(sigma) in [m2/Hz] - - - REAL(KIND=JWRB), DIMENSION(NANG) :: ZA_SPOS, ZA_SNEG - - REAL(KIND=JWRB) :: SPOS_LF, SNEG_LF - REAL(KIND=JWRB) :: SPOS_HF, SNEG_HF - REAL(KIND=JWRB) :: PHIWA_HF, PHIWA_LF - - REAL(KIND=JWRB) :: PHIWA - REAL(KIND=JPHOOK) :: ZHOOK_HANDLE +REAL(KIND=JWRB), DIMENSION(NANG,NFRE), INTENT(IN) :: SPOS ! POS Sin(sigma) in [m2/Hz] +REAL(KIND=JWRB), DIMENSION(NANG,NFRE), INTENT(IN) :: SNEG ! NEG Sin(sigma) in [m2/Hz] + + +REAL(KIND=JWRB), DIMENSION(NANG) :: ZA_SPOS, ZA_SNEG + +REAL(KIND=JWRB) :: SPOS_LF, SNEG_LF +REAL(KIND=JWRB) :: SPOS_HF, SNEG_HF +REAL(KIND=JWRB) :: PHIWA_HF, PHIWA_LF + +REAL(KIND=JWRB) :: PHIWA +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ---------------------------------------------------------------------------- ! - IF (LHOOK) CALL DR_HOOK('CALCPHIWA',0,ZHOOK_HANDLE) - - !/ 0) --- split integral into low/high frequency contributions ------------- / - ! - ! - ! Th=2pi,f=inf Th=2pi,f=FR(NFRE) Th=2pi,f=inf - ! / / / / / / - ! | | S(f,Th) df dTh = | | S(f,Th) df dTh + | | S(f,Th) df dTh - ! / / / / / / - ! Th=0,f=0 Th=0,f=0 Th=0,f=FR(NFRE) - ! - ! - ! = LF_contribution + HF_contribution - ! - ! - !/ 1) --- low frequency contributions to the integral ---------------------- / - ! -- Direct summation over available freq. bins up to FR(NFRE) - ! - ! DFIM = DELTH * DF - ! - SPOS_LF = SUM(SUM(SPOS,1) * DFIM) - SNEG_LF = SUM(SUM(SNEG,1) * DFIM) - - PHIWA_LF = G * ROWATER * ( SPOS_LF + SNEG_LF ) - - !/ 2) --- high frequency contributions to the integral --------------------- / - ! -- Assume spectral slope for S_IN(F) is proportional to F**(-2), then - ! integral collapses into easy analytic solution - ! - ! - ! Th=2pi,f=inf - ! / / - ! | | S(f,Th) df dTh = FR(NFRE) * DELTH * SUM(S(:,NFRE)) - ! / / - ! Th=0,f=FR(NFRE) - ! - ! - ! Determine value of spectrum at NFRE (i.e. at highest frequency). - ! - Note, direction dimension must remain - ZA_SPOS = SPOS(:,NFRE) - ZA_SNEG = SNEG(:,NFRE) - - SPOS_HF = FR(NFRE) * DELTH * SUM(ZA_SPOS) - SNEG_HF = FR(NFRE) * DELTH * SUM(ZA_SNEG) - - PHIWA_HF = G * ROWATER * ( SPOS_HF + SNEG_HF ) - - !/ 3) --- summate low + high frequency contributions to the integral ------- / - PHIWA = PHIWA_LF + PHIWA_HF - - IF (LHOOK) CALL DR_HOOK('CALCPHIWA',1,ZHOOK_HANDLE) - - END FUNCTION CALCPHIWA +IF (LHOOK) CALL DR_HOOK('CALCPHIWA',0,ZHOOK_HANDLE) + +!/ 0) --- split integral into low/high frequency contributions ------------- / +! +! +! Th=2pi,f=inf Th=2pi,f=FR(NFRE) Th=2pi,f=inf +! / / / / / / +! | | S(f,Th) df dTh = | | S(f,Th) df dTh + | | S(f,Th) df dTh +! / / / / / / +! Th=0,f=0 Th=0,f=0 Th=0,f=FR(NFRE) +! +! +! = LF_contribution + HF_contribution +! +! +!/ 1) --- low frequency contributions to the integral ---------------------- / +! -- Direct summation over available freq. bins up to FR(NFRE) +! +! DFIM = DELTH * DF +! +SPOS_LF = SUM(SUM(SPOS,1) * DFIM) +SNEG_LF = SUM(SUM(SNEG,1) * DFIM) + +PHIWA_LF = G * ROWATER * ( SPOS_LF + SNEG_LF ) + +!/ 2) --- high frequency contributions to the integral --------------------- / +! -- Assume spectral slope for S_IN(F) is proportional to F**(-2), then +! integral collapses into easy analytic solution +! +! +! Th=2pi,f=inf +! / / +! | | S(f,Th) df dTh = FR(NFRE) * DELTH * SUM(S(:,NFRE)) +! / / +! Th=0,f=FR(NFRE) +! +! +! Determine value of spectrum at NFRE (i.e. at highest frequency). +! - Note, direction dimension must remain +ZA_SPOS = SPOS(:,NFRE) +ZA_SNEG = SNEG(:,NFRE) + +SPOS_HF = FR(NFRE) * DELTH * SUM(ZA_SPOS) +SNEG_HF = FR(NFRE) * DELTH * SUM(ZA_SNEG) + +PHIWA_HF = G * ROWATER * ( SPOS_HF + SNEG_HF ) + +!/ 3) --- summate low + high frequency contributions to the integral ------- / +PHIWA = PHIWA_LF + PHIWA_HF + +IF (LHOOK) CALL DR_HOOK('CALCPHIWA',1,ZHOOK_HANDLE) + +END FUNCTION CALCPHIWA diff --git a/src/ecwam/lfactor.F90 b/src/ecwam/lfactor.F90 index 0afad1fbb..249df8a9d 100644 --- a/src/ecwam/lfactor.F90 +++ b/src/ecwam/lfactor.F90 @@ -86,139 +86,139 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, UPROXY, USDIR, ROAIRN, & #include "tauwindsxy.intfb.h" - REAL(KIND=JWRB), DIMENSION(NANG,NFRE), INTENT(IN) :: S ! Sin(sigma) in [m2/rad-Hz] - REAL(KIND=JWRB), DIMENSION(NFRE), INTENT(IN) :: CINV - REAL(KIND=JWRB), INTENT(IN) :: U10, USTAR, UPROXY, USDIR, ROAIRN +REAL(KIND=JWRB), DIMENSION(NANG,NFRE), INTENT(IN) :: S ! Sin(sigma) in [m2/rad-Hz] +REAL(KIND=JWRB), DIMENSION(NFRE), INTENT(IN) :: CINV +REAL(KIND=JWRB), INTENT(IN) :: U10, USTAR, UPROXY, USDIR, ROAIRN - REAL(KIND=JWRB), DIMENSION(NFRE), INTENT(OUT) :: LFACT - LOGICAL, INTENT(OUT) :: LREDUCE - REAL(KIND=JWRB), INTENT(OUT) :: TAUWX, TAUWY, TAU +REAL(KIND=JWRB), DIMENSION(NFRE), INTENT(OUT) :: LFACT +LOGICAL, INTENT(OUT) :: LREDUCE +REAL(KIND=JWRB), INTENT(OUT) :: TAUWX, TAUWY, TAU - INTEGER(KIND=JWIM), PARAMETER :: ITERMAX = 80 ! Max. no. iterations - ! to find numerical LFACT soln +INTEGER(KIND=JWIM), PARAMETER :: ITERMAX = 80 ! Max. no. iterations + ! to find numerical LFACT soln - REAL(KIND=JWRB), DIMENSION(NFRE_EXT) :: LF_EXT, CINV_EXT - REAL(KIND=JWRB), DIMENSION(NFRE_EXT) :: SDENS_EXT, SDENSX_EXT, SDENSY_EXT - REAL(KIND=JWRB), DIMENSION(NFRE_EXT) :: UCINV_EXT +REAL(KIND=JWRB), DIMENSION(NFRE_EXT) :: LF_EXT, CINV_EXT +REAL(KIND=JWRB), DIMENSION(NFRE_EXT) :: SDENS_EXT, SDENSX_EXT, SDENSY_EXT +REAL(KIND=JWRB), DIMENSION(NFRE_EXT) :: UCINV_EXT - REAL(KIND=JWRB) :: TAU_TOT, TAU_VIS, TAU_WAV - REAL(KIND=JWRB) :: TAUVX, TAUVY, TAUX, TAUY - REAL(KIND=JWRB) :: RTAU, DRTAU, ERR - LOGICAL :: OVERSHOT +REAL(KIND=JWRB) :: TAU_TOT, TAU_VIS, TAU_WAV +REAL(KIND=JWRB) :: TAUVX, TAUVY, TAUX, TAUY +REAL(KIND=JWRB) :: RTAU, DRTAU, ERR +LOGICAL :: OVERSHOT - INTEGER(KIND=JWIM) :: IK, K, M, SIGN_NEW, SIGN_OLD +INTEGER(KIND=JWIM) :: IK, K, M, SIGN_NEW, SIGN_OLD - REAL(KIND=JPHOOK) :: ZHOOK_HANDLE +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ---------------------------------------------------------------------- - IF (LHOOK) CALL DR_HOOK('LFACTOR',0,ZHOOK_HANDLE) +IF (LHOOK) CALL DR_HOOK('LFACTOR',0,ZHOOK_HANDLE) !/ 1) --- Either extrapolate arrays up to 10Hz or use discrete spectral ! grid per se. Limit the constraint to the positive part of the ! wind input only. ---------------------------------------------- / - IF (NFRE .LT. NFRE_EXT) THEN - CINV_EXT(1:NFRE) = CINV - SDENSX_EXT(1:NFRE) = 0.0_JWRB - SDENSY_EXT(1:NFRE) = 0.0_JWRB - SDENS_EXT(1:NFRE) = 0.0_JWRB - DO K = 1, NANG - DO M = 1, NFRE - SDENS_EXT(M) = SDENS_EXT(M) + S(K,M) - SDENSX_EXT(M) = SDENSX_EXT(M) + MAX(0.0_JWRB,S(K,M))*COSTH(K) - SDENSY_EXT(M) = SDENSY_EXT(M) + MAX(0.0_JWRB,S(K,M))*SINTH(K) - END DO +IF (NFRE .LT. NFRE_EXT) THEN + CINV_EXT(1:NFRE) = CINV + SDENSX_EXT(1:NFRE) = 0.0_JWRB + SDENSY_EXT(1:NFRE) = 0.0_JWRB + SDENS_EXT(1:NFRE) = 0.0_JWRB + DO K = 1, NANG + DO M = 1, NFRE + SDENS_EXT(M) = SDENS_EXT(M) + S(K,M) + SDENSX_EXT(M) = SDENSX_EXT(M) + MAX(0.0_JWRB,S(K,M))*COSTH(K) + SDENSY_EXT(M) = SDENSY_EXT(M) + MAX(0.0_JWRB,S(K,M))*SINTH(K) END DO - SDENS_EXT(1:NFRE) = SDENS_EXT(1:NFRE) * DELTH - SDENSX_EXT(1:NFRE) = SDENSX_EXT(1:NFRE) * DELTH - SDENSY_EXT(1:NFRE) = SDENSY_EXT(1:NFRE) * DELTH + END DO + SDENS_EXT(1:NFRE) = SDENS_EXT(1:NFRE) * DELTH + SDENSX_EXT(1:NFRE) = SDENSX_EXT(1:NFRE) * DELTH + SDENSY_EXT(1:NFRE) = SDENSY_EXT(1:NFRE) * DELTH ! --- Spectral slope for S_IN(F) is proportional to F**(-2) ------ / - CINV_EXT(NFRE+1:NFRE_EXT) = SIG_EXT(NFRE+1:NFRE_EXT)*GM1 ! 1/c=σ/g - SDENS_EXT(NFRE+1:NFRE_EXT) = SDENS_EXT(NFRE) * (SIG_EXT(NFRE)/SIG_EXT(NFRE+1:NFRE_EXT))**2 - SDENSX_EXT(NFRE+1:NFRE_EXT) = SDENSX_EXT(NFRE) * (SIG_EXT(NFRE)/SIG_EXT(NFRE+1:NFRE_EXT))**2 - SDENSY_EXT(NFRE+1:NFRE_EXT) = SDENSY_EXT(NFRE) * (SIG_EXT(NFRE)/SIG_EXT(NFRE+1:NFRE_EXT))**2 - ELSE - CINV_EXT = CINV - SDENSX_EXT(1:NFRE) = 0.0_JWRB - SDENSY_EXT(1:NFRE) = 0.0_JWRB - SDENS_EXT(1:NFRE) = 0.0_JWRB - DO K = 1, NANG - DO M = 1, NFRE - SDENS_EXT(M) = SDENS_EXT(M) + S(K,M) - SDENSX_EXT(M) = SDENSX_EXT(M) + MAX(0.0_JWRB,S(K,M))*COSTH(K) - SDENSY_EXT(M) = SDENSY_EXT(M) + MAX(0.0_JWRB,S(K,M))*SINTH(K) - END DO + CINV_EXT(NFRE+1:NFRE_EXT) = SIG_EXT(NFRE+1:NFRE_EXT)*GM1 ! 1/c=σ/g + SDENS_EXT(NFRE+1:NFRE_EXT) = SDENS_EXT(NFRE) * (SIG_EXT(NFRE)/SIG_EXT(NFRE+1:NFRE_EXT))**2 + SDENSX_EXT(NFRE+1:NFRE_EXT) = SDENSX_EXT(NFRE) * (SIG_EXT(NFRE)/SIG_EXT(NFRE+1:NFRE_EXT))**2 + SDENSY_EXT(NFRE+1:NFRE_EXT) = SDENSY_EXT(NFRE) * (SIG_EXT(NFRE)/SIG_EXT(NFRE+1:NFRE_EXT))**2 +ELSE + CINV_EXT = CINV + SDENSX_EXT(1:NFRE) = 0.0_JWRB + SDENSY_EXT(1:NFRE) = 0.0_JWRB + SDENS_EXT(1:NFRE) = 0.0_JWRB + DO K = 1, NANG + DO M = 1, NFRE + SDENS_EXT(M) = SDENS_EXT(M) + S(K,M) + SDENSX_EXT(M) = SDENSX_EXT(M) + MAX(0.0_JWRB,S(K,M))*COSTH(K) + SDENSY_EXT(M) = SDENSY_EXT(M) + MAX(0.0_JWRB,S(K,M))*SINTH(K) END DO - SDENS_EXT(1:NFRE) = SDENS_EXT(1:NFRE) * DELTH - SDENSX_EXT(1:NFRE) = SDENSX_EXT(1:NFRE) * DELTH - SDENSY_EXT(1:NFRE) = SDENSY_EXT(1:NFRE) * DELTH - END IF + END DO + SDENS_EXT(1:NFRE) = SDENS_EXT(1:NFRE) * DELTH + SDENSX_EXT(1:NFRE) = SDENSX_EXT(1:NFRE) * DELTH + SDENSY_EXT(1:NFRE) = SDENSY_EXT(1:NFRE) * DELTH +END IF ! !/ 2) --- Stress calculation ----------------------------------------- / ! --- The total stress ------------------------------------------- / - TAU_TOT = USTAR**2 * ROAIRN +TAU_TOT = USTAR**2 * ROAIRN ! ! --- The viscous stress and check that it does not exceed ! the total stress. ------------------------------------------ / - TAU_VIS = MAX(0.0_JWRB, -5.0E-5_JWRB*U10 + 1.1E-3_JWRB) * U10**2 * ROAIRN - TAU_VIS = MIN(0.95_JWRB * TAU_TOT, TAU_VIS) +TAU_VIS = MAX(0.0_JWRB, -5.0E-5_JWRB*U10 + 1.1E-3_JWRB) * U10**2 * ROAIRN +TAU_VIS = MIN(0.95_JWRB * TAU_TOT, TAU_VIS) ! - TAUVX = TAU_VIS * COS(USDIR) - TAUVY = TAU_VIS * SIN(USDIR) +TAUVX = TAU_VIS * COS(USDIR) +TAUVY = TAU_VIS * SIN(USDIR) ! ! --- The wave supported stress. --------------------------------- / - CALL TAUWINDSXY(SDENSX_EXT, SDENSY_EXT, CINV_EXT, DSII_EXT, NFRE_EXT, TAUWX, TAUWY) - TAU_WAV = SQRT(TAUWX**2 + TAUWY**2) ! normal stress (magnitude) +CALL TAUWINDSXY(SDENSX_EXT, SDENSY_EXT, CINV_EXT, DSII_EXT, NFRE_EXT, TAUWX, TAUWY) +TAU_WAV = SQRT(TAUWX**2 + TAUWY**2) ! normal stress (magnitude) ! - TAUX = TAUVX + TAUWX ! total stress (x-component) - TAUY = TAUVY + TAUWY ! total stress (y-component) - TAU = SQRT(TAUX**2 + TAUY**2) ! total stress (magnitude) - ERR = (TAU-TAU_TOT)/TAU_TOT ! initial error +TAUX = TAUVX + TAUWX ! total stress (x-component) +TAUY = TAUVY + TAUWY ! total stress (y-component) +TAU = SQRT(TAUX**2 + TAUY**2) ! total stress (magnitude) +ERR = (TAU-TAU_TOT)/TAU_TOT ! initial error ! !/ 3) --- Find reduced Sin(f) = L(f)*Sin(f) to satisfy our constraint !/ TAU <= TAU_TOT --------------------------------------------- / - LF_EXT = 1.0_JWRB - LREDUCE = .FALSE. - IK = 0 +LF_EXT = 1.0_JWRB +LREDUCE = .FALSE. +IK = 0 ! - IF (TAU .GT. TAU_TOT) THEN +IF (TAU .GT. TAU_TOT) THEN - OVERSHOT = .FALSE. - RTAU = ERR / 90.0_JWRB - DRTAU = 2.0_JWRB + OVERSHOT = .FALSE. + RTAU = ERR / 90.0_JWRB + DRTAU = 2.0_JWRB - SIGN_NEW = INT(SIGN(1.0_JWRB,ERR)) + SIGN_NEW = INT(SIGN(1.0_JWRB,ERR)) - UCINV_EXT = 1.0_JWRB - (UPROXY * CINV_EXT) + UCINV_EXT = 1.0_JWRB - (UPROXY * CINV_EXT) - DO IK=1,ITERMAX + DO IK=1,ITERMAX - LF_EXT = MIN(1.0_JWRB, EXP(UCINV_EXT * RTAU) ) - CALL TAUWINDSXY(SDENSX_EXT*LF_EXT, SDENSY_EXT*LF_EXT, CINV_EXT, DSII_EXT, NFRE_EXT, TAUWX, TAUWY) - TAU_WAV = SQRT(TAUWX**2 + TAUWY**2) - TAUX = TAUVX + TAUWX - TAUY = TAUVY + TAUWY - TAU = SQRT(TAUX**2 + TAUY**2) - ERR = (TAU-TAU_TOT) / TAU_TOT - SIGN_OLD = SIGN_NEW - SIGN_NEW = INT(SIGN(1.0_JWRB, ERR)) + LF_EXT = MIN(1.0_JWRB, EXP(UCINV_EXT * RTAU) ) + CALL TAUWINDSXY(SDENSX_EXT*LF_EXT, SDENSY_EXT*LF_EXT, CINV_EXT, DSII_EXT, NFRE_EXT, TAUWX, TAUWY) + TAU_WAV = SQRT(TAUWX**2 + TAUWY**2) + TAUX = TAUVX + TAUWX + TAUY = TAUVY + TAUWY + TAU = SQRT(TAUX**2 + TAUY**2) + ERR = (TAU-TAU_TOT) / TAU_TOT + SIGN_OLD = SIGN_NEW + SIGN_NEW = INT(SIGN(1.0_JWRB, ERR)) ! --- Slow down DRTAU when overshot. -------------------------- / - IF (SIGN_NEW .NE. SIGN_OLD) OVERSHOT = .TRUE. - IF (OVERSHOT) DRTAU = MAX(0.5_JWRB*(1.0_JWRB+DRTAU),1.00010_JWRB) + IF (SIGN_NEW .NE. SIGN_OLD) OVERSHOT = .TRUE. + IF (OVERSHOT) DRTAU = MAX(0.5_JWRB*(1.0_JWRB+DRTAU),1.00010_JWRB) - RTAU = RTAU * (DRTAU**SIGN_NEW) + RTAU = RTAU * (DRTAU**SIGN_NEW) - IF (ABS(ERR) .LT. 1.54E-4_JWRB) EXIT - - END DO + IF (ABS(ERR) .LT. 1.54E-4_JWRB) EXIT + + END DO - END IF +END IF - LFACT(1:NFRE) = LF_EXT(1:NFRE) - LREDUCE = ANY(LFACT(1:NFRE) .LT. 1.0_JWRB) +LFACT(1:NFRE) = LF_EXT(1:NFRE) +LREDUCE = ANY(LFACT(1:NFRE) .LT. 1.0_JWRB) - IF (LHOOK) CALL DR_HOOK('LFACTOR',1,ZHOOK_HANDLE) +IF (LHOOK) CALL DR_HOOK('LFACTOR',1,ZHOOK_HANDLE) - END SUBROUTINE LFACTOR +END SUBROUTINE LFACTOR diff --git a/src/ecwam/sdissip_zbry.F90 b/src/ecwam/sdissip_zbry.F90 index 5e84f4844..b448627e4 100644 --- a/src/ecwam/sdissip_zbry.F90 +++ b/src/ecwam/sdissip_zbry.F90 @@ -81,159 +81,159 @@ SUBROUTINE SDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & IMPLICIT NONE - INTEGER(KIND=JWIM), INTENT(IN) :: KIJS, KIJL - - REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(IN) :: FL1 - REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(INOUT) :: FLD, SL - REAL(KIND=JWRB), DIMENSION(KIJL,NFRE), INTENT(IN) :: WAVNUM, CGROUP - REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: WSWAVE, UFRIC, RAORW - - INTEGER(KIND=JWIM) :: IJ, K, M, I, J - - REAL(KIND=JWRB), DIMENSION(NFRE) :: FREQ ! frequencies [Hz] - REAL(KIND=JWRB), DIMENSION(NFRE) :: DFII ! frequency bandwiths [Hz] - REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: ANAR ! directional narrowness - REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: EDENS ! spectral density E(f) - REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: ETDENS ! threshold spec. density ET(f) - REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: EXDENS ! excess spectral density EX(f) - REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: NEXDENS! normalised excess spec.dens. - REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: T1 ! inherent breaking term - REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: T2 ! forced dissipation term - REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: T12 ! =T1+T2 or combined dissipation - REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: ADF ! temporary variable - REAL(KIND=JWRB) :: BNT ! empirical constant for wave breaking probability - REAL(KIND=JWRB) :: XFAC ! temporary variableis - REAL(KIND=JWRB), DIMENSION(KIJL) :: EDENSMAX ! temporary variable - REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE) :: A - REAL(KIND=JWRB), DIMENSION(KIJL) :: CUMADF - - REAL(KIND=JPHOOK) :: ZHOOK_HANDLE - +INTEGER(KIND=JWIM), INTENT(IN) :: KIJS, KIJL + +REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(IN) :: FL1 +REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(INOUT) :: FLD, SL +REAL(KIND=JWRB), DIMENSION(KIJL,NFRE), INTENT(IN) :: WAVNUM, CGROUP +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: WSWAVE, UFRIC, RAORW + +INTEGER(KIND=JWIM) :: IJ, K, M, I, J + +REAL(KIND=JWRB), DIMENSION(NFRE) :: FREQ ! frequencies [Hz] +REAL(KIND=JWRB), DIMENSION(NFRE) :: DFII ! frequency bandwiths [Hz] +REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: ANAR ! directional narrowness +REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: EDENS ! spectral density E(f) +REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: ETDENS ! threshold spec. density ET(f) +REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: EXDENS ! excess spectral density EX(f) +REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: NEXDENS! normalised excess spec.dens. +REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: T1 ! inherent breaking term +REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: T2 ! forced dissipation term +REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: T12 ! =T1+T2 or combined dissipation +REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: ADF ! temporary variable +REAL(KIND=JWRB) :: BNT ! empirical constant for wave breaking probability +REAL(KIND=JWRB) :: XFAC ! temporary variableis +REAL(KIND=JWRB), DIMENSION(KIJL) :: EDENSMAX ! temporary variable +REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE) :: A +REAL(KIND=JWRB), DIMENSION(KIJL) :: CUMADF + +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + ! ---------------------------------------------------------------------- - IF (LHOOK) CALL DR_HOOK('SDISSIP_ZBRY',0,ZHOOK_HANDLE) +IF (LHOOK) CALL DR_HOOK('SDISSIP_ZBRY',0,ZHOOK_HANDLE) - DO M = 1, NFRE - DO K = 1, NANG ! Apply to all directions - DO IJ = KIJS,KIJL - A(IJ,K,M) = FL1(IJ,K,M) * CGROUP(IJ,M) / ( ZPI * SIG(M) ) ! ACTION DENSITY SPECTRUM - END DO - END DO +DO M = 1, NFRE + DO K = 1, NANG ! Apply to all directions + DO IJ = KIJS,KIJL + A(IJ,K,M) = FL1(IJ,K,M) * CGROUP(IJ,M) / ( ZPI * SIG(M) ) ! ACTION DENSITY SPECTRUM END DO + END DO +END DO !/ 0) --- Initialize essential parameters ---------------------------- / - FREQ(:) = FR(1:NFRE) - BNT = 0.035_JWRB**2 - DO M = 1, NFRE - DO IJ = KIJS,KIJL - ANAR(IJ,M) = 1.0_JWRB - T1(IJ,M) = 0.0_JWRB - T2(IJ,M) = 0.0_JWRB - NEXDENS(IJ,M) = 0.0_JWRB - END DO - END DO +FREQ(:) = FR(1:NFRE) +BNT = 0.035_JWRB**2 +DO M = 1, NFRE + DO IJ = KIJS,KIJL + ANAR(IJ,M) = 1.0_JWRB + T1(IJ,M) = 0.0_JWRB + T2(IJ,M) = 0.0_JWRB + NEXDENS(IJ,M) = 0.0_JWRB + END DO +END DO ! !/ 1) --- Calculate threshold spectral density, spectral density, and !/ the level of exceedence EXDENS(f) -------------------------- / - DO M = 1, NFRE - DO IJ = KIJS,KIJL - ETDENS(IJ,M) = ( ZPI * BNT ) / ( ANAR(IJ,M) * CGROUP(IJ,M) * WAVNUM(IJ,M)**3 ) - EDENS(IJ,M) = 0.0_JWRB - END DO - DO K = 1, NANG - DO IJ = KIJS,KIJL - EDENS(IJ,M) = EDENS(IJ,M) + FL1(IJ,K,M) - END DO - END DO - DO IJ = KIJS,KIJL - EDENS(IJ,M) = EDENS(IJ,M) * DELTH ! E(f) - EXDENS(IJ,M) = MAX(0.0_JWRB,EDENS(IJ,M)-ETDENS(IJ,M)) - END DO + DO M = 1, NFRE + DO IJ = KIJS,KIJL + ETDENS(IJ,M) = ( ZPI * BNT ) / ( ANAR(IJ,M) * CGROUP(IJ,M) * WAVNUM(IJ,M)**3 ) + EDENS(IJ,M) = 0.0_JWRB + END DO + DO K = 1, NANG + DO IJ = KIJS,KIJL + EDENS(IJ,M) = EDENS(IJ,M) + FL1(IJ,K,M) END DO + END DO + DO IJ = KIJS,KIJL + EDENS(IJ,M) = EDENS(IJ,M) * DELTH ! E(f) + EXDENS(IJ,M) = MAX(0.0_JWRB,EDENS(IJ,M)-ETDENS(IJ,M)) + END DO + END DO ! !/ --- normalise by a generic spectral density -------------------- / - IF (LLSDS6ET) THEN - DO M = 1,NFRE - DO IJ = KIJS,KIJL - NEXDENS(IJ,M) = EXDENS(IJ,M) / ETDENS(IJ,M) ! normalise by threshold spectral density - END DO - END DO - ELSE ! normalise by spectral density - DO IJ = KIJS,KIJL - EDENSMAX(IJ) = MAXVAL(EDENS(IJ,1:NFRE))*1.0E-5_JWRB - END DO - DO M = 1,NFRE - DO IJ = KIJS,KIJL - IF (EDENS(IJ,M) .GT. EDENSMAX(IJ)) THEN - NEXDENS(IJ,M) = EXDENS(IJ,M) / EDENS(IJ,M) - END IF - END DO - END DO - END IF +IF (LLSDS6ET) THEN + DO M = 1,NFRE + DO IJ = KIJS,KIJL + NEXDENS(IJ,M) = EXDENS(IJ,M) / ETDENS(IJ,M) ! normalise by threshold spectral density + END DO + END DO +ELSE ! normalise by spectral density + DO IJ = KIJS,KIJL + EDENSMAX(IJ) = MAXVAL(EDENS(IJ,1:NFRE))*1.0E-5_JWRB + END DO + DO M = 1,NFRE + DO IJ = KIJS,KIJL + IF (EDENS(IJ,M) .GT. EDENSMAX(IJ)) THEN + NEXDENS(IJ,M) = EXDENS(IJ,M) / EDENS(IJ,M) + END IF + END DO + END DO +END IF ! !/ 2) --- Calculate inherent breaking component T1 ------------------- / - DO M = 1,NFRE - DO IJ = KIJS,KIJL - T1(IJ,M) = ZSDS6A1 * ANAR(IJ,M) * FREQ(M) * (NEXDENS(IJ,M)**ISDS6P1) - END DO - END DO + DO M = 1,NFRE + DO IJ = KIJS,KIJL + T1(IJ,M) = ZSDS6A1 * ANAR(IJ,M) * FREQ(M) * (NEXDENS(IJ,M)**ISDS6P1) + END DO + END DO ! !/ 3) --- Calculate T2, the dissipation of waves induced by !/ the breaking of longer waves T2 ---------------------------- / - DO M = 1,NFRE - DO IJ = KIJS,KIJL - ADF(IJ,M) = ANAR(IJ,M) * (NEXDENS(IJ,M)**ISDS6P2) - END DO - END DO - - XFAC = (1.0_JWRB-1.0_JWRB/FRATIO)/(FRATIO-1.0_JWRB/FRATIO) - DO M = 1,NFRE - DFII(M) = DF(M) - IF (M .GT. 1 .AND. M .LT. NFRE) THEN - DFII(M) = DFII(M) * XFAC - END IF - END DO - + DO M = 1,NFRE DO IJ = KIJS,KIJL - CUMADF(IJ) = 0.0_JWRB + ADF(IJ,M) = ANAR(IJ,M) * (NEXDENS(IJ,M)**ISDS6P2) END DO - DO M = 1,NFRE + END DO + +XFAC = (1.0_JWRB-1.0_JWRB/FRATIO)/(FRATIO-1.0_JWRB/FRATIO) +DO M = 1,NFRE + DFII(M) = DF(M) + IF (M .GT. 1 .AND. M .LT. NFRE) THEN + DFII(M) = DFII(M) * XFAC + END IF +END DO + +DO IJ = KIJS,KIJL + CUMADF(IJ) = 0.0_JWRB +END DO +DO M = 1,NFRE + DO IJ = KIJS,KIJL + CUMADF(IJ) = CUMADF(IJ) + ADF(IJ,M)*DFII(M) + T2(IJ,M) = ZSDS6A2 * CUMADF(IJ) + END DO +END DO + +!/ 4) --- Sum up dissipation terms and apply to all directions ------- / +DO M = 1,NFRE + DO IJ = KIJS,KIJL + T12(IJ,M) = -1.0_JWRB * ( MAX(0.0_JWRB,T1(IJ,M))+MAX(0.0_JWRB,T2(IJ,M)) ) + END DO +END DO + +IF (LLLOWWINDS) THEN + DO M = 1,NFRE + DO K = 1, NANG DO IJ = KIJS,KIJL - CUMADF(IJ) = CUMADF(IJ) + ADF(IJ,M)*DFII(M) - T2(IJ,M) = ZSDS6A2 * CUMADF(IJ) + IF ( WSWAVE(IJ)>=5._JWRB) THEN + ! no dissipation for winds<5m/s (following Muhammad Yasrab's work) + SL(IJ,K,M) = SL(IJ,K,M) + T12(IJ,M)*FL1(IJ,K,M) + FLD(IJ,K,M) = FLD(IJ,K,M) + T12(IJ,M) + END IF END DO END DO - -!/ 4) --- Sum up dissipation terms and apply to all directions ------- / - DO M = 1,NFRE + END DO +ELSE + DO M = 1,NFRE + DO K = 1, NANG DO IJ = KIJS,KIJL - T12(IJ,M) = -1.0_JWRB * ( MAX(0.0_JWRB,T1(IJ,M))+MAX(0.0_JWRB,T2(IJ,M)) ) + SL(IJ,K,M) = SL(IJ,K,M) + T12(IJ,M)*FL1(IJ,K,M) + FLD(IJ,K,M) = FLD(IJ,K,M) + T12(IJ,M) END DO END DO + END DO +END IF - IF (LLLOWWINDS) THEN - DO M = 1,NFRE - DO K = 1, NANG - DO IJ = KIJS,KIJL - IF ( WSWAVE(IJ)>=5._JWRB) THEN - ! no dissipation for winds<5m/s (following Muhammad Yasrab's work) - SL(IJ,K,M) = SL(IJ,K,M) + T12(IJ,M)*FL1(IJ,K,M) - FLD(IJ,K,M) = FLD(IJ,K,M) + T12(IJ,M) - END IF - END DO - END DO - END DO - ELSE - DO M = 1,NFRE - DO K = 1, NANG - DO IJ = KIJS,KIJL - SL(IJ,K,M) = SL(IJ,K,M) + T12(IJ,M)*FL1(IJ,K,M) - FLD(IJ,K,M) = FLD(IJ,K,M) + T12(IJ,M) - END DO - END DO - END DO - END IF - - IF (LHOOK) CALL DR_HOOK('SDISSIP_ZBRY',1,ZHOOK_HANDLE) +IF (LHOOK) CALL DR_HOOK('SDISSIP_ZBRY',1,ZHOOK_HANDLE) - END SUBROUTINE SDISSIP_ZBRY +END SUBROUTINE SDISSIP_ZBRY diff --git a/src/ecwam/swldissip_zbry.F90 b/src/ecwam/swldissip_zbry.F90 index a950c2c95..3982e102e 100644 --- a/src/ecwam/swldissip_zbry.F90 +++ b/src/ecwam/swldissip_zbry.F90 @@ -73,133 +73,133 @@ SUBROUTINE SWLDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & IMPLICIT NONE - INTEGER(KIND=JWIM), INTENT(IN) :: KIJS, KIJL +INTEGER(KIND=JWIM), INTENT(IN) :: KIJS, KIJL - REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(IN) :: FL1 - REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(INOUT) :: FLD, SL - REAL(KIND=JWRB), DIMENSION(KIJL,NFRE), INTENT(IN) :: WAVNUM, CGROUP - REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: UFRIC, RAORW +REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(IN) :: FL1 +REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(INOUT) :: FLD, SL +REAL(KIND=JWRB), DIMENSION(KIJL,NFRE), INTENT(IN) :: WAVNUM, CGROUP +REAL(KIND=JWRB), DIMENSION(KIJL), INTENT(IN) :: UFRIC, RAORW - INTEGER(KIND=JWIM) :: IJ, M, I, J, M2, K2, K, NANGD - INTEGER(KIND=JWIM), DIMENSION(KIJL) :: MPEAK +INTEGER(KIND=JWIM) :: IJ, M, I, J, M2, K2, K, NANGD +INTEGER(KIND=JWIM), DIMENSION(KIJL) :: MPEAK - REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: ABAND, KMAX, ANAR, BN, DDIS - REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE) :: KK - REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE) :: A - REAL(KIND=JWRB), DIMENSION(KIJL) :: B1, SUMDIR_IJ +REAL(KIND=JWRB), DIMENSION(KIJL,NFRE) :: ABAND, KMAX, ANAR, BN, DDIS +REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE) :: KK +REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE) :: A +REAL(KIND=JWRB), DIMENSION(KIJL) :: B1, SUMDIR_IJ + +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE - REAL(KIND=JPHOOK) :: ZHOOK_HANDLE - ! ---------------------------------------------------------------------- - IF (LHOOK) CALL DR_HOOK('SWLDISSIP_ZBRY',0,ZHOOK_HANDLE) - - DO M = 1, NFRE - DO K = 1, NANG ! Apply to all directions - DO IJ = KIJS,KIJL - A(IJ,K,M) = FL1(IJ,K,M) * CGROUP(IJ,M) / ( ZPI * SIG(M) ) ! ACTION DENSITY SPECTRUM - END DO - END DO - END DO - - !/ 0) --- Initialize parameters -------------------------------------- / - DO M = 1, NFRE - DO IJ = KIJS,KIJL - ABAND(IJ,M) = 0.0_JWRB - DDIS(IJ,M) = 0.0_JWRB - END DO - END DO - DO M = 1, NFRE - DO K = 1, NANG - DO IJ = KIJS,KIJL - ABAND(IJ,M) = ABAND(IJ,M) + A(IJ,K,M) - END DO - END DO - END DO +IF (LHOOK) CALL DR_HOOK('SWLDISSIP_ZBRY',0,ZHOOK_HANDLE) + +DO M = 1, NFRE + DO K = 1, NANG ! Apply to all directions + DO IJ = KIJS,KIJL + A(IJ,K,M) = FL1(IJ,K,M) * CGROUP(IJ,M) / ( ZPI * SIG(M) ) ! ACTION DENSITY SPECTRUM + END DO + END DO +END DO + +!/ 0) --- Initialize parameters -------------------------------------- / +DO M = 1, NFRE + DO IJ = KIJS,KIJL + ABAND(IJ,M) = 0.0_JWRB + DDIS(IJ,M) = 0.0_JWRB + END DO +END DO +DO M = 1, NFRE + DO K = 1, NANG + DO IJ = KIJS,KIJL + ABAND(IJ,M) = ABAND(IJ,M) + A(IJ,K,M) + END DO + END DO +END DO !/ 1) --- Choose calculation of steepness a*k ------------------------ / !/ Replace the measure of steepness with the spectral ! saturation after Banner et al. (2002) ---------------------- / - DO M = 1,NFRE - DO IJ = KIJS,KIJL - KMAX(IJ,M) = 0.0_JWRB - END DO - DO K = 1,NANG - DO IJ = KIJS,KIJL - KK(IJ,K,M) = A(IJ,K,M) - KMAX(IJ,M) = MAX(KMAX(IJ,M), KK(IJ,K,M)) - END DO - END DO - END DO - - DO M = 1,NFRE - DO K = 1,NANG - DO IJ = KIJS,KIJL - IF (KMAX(IJ,M).LT.1.0E-34_JWRB) THEN - KK(IJ,K,M) = 1.0_JWRB - ELSE - KK(IJ,K,M) = KK(IJ,K,M)/KMAX(IJ,M) - END IF - END DO - END DO - END DO - - DO M = 1,NFRE - DO IJ = KIJS,KIJL - SUMDIR_IJ(IJ) = 0.0_JWRB - END DO - DO K = 1,NANG - DO IJ = KIJS,KIJL - SUMDIR_IJ(IJ) = SUMDIR_IJ(IJ) + KK(IJ,K,M) - END DO - END DO - DO IJ = KIJS,KIJL - ANAR(IJ,M) = 1.0_JWRB/( SUMDIR_IJ(IJ) * DELTH ) - BN(IJ,M) = ANAR(IJ,M) * ( ABAND(IJ,M) * SIG(M) * DELTH ) * WAVNUM(IJ,M)**3 - END DO - END DO +DO M = 1,NFRE + DO IJ = KIJS,KIJL + KMAX(IJ,M) = 0.0_JWRB + END DO + DO K = 1,NANG + DO IJ = KIJS,KIJL + KK(IJ,K,M) = A(IJ,K,M) + KMAX(IJ,M) = MAX(KMAX(IJ,M), KK(IJ,K,M)) + END DO + END DO +END DO + +DO M = 1,NFRE + DO K = 1,NANG + DO IJ = KIJS,KIJL + IF (KMAX(IJ,M).LT.1.0E-34_JWRB) THEN + KK(IJ,K,M) = 1.0_JWRB + ELSE + KK(IJ,K,M) = KK(IJ,K,M)/KMAX(IJ,M) + END IF + END DO + END DO +END DO + +DO M = 1,NFRE + DO IJ = KIJS,KIJL + SUMDIR_IJ(IJ) = 0.0_JWRB + END DO + DO K = 1,NANG + DO IJ = KIJS,KIJL + SUMDIR_IJ(IJ) = SUMDIR_IJ(IJ) + KK(IJ,K,M) + END DO + END DO + DO IJ = KIJS,KIJL + ANAR(IJ,M) = 1.0_JWRB/( SUMDIR_IJ(IJ) * DELTH ) + BN(IJ,M) = ANAR(IJ,M) * ( ABAND(IJ,M) * SIG(M) * DELTH ) * WAVNUM(IJ,M)**3 + END DO +END DO ! - IF (.NOT.LLSWL6CSTB1) THEN +IF (.NOT.LLSWL6CSTB1) THEN !/ --- A constant value for B1 attenuates swell too strong in the !/ western central Pacific (i.e. cross swell less than 1.0m). !/ Workaround is to scale B1 with steepness a*kp, where kp is !/ the peak wavenumber. ZSWL6B1 remains a scaling constant, but !/ with different magnitude. --------------------------------- / - DO IJ = KIJS,KIJL - MPEAK(IJ) = MAXLOC(ABAND(IJ,:),1) ! Index for peak - SUMDIR_IJ(IJ) = 0.0_JWRB - END DO - DO K = 1,NFRE - DO IJ = KIJS,KIJL - SUMDIR_IJ(IJ) = SUMDIR_IJ(IJ) + ABAND(IJ,K)*DDEN(K)/CGROUP(IJ,K) - END DO - END DO - DO IJ = KIJS,KIJL - B1(IJ) = ZSWL6B1*(2.0_JWRB*SQRT(SUMDIR_IJ(IJ))*WAVNUM(IJ,MPEAK(IJ))) - END DO - END IF + DO IJ = KIJS,KIJL + MPEAK(IJ) = MAXLOC(ABAND(IJ,:),1) ! Index for peak + SUMDIR_IJ(IJ) = 0.0_JWRB + END DO + DO K = 1,NFRE + DO IJ = KIJS,KIJL + SUMDIR_IJ(IJ) = SUMDIR_IJ(IJ) + ABAND(IJ,K)*DDEN(K)/CGROUP(IJ,K) + END DO + END DO + DO IJ = KIJS,KIJL + B1(IJ) = ZSWL6B1*(2.0_JWRB*SQRT(SUMDIR_IJ(IJ))*WAVNUM(IJ,MPEAK(IJ))) + END DO +END IF ! !/ 2) --- Calculate the derivative term only (in units of 1/s) ------- / - DO M = 1,NFRE - DO IJ = KIJS,KIJL - IF (ABAND(IJ,M) .GT. 1.0E-30_JWRB) THEN - DDIS(IJ,M) = -(2.0_JWRB/3.0_JWRB) * B1(IJ) * SIG(M) * SQRT(BN(IJ,M)) - END IF - END DO - END DO +DO M = 1,NFRE + DO IJ = KIJS,KIJL + IF (ABAND(IJ,M) .GT. 1.0E-30_JWRB) THEN + DDIS(IJ,M) = -(2.0_JWRB/3.0_JWRB) * B1(IJ) * SIG(M) * SQRT(BN(IJ,M)) + END IF + END DO +END DO ! !/ 3) --- Apply dissipation term of derivative to all directions ----- / - DO M = 1,NFRE - DO K = 1, NANG - DO IJ = KIJS,KIJL - SL(IJ,K,M) = SL(IJ,K,M) + DDIS(IJ,M)*FL1(IJ,K,M) - FLD(IJ,K,M) = FLD(IJ,K,M) + DDIS(IJ,M) - END DO - END DO - END DO +DO M = 1,NFRE + DO K = 1, NANG + DO IJ = KIJS,KIJL + SL(IJ,K,M) = SL(IJ,K,M) + DDIS(IJ,M)*FL1(IJ,K,M) + FLD(IJ,K,M) = FLD(IJ,K,M) + DDIS(IJ,M) + END DO + END DO +END DO - IF (LHOOK) CALL DR_HOOK('SWLDISSIP_ZBRY',1,ZHOOK_HANDLE) +IF (LHOOK) CALL DR_HOOK('SWLDISSIP_ZBRY',1,ZHOOK_HANDLE) - END SUBROUTINE SWLDISSIP_ZBRY +END SUBROUTINE SWLDISSIP_ZBRY diff --git a/src/ecwam/tau_wave_atmos.F90 b/src/ecwam/tau_wave_atmos.F90 index f394bd556..8b46d3788 100644 --- a/src/ecwam/tau_wave_atmos.F90 +++ b/src/ecwam/tau_wave_atmos.F90 @@ -63,86 +63,86 @@ SUBROUTINE TAU_WAVE_ATMOS(S, CINV, TAUNWX, TAUNWY ) #include "tauwindsxy.intfb.h" - REAL(KIND=JWRB), DIMENSION(NANG,NFRE), INTENT(IN) :: S ! Sin(sigma) in [m2/rad-Hz] - REAL(KIND=JWRB), DIMENSION(NFRE), INTENT(IN) :: CINV - REAL(KIND=JWRB), INTENT(OUT) :: TAUNWX, TAUNWY +REAL(KIND=JWRB), DIMENSION(NANG,NFRE), INTENT(IN) :: S ! Sin(sigma) in [m2/rad-Hz] +REAL(KIND=JWRB), DIMENSION(NFRE), INTENT(IN) :: CINV +REAL(KIND=JWRB), INTENT(OUT) :: TAUNWX, TAUNWY - REAL(KIND=JWRB), DIMENSION(NANG,NFRE) :: SX, SY +REAL(KIND=JWRB), DIMENSION(NANG,NFRE) :: SX, SY - REAL(KIND=JWRB), DIMENSION(NFRE) :: SDENSX_LF, SDENSY_LF - REAL(KIND=JWRB), DIMENSION(NFRE) :: ZA_SX, ZA_SY +REAL(KIND=JWRB), DIMENSION(NFRE) :: SDENSX_LF, SDENSY_LF +REAL(KIND=JWRB), DIMENSION(NFRE) :: ZA_SX, ZA_SY - REAL(KIND=JWRB) :: SDENSX_HF, SDENSY_HF - REAL(KIND=JWRB) :: TAUNWX_LF, TAUNWY_LF - REAL(KIND=JWRB) :: TAUNWX_HF, TAUNWY_HF - - REAL(KIND=JPHOOK) :: ZHOOK_HANDLE +REAL(KIND=JWRB) :: SDENSX_HF, SDENSY_HF +REAL(KIND=JWRB) :: TAUNWX_LF, TAUNWY_LF +REAL(KIND=JWRB) :: TAUNWX_HF, TAUNWY_HF + +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ---------------------------------------------------------------------- - IF (LHOOK) CALL DR_HOOK('TAU_WAVE_ATMOS',0,ZHOOK_HANDLE) - - SX = ABS(MIN(0.0_JWRB,S)) * SPREAD(COSTH,2,NFRE) - SY = ABS(MIN(0.0_JWRB,S)) * SPREAD(SINTH,2,NFRE) - - !/ 0) --- split integral into low/high frequency contributions ------------- / - ! - ! - ! Th=2pi,f=inf Th=2pi,f=FR(NFRE) Th=2pi,f=inf - ! / / / / / / - ! | | S(f,Th)/c df dTh = | | S(f,Th)/c df dTh + | | S(f,Th)/c df dTh - ! / / / / / / - ! Th=0,f=0 Th=0,f=0 Th=0,f=FR(NFRE) - ! - ! - ! = LF_contribution + HF_contribution - ! - ! - !/ 1) --- low frequency contributions to the integral ---------------------- / - ! -- Direct summation over available freq. bins up to FR(NFRE) - - SDENSX_LF = SUM(SX,1) * DELTH - SDENSY_LF = SUM(SY,1) * DELTH - CALL TAUWINDSXY(SDENSX_LF, SDENSY_LF, CINV, DSII, NFRE, TAUNWX_LF, TAUNWY_LF) - - !/ 2) --- high frequency contributions to the integral --------------------- / - ! -- Assume spectral slope for S_IN(F) is proportional to F**(-2), then - ! integral collapses into easy analytic solution - ! - ! - ! Th=2pi,ω=inf - ! / / - ! | | S(f,Th)/c df dTh = (LOG(inf) - LOG(SIG(NFRE))) * SIG(NFRE)**2 * DELTH * SUM(S(:,NFRE)) * ZPI * GM1 - ! / / - ! Th=0,ω=SIG(NFRE) - ! - ! Instead, use FRQMAX extension (e.g. 10Hz) - ! - ! Th=2pi,ω=ZPI*FRQMAX - ! / / - ! | | S(f,Th)/c df dTh = (LOG(ZPI*FRQMAX) - LOG(SIG(NFRE))) * SIG(NFRE)**2 * DELTH * SUM(S(:,NFRE)) * ZPI * GM1 - ! / / - ! Th=0,ω=SIG(NFRE) - ! - ! - ! Determine value of spectrum at NFRE (i.e. at highest frequency). - ! - Note, direction dimension must remain - - ZA_SX = SX(:,NFRE) - ZA_SY = SY(:,NFRE) - - SDENSX_HF = (LOG(ZPI*FRQMAX) - LOG(SIG(NFRE))) * SIG(NFRE)**2 * DELTH * SUM(ZA_SX) * ZPI * GM1 - SDENSY_HF = (LOG(ZPI*FRQMAX) - LOG(SIG(NFRE))) * SIG(NFRE)**2 * DELTH * SUM(ZA_SY) * ZPI * GM1 - - TAUNWX_HF = G * ROWATER * ( SDENSX_HF ) - TAUNWY_HF = G * ROWATER * ( SDENSY_HF ) - - !/ 3) --- summate low + high frequency contributions to the integral ------- / - - TAUNWX = TAUNWX_LF + TAUNWX_HF - TAUNWY = TAUNWY_LF + TAUNWY_HF - - IF (LHOOK) CALL DR_HOOK('TAU_WAVE_ATMOS',1,ZHOOK_HANDLE) - - END SUBROUTINE TAU_WAVE_ATMOS +IF (LHOOK) CALL DR_HOOK('TAU_WAVE_ATMOS',0,ZHOOK_HANDLE) + +SX = ABS(MIN(0.0_JWRB,S)) * SPREAD(COSTH,2,NFRE) +SY = ABS(MIN(0.0_JWRB,S)) * SPREAD(SINTH,2,NFRE) + +!/ 0) --- split integral into low/high frequency contributions ------------- / +! +! +! Th=2pi,f=inf Th=2pi,f=FR(NFRE) Th=2pi,f=inf +! / / / / / / +! | | S(f,Th)/c df dTh = | | S(f,Th)/c df dTh + | | S(f,Th)/c df dTh +! / / / / / / +! Th=0,f=0 Th=0,f=0 Th=0,f=FR(NFRE) +! +! +! = LF_contribution + HF_contribution +! +! +!/ 1) --- low frequency contributions to the integral ---------------------- / +! -- Direct summation over available freq. bins up to FR(NFRE) + +SDENSX_LF = SUM(SX,1) * DELTH +SDENSY_LF = SUM(SY,1) * DELTH +CALL TAUWINDSXY(SDENSX_LF, SDENSY_LF, CINV, DSII, NFRE, TAUNWX_LF, TAUNWY_LF) + +!/ 2) --- high frequency contributions to the integral --------------------- / +! -- Assume spectral slope for S_IN(F) is proportional to F**(-2), then +! integral collapses into easy analytic solution +! +! +! Th=2pi,ω=inf +! / / +! | | S(f,Th)/c df dTh = (LOG(inf) - LOG(SIG(NFRE))) * SIG(NFRE)**2 * DELTH * SUM(S(:,NFRE)) * ZPI * GM1 +! / / +! Th=0,ω=SIG(NFRE) +! +! Instead, use FRQMAX extension (e.g. 10Hz) +! +! Th=2pi,ω=ZPI*FRQMAX +! / / +! | | S(f,Th)/c df dTh = (LOG(ZPI*FRQMAX) - LOG(SIG(NFRE))) * SIG(NFRE)**2 * DELTH * SUM(S(:,NFRE)) * ZPI * GM1 +! / / +! Th=0,ω=SIG(NFRE) +! +! +! Determine value of spectrum at NFRE (i.e. at highest frequency). +! - Note, direction dimension must remain + +ZA_SX = SX(:,NFRE) +ZA_SY = SY(:,NFRE) + +SDENSX_HF = (LOG(ZPI*FRQMAX) - LOG(SIG(NFRE))) * SIG(NFRE)**2 * DELTH * SUM(ZA_SX) * ZPI * GM1 +SDENSY_HF = (LOG(ZPI*FRQMAX) - LOG(SIG(NFRE))) * SIG(NFRE)**2 * DELTH * SUM(ZA_SY) * ZPI * GM1 + +TAUNWX_HF = G * ROWATER * ( SDENSX_HF ) +TAUNWY_HF = G * ROWATER * ( SDENSY_HF ) + +!/ 3) --- summate low + high frequency contributions to the integral ------- / + +TAUNWX = TAUNWX_LF + TAUNWX_HF +TAUNWY = TAUNWY_LF + TAUNWY_HF + +IF (LHOOK) CALL DR_HOOK('TAU_WAVE_ATMOS',1,ZHOOK_HANDLE) + +END SUBROUTINE TAU_WAVE_ATMOS diff --git a/src/ecwam/tauwindsxy.F90 b/src/ecwam/tauwindsxy.F90 index 951de3490..764c62adc 100644 --- a/src/ecwam/tauwindsxy.F90 +++ b/src/ecwam/tauwindsxy.F90 @@ -42,31 +42,31 @@ SUBROUTINE TAUWINDSXY(SDENSX_IN, SDENSY_IN, CINV_IN, DSII_IN, NPTS, TAUWX_OUT, T IMPLICIT NONE - REAL(KIND=JWRB), INTENT(IN) :: SDENSX_IN(*), SDENSY_IN(*) - REAL(KIND=JWRB), INTENT(IN) :: CINV_IN(*), DSII_IN(*) - INTEGER(KIND=JWIM), INTENT(IN) :: NPTS - REAL(KIND=JWRB), INTENT(OUT) :: TAUWX_OUT, TAUWY_OUT +REAL(KIND=JWRB), INTENT(IN) :: SDENSX_IN(*), SDENSY_IN(*) +REAL(KIND=JWRB), INTENT(IN) :: CINV_IN(*), DSII_IN(*) +INTEGER(KIND=JWIM), INTENT(IN) :: NPTS +REAL(KIND=JWRB), INTENT(OUT) :: TAUWX_OUT, TAUWY_OUT - INTEGER(KIND=JWIM) :: M - REAL(KIND=JWRB) :: SUMX, SUMY - REAL(KIND=JPHOOK) :: ZHOOK_HANDLE +INTEGER(KIND=JWIM) :: M +REAL(KIND=JWRB) :: SUMX, SUMY +REAL(KIND=JPHOOK) :: ZHOOK_HANDLE !---------------------------------------------------------------------- ! - IF (LHOOK) CALL DR_HOOK('TAUWINDSXY',0,ZHOOK_HANDLE) +IF (LHOOK) CALL DR_HOOK('TAUWINDSXY',0,ZHOOK_HANDLE) - SUMX = 0.0_JWRB - SUMY = 0.0_JWRB +SUMX = 0.0_JWRB +SUMY = 0.0_JWRB - DO M = 1, NPTS - SUMX = SUMX + SDENSX_IN(M) * CINV_IN(M) * DSII_IN(M) - SUMY = SUMY + SDENSY_IN(M) * CINV_IN(M) * DSII_IN(M) - END DO +DO M = 1, NPTS + SUMX = SUMX + SDENSX_IN(M) * CINV_IN(M) * DSII_IN(M) + SUMY = SUMY + SDENSY_IN(M) * CINV_IN(M) * DSII_IN(M) +END DO - TAUWX_OUT = G * ROWATER * SUMX - TAUWY_OUT = G * ROWATER * SUMY +TAUWX_OUT = G * ROWATER * SUMX +TAUWY_OUT = G * ROWATER * SUMY - IF (LHOOK) CALL DR_HOOK('TAUWINDSXY',1,ZHOOK_HANDLE) +IF (LHOOK) CALL DR_HOOK('TAUWINDSXY',1,ZHOOK_HANDLE) - END SUBROUTINE TAUWINDSXY \ No newline at end of file +END SUBROUTINE TAUWINDSXY \ No newline at end of file From e11b026d57100029554a7b2a73c7da7438249d40 Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Wed, 29 Apr 2026 17:47:00 +0000 Subject: [PATCH 81/89] minor aesthetic tidy --- src/ecwam/CMakeLists.txt | 1 - src/ecwam/airsea_zbry.F90 | 8 ++-- src/ecwam/calcphiwa.F90 | 1 - src/ecwam/implsch.F90 | 3 +- src/ecwam/sdissip.F90 | 6 +-- src/ecwam/sdissip_zbry.F90 | 2 +- src/ecwam/setwavphys.F90 | 8 ++-- src/ecwam/sinput.F90 | 2 +- src/ecwam/stresso.F90 | 9 ---- src/ecwam/swldissip_zbry.F90 | 6 +-- src/ecwam/tau_wave_atmos.F90 | 4 +- src/ecwam/tauwinds.F90 | 65 ---------------------------- src/ecwam/tauwxy.F90 | 72 ------------------------------- src/ecwam/wsigstar.F90 | 6 +-- src/ecwam/wvei.F90 | 84 ------------------------------------ src/ecwam/yowcout.F90 | 4 +- 16 files changed, 24 insertions(+), 257 deletions(-) delete mode 100644 src/ecwam/tauwinds.F90 delete mode 100644 src/ecwam/tauwxy.F90 delete mode 100644 src/ecwam/wvei.F90 diff --git a/src/ecwam/CMakeLists.txt b/src/ecwam/CMakeLists.txt index 4814d231e..7d618c55c 100644 --- a/src/ecwam/CMakeLists.txt +++ b/src/ecwam/CMakeLists.txt @@ -320,7 +320,6 @@ list( APPEND ecwam_srcs wvalloc.F90 wvchkmid.F90 wvdealloc.F90 - wvei.F90 wvfricvelo.F90 wvopenbathy.F90 wvopensubbathy.F90 diff --git a/src/ecwam/airsea_zbry.F90 b/src/ecwam/airsea_zbry.F90 index a868e6fe5..defea07c0 100644 --- a/src/ecwam/airsea_zbry.F90 +++ b/src/ecwam/airsea_zbry.F90 @@ -76,7 +76,7 @@ SUBROUTINE AIRSEA_ZBRY (KIJS, KIJL, & REAL(KIND=JWRB) :: ZNLEV REAL(KIND=JWRB), PARAMETER :: RKAP = 0.4_JWRB -! for the ietrative scheme +! for the iterative scheme INTEGER(KIND=JWIM), PARAMETER :: NITER=15 ! CD=ACD+BCD*U10 @@ -148,8 +148,8 @@ SUBROUTINE AIRSEA_ZBRY (KIJS, KIJL, & CDLIN= ACDLIN + BCDLIN*SQRT(PCHAROG*G) * U10(IJ) ! first guess for u* -! UST = U10(IJ)*SQRT(ACD+BCD*U10(IJ)) ! Use linear approx -! UST = SQRT(CD)*U10(IJ) ! Use Hersbach approx +! UST = U10(IJ)*SQRT(ACD+BCD*U10(IJ)) ! Use linear approx +! UST = SQRT(CD)*U10(IJ) ! Use Hersbach approx UST = SQRT(CDLIN)*U10(IJ) ! Use Hersbach approx ! iterate @@ -175,7 +175,7 @@ SUBROUTINE AIRSEA_ZBRY (KIJS, KIJL, & US(IJ) = XKUTOP/LOG(1.0+ZNLEV/Z0(IJ)) ELSE US(IJ) = MAX(UST,USTMIN) - ! Z0(IJ) = Z0CH ! Commented out -> Z0=Z0TOT + ! Z0(IJ) = Z0CH ! N.B. not needed here because Z0=Z0TOT ENDIF diff --git a/src/ecwam/calcphiwa.F90 b/src/ecwam/calcphiwa.F90 index 4a77b6be6..108337ccd 100644 --- a/src/ecwam/calcphiwa.F90 +++ b/src/ecwam/calcphiwa.F90 @@ -67,7 +67,6 @@ FUNCTION CALCPHIWA(SPOS,SNEG) RESULT(PHIWA) !/ 1) --- low frequency contributions to the integral ---------------------- / ! -- Direct summation over available freq. bins up to FR(NFRE) ! -! DFIM = DELTH * DF ! SPOS_LF = SUM(SUM(SPOS,1) * DFIM) SNEG_LF = SUM(SUM(SNEG,1) * DFIM) diff --git a/src/ecwam/implsch.F90 b/src/ecwam/implsch.F90 index ccc9df640..ab154f589 100644 --- a/src/ecwam/implsch.F90 +++ b/src/ecwam/implsch.F90 @@ -255,7 +255,6 @@ SUBROUTINE IMPLSCH (KIJS, KIJL, FL1, & CASE(0,1) NCALL = 2 CASE(2) - ! test without iterating for ZBRY on physics NCALL = 1 END SELECT @@ -270,7 +269,7 @@ SUBROUTINE IMPLSCH (KIJS, KIJL, FL1, & & COSWDIF, SINWDIF2, & & FMEAN, HALP, FMEANWS, & & FLM, & - & UFRIC, TAUW, TAUWDIR, & + & UFRIC, TAUW, TAUWDIR, & & Z0M, Z0B, CHRNCK, PHIWA, & & FLD, SL, SPOS, & & MIJ, RHOWGDFTH, XLLWS) diff --git a/src/ecwam/sdissip.F90 b/src/ecwam/sdissip.F90 index 7db531281..6c70ff3d2 100644 --- a/src/ecwam/sdissip.F90 +++ b/src/ecwam/sdissip.F90 @@ -91,11 +91,11 @@ SUBROUTINE SDISSIP (KIJS, KIJL, FL1, FLD, SL, & !$loki inline CALL SDISSIP_ZBRY (KIJS, KIJL, FL1 ,FLD, SL, & & WSWAVE, WAVNUM, CGROUP, & - & UFRIC, RAORW) + & UFRIC, RAORW) CALL SWLDISSIP_ZBRY(KIJS, KIJL, FL1 ,FLD, SL, & & WAVNUM, CGROUP, & - & UFRIC, RAORW) - END SELECT + & UFRIC, RAORW) + END SELECT IF (LHOOK) CALL DR_HOOK('SDISSIP',1,ZHOOK_HANDLE) diff --git a/src/ecwam/sdissip_zbry.F90 b/src/ecwam/sdissip_zbry.F90 index b448627e4..a3e04085d 100644 --- a/src/ecwam/sdissip_zbry.F90 +++ b/src/ecwam/sdissip_zbry.F90 @@ -114,7 +114,7 @@ SUBROUTINE SDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & IF (LHOOK) CALL DR_HOOK('SDISSIP_ZBRY',0,ZHOOK_HANDLE) DO M = 1, NFRE - DO K = 1, NANG ! Apply to all directions + DO K = 1, NANG DO IJ = KIJS,KIJL A(IJ,K,M) = FL1(IJ,K,M) * CGROUP(IJ,M) / ( ZPI * SIG(M) ) ! ACTION DENSITY SPECTRUM END DO diff --git a/src/ecwam/setwavphys.F90 b/src/ecwam/setwavphys.F90 index abf22f457..d5099160c 100644 --- a/src/ecwam/setwavphys.F90 +++ b/src/ecwam/setwavphys.F90 @@ -206,7 +206,9 @@ SUBROUTINE SETWAVPHYS ELSE IF (IPHYS.EQ.2) THEN - ! Dummy values for IPHYS=1-inherited variables not used in IPHYS=2 + ! Dummy values for IPHYS=1-inherited variables not used in IPHYS=2. + ! N. B. The issue only appears when compiling in coupled mode + ! ZBRY TODO: these should be cleaned up so they are not required with this physics option. ZALP = 0.008_JWRB ANG_GC_A = 0.35_JWRB ANG_GC_B = 0.65_JWRB @@ -246,8 +248,8 @@ SUBROUTINE SETWAVPHYS TAILFACTOR=6.0_JWRB TAILFACTOR_PM=4.0_JWRB CASE(2,3) - ! NGST=2 ! intend to use this later - NGST=1 ! keep NGST=1 for clean comparison + ! NGST=2 + NGST=1 ! keep NGST=1 for clean comparison to other IPHYS2_AIRSEA options ALPHAPMAX = 0.031_JWRB ! cap on spectral steepness as in ARD TAILFACTOR=2.5_JWRB TAILFACTOR_PM=3.0_JWRB ! as in ARD diff --git a/src/ecwam/sinput.F90 b/src/ecwam/sinput.F90 index 087951b5a..d0f1b11e0 100644 --- a/src/ecwam/sinput.F90 +++ b/src/ecwam/sinput.F90 @@ -122,7 +122,7 @@ SUBROUTINE SINPUT (NGST, LLSNEG, KIJS, KIJL, FL1, & & RAORW, WSTAR, RNFAC, & & FLD, SL, SPOS, XLLWS) ! CASE(2) - ! - not called from SINPUT + ! - not called from SINPUT because it is handled input source term in SINFLX_ZBRY END SELECT IF (LHOOK) CALL DR_HOOK('SINPUT',1,ZHOOK_HANDLE) diff --git a/src/ecwam/stresso.F90 b/src/ecwam/stresso.F90 index 7f02c8e7f..ae9a406e4 100644 --- a/src/ecwam/stresso.F90 +++ b/src/ecwam/stresso.F90 @@ -143,15 +143,6 @@ SUBROUTINE STRESSO (KIJS, KIJL, MIJ, RHOWGDFTH, & ENDDO ENDIF -! --------------------------------------------------------------------------------- -! --------------------------------------------------------------------------------- -! --------------------------------------------------------------------------------- -! --------------------------------------------------------------------------------- -! --------------------------------------------------------------------------------- -! --------------------------------------------------------------------------------- - ! this is all IPHYS=0,1 - - !* CALCULATE LOW-FREQUENCY CONTRIBUTION TO STRESS AND ENERGY FLUX (positive sinput). ! --------------------------------------------------------------------------------- DO M=1,NFRE diff --git a/src/ecwam/swldissip_zbry.F90 b/src/ecwam/swldissip_zbry.F90 index 3982e102e..b5020dc82 100644 --- a/src/ecwam/swldissip_zbry.F90 +++ b/src/ecwam/swldissip_zbry.F90 @@ -8,8 +8,8 @@ ! SUBROUTINE SWLDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & - & WAVNUM, CGROUP, & - & UFRIC, RAORW) + & WAVNUM, CGROUP, & + & UFRIC, RAORW) ! ---------------------------------------------------------------------- !**** *SWLDISSIP_ZBRY* - COMPUTATION OF DISSIPATION SOURCE FUNCTION. @@ -95,7 +95,7 @@ SUBROUTINE SWLDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & IF (LHOOK) CALL DR_HOOK('SWLDISSIP_ZBRY',0,ZHOOK_HANDLE) DO M = 1, NFRE - DO K = 1, NANG ! Apply to all directions + DO K = 1, NANG DO IJ = KIJS,KIJL A(IJ,K,M) = FL1(IJ,K,M) * CGROUP(IJ,M) / ( ZPI * SIG(M) ) ! ACTION DENSITY SPECTRUM END DO diff --git a/src/ecwam/tau_wave_atmos.F90 b/src/ecwam/tau_wave_atmos.F90 index 8b46d3788..9857a781e 100644 --- a/src/ecwam/tau_wave_atmos.F90 +++ b/src/ecwam/tau_wave_atmos.F90 @@ -6,7 +6,7 @@ ! granted to it by virtue of its status as an intergovernmental organisation ! nor does it submit to any jurisdiction. - SUBROUTINE TAU_WAVE_ATMOS(S, CINV, TAUNWX, TAUNWY ) + SUBROUTINE TAU_WAVE_ATMOS(S, CINV, TAUNWX, TAUNWY) ! ---------------------------------------------------------------------- ! @@ -30,7 +30,7 @@ SUBROUTINE TAU_WAVE_ATMOS(S, CINV, TAUNWX, TAUNWY ) !** INTERFACE. ! ---------- -! *CALL* *TAU_WAVE_ATMOS(S, CINV, TAUNWX, TAUNWY ) +! *CALL* *TAU_WAVE_ATMOS(S, CINV, TAUNWX, TAUNWY)* ! *S* - NEG. WIND INPUT ENERGY DENSITY SPECTRUM. ! *CINV* - INVERSE PHASE SPEED CALC. IN INPUT ROUTINE diff --git a/src/ecwam/tauwinds.F90 b/src/ecwam/tauwinds.F90 deleted file mode 100644 index 7cdd34eea..000000000 --- a/src/ecwam/tauwinds.F90 +++ /dev/null @@ -1,65 +0,0 @@ -! (C) Copyright 1989- ECMWF. -! -! This software is licensed under the terms of the Apache Licence Version 2.0 -! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. -! In applying this licence, ECMWF does not waive the privileges and immunities -! granted to it by virtue of its status as an intergovernmental organisation -! nor does it submit to any jurisdiction. - - FUNCTION TAUWINDS(SDENSIG,CINV,DSII) RESULT(TAU_WINDS) - -! ---------------------------------------------------------------------------- -! -! 1. Purpose : -! -! Wind stress (tau) computation from wind-momentum-input -! function which can be obtained from wind-energy-input (Sin). -! -! / FRMAX -! tau = g * rho_water * | Sin(f)/C(f) df -! / - -!---------------------------------------------------------------------- -! -! INTERFACE VARIABLES. -! -------------------- - -! ORIGIN. -! ---------- -! Adapted from Babanin Young Donelan & Banner (ZBRY) physics -! as implemented as ST6 in WAVEWATCH-III -! Implementation into ECWAM DECEMBER 2021 by J. Kousal - -! ---------------------------------------------------------------------------- -! - - USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU - USE YOWPCONS , ONLY : G ,ZPI ,ROWATER - USE YOMHOOK , ONLY : LHOOK ,DR_HOOK, JPHOOK - -!---------------------------------------------------------------------- - - IMPLICIT NONE - - REAL(KIND=JWRB), INTENT(IN) :: SDENSIG(:) ! Sin(sigma) in [m2/rad-Hz] - REAL(KIND=JWRB), INTENT(IN) :: CINV(:) ! inverse phase speed - REAL(KIND=JWRB), INTENT(IN) :: DSII(:) ! freq. bandwidths in [radians] - - REAL(KIND=JWRB) :: TAU_WINDS - REAL(KIND=JPHOOK) :: ZHOOK_HANDLE - INTEGER(KIND=JWIM) :: M - -! ---------------------------------------------------------------------------- -! - - IF (LHOOK) CALL DR_HOOK('TAUWINDS',0,ZHOOK_HANDLE) - - TAU_WINDS = 0.0_JWRB - DO M = 1, SIZE(SDENSIG) - TAU_WINDS = TAU_WINDS + SDENSIG(M) * CINV(M) * DSII(M) - END DO - TAU_WINDS = G * ROWATER * TAU_WINDS - - IF (LHOOK) CALL DR_HOOK('TAUWINDS',1,ZHOOK_HANDLE) - - END FUNCTION TAUWINDS diff --git a/src/ecwam/tauwxy.F90 b/src/ecwam/tauwxy.F90 deleted file mode 100644 index 741d1278f..000000000 --- a/src/ecwam/tauwxy.F90 +++ /dev/null @@ -1,72 +0,0 @@ -! (C) Copyright 1989- ECMWF. -! -! This software is licensed under the terms of the Apache Licence Version 2.0 -! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. -! In applying this licence, ECMWF does not waive the privileges and immunities -! granted to it by virtue of its status as an intergovernmental organisation -! nor does it submit to any jurisdiction. - - SUBROUTINE TAUWXY(SDENSX_IN, SDENSY_IN, CINV_IN, DSII_IN, TAUWX_OUT, TAUWY_OUT) - -! ---------------------------------------------------------------------------- -! -! 1. Purpose : -! -! Wind stress (tau) computation from wind-momentum-input -! function which can be obtained from wind-energy-input (Sin). -! -! / FRMAX -! tau = g * rho_water * | Sin(f)/C(f) df -! / - -!---------------------------------------------------------------------- -! -! INTERFACE VARIABLES. -! -------------------- - -! ORIGIN. -! ---------- -! Adapted from Babanin Young Donelan & Banner (ZBRY) physics -! as implemented as ST6 in WAVEWATCH-III -! Implementation into ECWAM DECEMBER 2021 by J. Kousal - -! ---------------------------------------------------------------------------- -! - - USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU - USE YOWFRED , ONLY : NFRE_EXT - USE YOWPCONS , ONLY : G, ROWATER - USE YOMHOOK , ONLY : LHOOK ,DR_HOOK, JPHOOK - -!---------------------------------------------------------------------- - - - IMPLICIT NONE - - REAL(KIND=JWRB), INTENT(IN) :: SDENSX_IN(NFRE_EXT), SDENSY_IN(NFRE_EXT) - REAL(KIND=JWRB), INTENT(IN) :: CINV_IN(NFRE_EXT), DSII_IN(NFRE_EXT) - REAL(KIND=JWRB), INTENT(OUT) :: TAUWX_OUT, TAUWY_OUT - - INTEGER(KIND=JWIM) :: M - REAL(KIND=JWRB) :: SUMX, SUMY - REAL(KIND=JPHOOK) :: ZHOOK_HANDLE - -!---------------------------------------------------------------------- -! - - IF (LHOOK) CALL DR_HOOK('TAUWXY',0,ZHOOK_HANDLE) - - SUMX = 0.0_JWRB - SUMY = 0.0_JWRB - - DO M = 1, NFRE_EXT - SUMX = SUMX + SDENSX_IN(M) * CINV_IN(M) * DSII_IN(M) - SUMY = SUMY + SDENSY_IN(M) * CINV_IN(M) * DSII_IN(M) - END DO - - TAUWX_OUT = G * ROWATER * SUMX - TAUWY_OUT = G * ROWATER * SUMY - - IF (LHOOK) CALL DR_HOOK('TAUWXY',1,ZHOOK_HANDLE) - - END SUBROUTINE TAUWXY diff --git a/src/ecwam/wsigstar.F90 b/src/ecwam/wsigstar.F90 index a56ba419e..2dcc66431 100644 --- a/src/ecwam/wsigstar.F90 +++ b/src/ecwam/wsigstar.F90 @@ -29,7 +29,7 @@ SUBROUTINE WSIGSTAR (KIJS, KIJL, WSWAVE, UFRIC, Z0M, WSTAR, SIG_N, SIG_U10) ! *Z0M* - ROUGHNESS LENGTH IN M. ! *WSTAR* - FREE CONVECTION VELOCITY SCALE (M/S). ! *SIG_N* - ESTIMATED RELATIVE STANDARD DEVIATION OF USTAR. -! *SIG_U10* - ESTIMATED RELATIVE STANDARD DEVIATION OF U10. +! *SIG_U10*- ESTIMATED RELATIVE STANDARD DEVIATION OF U10. ! METHOD. ! ------- @@ -103,8 +103,7 @@ SUBROUTINE WSIGSTAR (KIJS, KIJL, WSWAVE, UFRIC, Z0M, WSTAR, SIG_N, SIG_U10) SIG_N(IJ) = MIN(SIG_NMAX, SIG_CONV * U10M1*(BG_GUST*UFRIC(IJ)**3 + & & 0.5_JWRB*XKAPPA*WSTAR(IJ)**3)**ONETHIRD ) SIG_U10(IJ) = MIN(SIG_U10MAX, (BG_GUST*UFRIC(IJ)**3 + & - & 0.5_JWRB*XKAPPA*WSTAR(IJ)**3)**ONETHIRD ) - + & 0.5_JWRB*XKAPPA*WSTAR(IJ)**3)**ONETHIRD ) ENDDO ELSE @@ -131,7 +130,6 @@ SUBROUTINE WSIGSTAR (KIJS, KIJL, WSWAVE, UFRIC, Z0M, WSTAR, SIG_N, SIG_U10) & 0.5_JWRB*XKAPPA*WSTAR(IJ)**3)**ONETHIRD ) SIG_U10(IJ) = MIN(SIG_U10MAX, (BG_GUST*UFRIC(IJ)**3 + & & 0.5_JWRB*XKAPPA*WSTAR(IJ)**3)**ONETHIRD ) - ENDDO ENDIF diff --git a/src/ecwam/wvei.F90 b/src/ecwam/wvei.F90 deleted file mode 100644 index 3e68fd5d6..000000000 --- a/src/ecwam/wvei.F90 +++ /dev/null @@ -1,84 +0,0 @@ -! (C) Copyright 1989- ECMWF. -! -! This software is licensed under the terms of the Apache Licence Version 2.0 -! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. -! In applying this licence, ECMWF does not waive the privileges and immunities -! granted to it by virtue of its status as an intergovernmental organisation -! nor does it submit to any jurisdiction. - - FUNCTION WVEI(x) RESULT(res) - -! ---------------------------------------------------------------------------- -! -! 1. Purpose : -! - ! Real-valued exponential integral Ei(x) approximation for real x - ! Uses power series for small/negative x and an asymptotic expansion for large positive x. - ! Reasonable accuracy for typical geophysical ranges; replace with a library routine if you need higher precision. - -!---------------------------------------------------------------------- -! -! INTERFACE VARIABLES. -! -------------------- - -! ORIGIN. -! ---------- -! Implementation into ECWAM DECEMBER 2025 by J. Kousal based on available online solvers - -! ---------------------------------------------------------------------------- -! - - USE PARKIND_WAVE, ONLY : JWIM, JWRB, JWRU - USE YOWPCONS , ONLY : GAMMA_E - USE YOMHOOK , ONLY : LHOOK ,DR_HOOK, JPHOOK - -!---------------------------------------------------------------------- - - IMPLICIT NONE - REAL(KIND=JWRB), INTENT(IN) :: x - REAL(KIND=JWRB) :: term, sum, res - INTEGER(KIND=JWIM) :: k, kmax - REAL(KIND=JWRB) :: eps - - REAL(KIND=JPHOOK) :: ZHOOK_HANDLE - -! ---------------------------------------------------------------------------- -! - - IF (LHOOK) CALL DR_HOOK('WVEI',0,ZHOOK_HANDLE) - - - eps = 1.0E-12_JWRB - if (x < 0.0_JWRB .or. abs(x) <= 6.0_JWRB) then - ! series: Ei(x) = gamma + ln(|x|) + sum_{k=1..inf} x^k/(k*k!) - if (x == 0.0_JWRB) then - res = -huge(1.0_JWRB) ! singular; caller should not hit exact zero normally - return - end if - sum = 0.0_JWRB - term = x - k = 1 - kmax = 200 - do while (k <= kmax) - sum = sum + term/real(k,kind=JWRB) - term = term * x/real(k+1,kind=JWRB) - if (abs(term/real(k+1,kind=JWRB)) < abs(sum)*eps) exit - k = k + 1 - end do - res = GAMMA_E + log(abs(x)) + sum - else - ! asymptotic for large positive x: Ei(x) ~ exp(x)/x * (1 + 1/x + 2!/x^2 + 6/x^3 + ...) - kmax = 50 - sum = 1.0_JWRB - term = 1.0_JWRB - do k = 1, kmax - term = term * real(k,kind=JWRB) / x - sum = sum + term - if (abs(term) < abs(sum)*eps) exit - end do - res = exp(x) / x * sum - end if - - IF (LHOOK) CALL DR_HOOK('WVEI',1,ZHOOK_HANDLE) - - END FUNCTION WVEI \ No newline at end of file diff --git a/src/ecwam/yowcout.F90 b/src/ecwam/yowcout.F90 index 74141da39..54ad912d7 100644 --- a/src/ecwam/yowcout.F90 +++ b/src/ecwam/yowcout.F90 @@ -17,8 +17,8 @@ MODULE YOWCOUT !* ** *COUT* OUTPUT POINTS INDICES AND FLAGS. INTEGER(KIND=JWIM), PARAMETER :: NTRAIN=3 - INTEGER(KIND=JWIM), PARAMETER :: JPPFLAG=72+3*NTRAIN+5 !!!! change also in scripts: wave_setgflag - INTEGER(KIND=JWIM), PARAMETER :: NREAL=17 + INTEGER(KIND=JWIM), PARAMETER :: JPPFLAG=75+3*NTRAIN+5 !!!! change also in scripts: wave_setgflag + INTEGER(KIND=JWIM), PARAMETER :: NREAL=16 INTEGER(KIND=JWIM), PARAMETER :: NIPRMINFO=7 INTEGER(KIND=JWIM), PARAMETER :: NINFOBOUT=5 From 55ac7a67ab28d709c63e6d619a80d8fd8390e9e1 Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Wed, 29 Apr 2026 17:54:14 +0000 Subject: [PATCH 82/89] renaming of zbry to bydrz --- src/ecwam/CMakeLists.txt | 8 ++++---- src/ecwam/airsea.F90 | 4 ++-- src/ecwam/{airsea_zbry.F90 => airsea_bydrz.F90} | 14 +++++++------- src/ecwam/initmdl.F90 | 2 +- src/ecwam/lfactor.F90 | 2 +- src/ecwam/sdissip.F90 | 8 ++++---- .../{sdissip_zbry.F90 => sdissip_bydrz.F90} | 14 +++++++------- src/ecwam/setwavphys.F90 | 2 +- src/ecwam/sinflx.F90 | 4 ++-- src/ecwam/{sinflx_zbry.F90 => sinflx_bydrz.F90} | 14 +++++++------- src/ecwam/sinput.F90 | 2 +- .../{swldissip_zbry.F90 => swldissip_bydrz.F90} | 14 +++++++------- src/ecwam/tau_wave_atmos.F90 | 2 +- src/ecwam/tauwindsxy.F90 | 2 +- src/ecwam/yowphys.F90 | 16 ++++++++-------- src/ecwam/yowstat.F90 | 2 +- ...ml => etopo1_oper_an_fc_O48_cy50r1_bydrz.yml} | 0 17 files changed, 55 insertions(+), 55 deletions(-) rename src/ecwam/{airsea_zbry.F90 => airsea_bydrz.F90} (95%) rename src/ecwam/{sdissip_zbry.F90 => sdissip_bydrz.F90} (94%) rename src/ecwam/{sinflx_zbry.F90 => sinflx_bydrz.F90} (98%) rename src/ecwam/{swldissip_zbry.F90 => swldissip_bydrz.F90} (93%) rename tests/{etopo1_oper_an_fc_O48_cy50r1_zbry.yml => etopo1_oper_an_fc_O48_cy50r1_bydrz.yml} (100%) diff --git a/src/ecwam/CMakeLists.txt b/src/ecwam/CMakeLists.txt index 7d618c55c..234b2de06 100644 --- a/src/ecwam/CMakeLists.txt +++ b/src/ecwam/CMakeLists.txt @@ -49,7 +49,7 @@ list( APPEND ecwam_srcs adjust.F90 airsea.F90 airsea_jan.F90 - airsea_zbry.F90 + airsea_bydrz.F90 aki.F90 aki_ice.F90 alphap_tail.F90 @@ -221,7 +221,7 @@ list( APPEND ecwam_srcs sdissip.F90 sdissip_ard.F90 sdissip_jan.F90 - sdissip_zbry.F90 + sdissip_bydrz.F90 sdiwbk.F90 sdice.F90 sdice1.F90 @@ -243,7 +243,7 @@ list( APPEND ecwam_srcs setmarstype.F90 setwavphys.F90 sinflx.F90 - sinflx_zbry.F90 + sinflx_bydrz.F90 sinflx_ard_jan.F90 sinput.F90 sinput_ard.F90 @@ -259,7 +259,7 @@ list( APPEND ecwam_srcs stress_gc.F90 stresso.F90 strspec.F90 - swldissip_zbry.F90 + swldissip_bydrz.F90 tables_2nd.F90 tabu_swellft.F90 tau_phi_hf.F90 diff --git a/src/ecwam/airsea.F90 b/src/ecwam/airsea.F90 index 247335e41..4f507b4db 100644 --- a/src/ecwam/airsea.F90 +++ b/src/ecwam/airsea.F90 @@ -70,7 +70,7 @@ SUBROUTINE AIRSEA (KIJS, KIJL, & #include "abort1.intfb.h" #include "airsea_jan.intfb.h" -#include "airsea_zbry.intfb.h" +#include "airsea_bydrz.intfb.h" INTEGER(KIND=JWIM), INTENT(IN) :: KIJS, KIJL, ICODE_WND, IUSFG REAL(KIND=JWRB), DIMENSION(KIJL), INTENT (IN), OPTIONAL :: HALP, RNFAC @@ -100,7 +100,7 @@ SUBROUTINE AIRSEA (KIJS, KIJL, & & HALP, U10, U10DIR, TAUW, TAUWDIR, RNFAC, & & US, Z0, Z0B, CHRNCK, ICODE_WND, IUSFG) CASE(2) - CALL AIRSEA_ZBRY(KIJS, KIJL, & + CALL AIRSEA_BYDRZ(KIJS, KIJL, & & U10, U10DIR, TAUW, TAUWDIR, & & US, Z0, Z0B, CHRNCK, ICODE_WND, IUSFG) diff --git a/src/ecwam/airsea_zbry.F90 b/src/ecwam/airsea_bydrz.F90 similarity index 95% rename from src/ecwam/airsea_zbry.F90 rename to src/ecwam/airsea_bydrz.F90 index defea07c0..be8e5e390 100644 --- a/src/ecwam/airsea_zbry.F90 +++ b/src/ecwam/airsea_bydrz.F90 @@ -7,13 +7,13 @@ ! nor does it submit to any jurisdiction. ! - SUBROUTINE AIRSEA_ZBRY (KIJS, KIJL, & + SUBROUTINE AIRSEA_BYDRZ (KIJS, KIJL, & & U10, U10DIR, TAUW, TAUWDIR, & & US, Z0, Z0B, CHRNCK, ICODE_WND, IUSFG) ! ---------------------------------------------------------------------- -!**** *AIRSEA_ZBRY* - DETERMINE TOTAL STRESS IN SURFACE LAYER. +!**** *AIRSEA_BYDRZ* - DETERMINE TOTAL STRESS IN SURFACE LAYER. ! ! JOSH KOUSAL & JEAN BIDLOT ECMWF 2023 ! @@ -25,7 +25,7 @@ SUBROUTINE AIRSEA_ZBRY (KIJS, KIJL, & !** INTERFACE. ! ---------- -! *CALL* *AIRSEA_ZBRY (KIJS, KIJL, +! *CALL* *AIRSEA_BYDRZ (KIJS, KIJL, ! U10, U10DIR, TAUW, TAUWDIR, ! US, Z0, Z0B, CHRNCK, ICODE_WND, IUSFG)* @@ -101,7 +101,7 @@ SUBROUTINE AIRSEA_ZBRY (KIJS, KIJL, & REAL(KIND=JPHOOK) :: ZHOOK_HANDLE ! ---------------------------------------------------------------------- -IF (LHOOK) CALL DR_HOOK ('AIRSEA_ZBRY', 0, ZHOOK_HANDLE) +IF (LHOOK) CALL DR_HOOK ('AIRSEA_BYDRZ', 0, ZHOOK_HANDLE) !* 2. DETERMINE TOTAL STRESS AND ROUGHNESS (if needed) ! ---------------------------------- @@ -203,12 +203,12 @@ SUBROUTINE AIRSEA_ZBRY (KIJS, KIJL, & ELSE WRITE (IU06, * ) ' ++++++++++++++++++++++++++++++++++++++++++' - WRITE (IU06, * ) ' + AIRSEA_ZBRY : INVALID VALUE OF ICODE_WND +' + WRITE (IU06, * ) ' + AIRSEA_BYDRZ : INVALID VALUE OF ICODE_WND +' WRITE (IU06, * ) ' ICODE_WND = ', ICODE_WND WRITE (IU06, * ) ' ++++++++++++++++++++++++++++++++++++++++++' CALL ABORT1 ENDIF -IF (LHOOK) CALL DR_HOOK ('AIRSEA_ZBRY', 1, ZHOOK_HANDLE) +IF (LHOOK) CALL DR_HOOK ('AIRSEA_BYDRZ', 1, ZHOOK_HANDLE) -END SUBROUTINE AIRSEA_ZBRY +END SUBROUTINE AIRSEA_BYDRZ diff --git a/src/ecwam/initmdl.F90 b/src/ecwam/initmdl.F90 index 33bb5e824..598b43d6c 100644 --- a/src/ecwam/initmdl.F90 +++ b/src/ecwam/initmdl.F90 @@ -504,7 +504,7 @@ SUBROUTINE INITMDL (NADV, & ENDDO ! -------------------------------------------------- - ! ZBRY-specific frequency-space setup (only needed for IPHYS=2). + ! BYDRZ-specific frequency-space setup (only needed for IPHYS=2). IF (IPHYS == 2) THEN IF (.NOT.ALLOCATED(DF)) ALLOCATE(DF(NFRE)) IF (.NOT.ALLOCATED(SIG)) ALLOCATE(SIG(NFRE)) diff --git a/src/ecwam/lfactor.F90 b/src/ecwam/lfactor.F90 index 249df8a9d..81b81c9d1 100644 --- a/src/ecwam/lfactor.F90 +++ b/src/ecwam/lfactor.F90 @@ -66,7 +66,7 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, UPROXY, USDIR, ROAIRN, & ! ORIGIN. ! ---------- -! Adapted from Babanin Young Donelan & Banner (ZBRY) physics +! Adapted from Babanin Young Donelan & Banner (BYDRZ) physics ! as implemented as ST6 in WAVEWATCH-III ! Implementation into ECWAM DECEMBER 2021 by J. Kousal diff --git a/src/ecwam/sdissip.F90 b/src/ecwam/sdissip.F90 index 6c70ff3d2..0a430a234 100644 --- a/src/ecwam/sdissip.F90 +++ b/src/ecwam/sdissip.F90 @@ -58,8 +58,8 @@ SUBROUTINE SDISSIP (KIJS, KIJL, FL1, FLD, SL, & #include "sdissip_ard.intfb.h" #include "sdissip_jan.intfb.h" -#include "sdissip_zbry.intfb.h" -#include "swldissip_zbry.intfb.h" +#include "sdissip_bydrz.intfb.h" +#include "swldissip_bydrz.intfb.h" INTEGER(KIND=JWIM), INTENT(IN) :: KIJS, KIJL REAL(KIND=JWRB), DIMENSION(KIJL,NANG,NFRE), INTENT(IN) :: FL1 @@ -89,10 +89,10 @@ SUBROUTINE SDISSIP (KIJS, KIJL, FL1, FLD, SL, & & UFRIC, COSWDIF, RAORW) CASE(2) !$loki inline - CALL SDISSIP_ZBRY (KIJS, KIJL, FL1 ,FLD, SL, & + CALL SDISSIP_BYDRZ (KIJS, KIJL, FL1 ,FLD, SL, & & WSWAVE, WAVNUM, CGROUP, & & UFRIC, RAORW) - CALL SWLDISSIP_ZBRY(KIJS, KIJL, FL1 ,FLD, SL, & + CALL SWLDISSIP_BYDRZ(KIJS, KIJL, FL1 ,FLD, SL, & & WAVNUM, CGROUP, & & UFRIC, RAORW) END SELECT diff --git a/src/ecwam/sdissip_zbry.F90 b/src/ecwam/sdissip_bydrz.F90 similarity index 94% rename from src/ecwam/sdissip_zbry.F90 rename to src/ecwam/sdissip_bydrz.F90 index a3e04085d..b3e6dc582 100644 --- a/src/ecwam/sdissip_zbry.F90 +++ b/src/ecwam/sdissip_bydrz.F90 @@ -7,12 +7,12 @@ ! nor does it submit to any jurisdiction. ! - SUBROUTINE SDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & + SUBROUTINE SDISSIP_BYDRZ (KIJS, KIJL, FL1, FLD, SL, & & WSWAVE, WAVNUM, CGROUP, & & UFRIC, RAORW) ! ---------------------------------------------------------------------- -!**** *SDISSIP_ZBRY* - COMPUTATION OF DISSIPATION SOURCE FUNCTION. +!**** *SDISSIP_BYDRZ* - COMPUTATION OF DISSIPATION SOURCE FUNCTION. ! ! JOSH KOUSAL & JEAN BIDLOT ECMWF 2023 ! @@ -29,7 +29,7 @@ SUBROUTINE SDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & !** INTERFACE. ! ---------- -! *CALL* *SDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL,* +! *CALL* *SDISSIP_BYDRZ (KIJS, KIJL, FL1, FLD, SL,* ! WSWAVE, WAVNUM, CGROUP, ! UFRIC, RAORW)* ! *KIJS* - INDEX OF FIRST GRIDPOINT @@ -60,7 +60,7 @@ SUBROUTINE SDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & ! ORIGIN. ! ---------- -! Adapted from Babanin Young Donelan & Banner (ZBRY) physics +! Adapted from Babanin Young Donelan & Banner (BYDRZ) physics ! as implemented as ST6 in WAVEWATCH-III ! Implementation into ECWAM DECEMBER 2021 by J. Kousal @@ -111,7 +111,7 @@ SUBROUTINE SDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & ! ---------------------------------------------------------------------- -IF (LHOOK) CALL DR_HOOK('SDISSIP_ZBRY',0,ZHOOK_HANDLE) +IF (LHOOK) CALL DR_HOOK('SDISSIP_BYDRZ',0,ZHOOK_HANDLE) DO M = 1, NFRE DO K = 1, NANG @@ -234,6 +234,6 @@ SUBROUTINE SDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & END DO END IF -IF (LHOOK) CALL DR_HOOK('SDISSIP_ZBRY',1,ZHOOK_HANDLE) +IF (LHOOK) CALL DR_HOOK('SDISSIP_BYDRZ',1,ZHOOK_HANDLE) -END SUBROUTINE SDISSIP_ZBRY +END SUBROUTINE SDISSIP_BYDRZ diff --git a/src/ecwam/setwavphys.F90 b/src/ecwam/setwavphys.F90 index d5099160c..5e57b9297 100644 --- a/src/ecwam/setwavphys.F90 +++ b/src/ecwam/setwavphys.F90 @@ -208,7 +208,7 @@ SUBROUTINE SETWAVPHYS ! Dummy values for IPHYS=1-inherited variables not used in IPHYS=2. ! N. B. The issue only appears when compiling in coupled mode - ! ZBRY TODO: these should be cleaned up so they are not required with this physics option. + ! BYDRZ TODO: these should be cleaned up so they are not required with this physics option. ZALP = 0.008_JWRB ANG_GC_A = 0.35_JWRB ANG_GC_B = 0.65_JWRB diff --git a/src/ecwam/sinflx.F90 b/src/ecwam/sinflx.F90 index 571db65d8..2039df31f 100644 --- a/src/ecwam/sinflx.F90 +++ b/src/ecwam/sinflx.F90 @@ -43,7 +43,7 @@ SUBROUTINE SINFLX (ICALL, NCALL, KIJS, KIJL, & #include "abort1.intfb.h" #include "sinflx_ard_jan.intfb.h" -#include "sinflx_zbry.intfb.h" +#include "sinflx_bydrz.intfb.h" INTEGER(KIND=JWIM), INTENT(IN) :: ICALL !! CALL NUMBER. INTEGER(KIND=JWIM), INTENT(IN) :: NCALL !! TOTAL NUMBER OF CALLS. @@ -115,7 +115,7 @@ SUBROUTINE SINFLX (ICALL, NCALL, KIJS, KIJL, & & FLD, SL, SPOS, & & MIJ, RHOWGDFTH, XLLWS) CASE(2) - CALL SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & + CALL SINFLX_BYDRZ (ICALL, NCALL, NGST, KIJS, KIJL, & & LUPDTUS, & & FL1, & & WAVNUM,CGROUP, CINV, & diff --git a/src/ecwam/sinflx_zbry.F90 b/src/ecwam/sinflx_bydrz.F90 similarity index 98% rename from src/ecwam/sinflx_zbry.F90 rename to src/ecwam/sinflx_bydrz.F90 index d8e1128b9..e64d0eabb 100644 --- a/src/ecwam/sinflx_zbry.F90 +++ b/src/ecwam/sinflx_bydrz.F90 @@ -7,7 +7,7 @@ ! nor does it submit to any jurisdiction. ! -SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & +SUBROUTINE SINFLX_BYDRZ (ICALL, NCALL, NGST, KIJS, KIJL, & & LUPDTUS, & & FL1, & & WAVNUM,CGROUP, CINV, & @@ -22,7 +22,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & ! ---------------------------------------------------------------------- -!**** *SINFLX_ZBRY* - COMPUTATION OF INPUT SOURCE FUNCTION AND STRESSES +!**** *SINFLX_BYDRZ* - COMPUTATION OF INPUT SOURCE FUNCTION AND STRESSES ! ! JOSH KOUSAL & JEAN BIDLOT ECMWF 2023 ! @@ -36,7 +36,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & !** INTERFACE. ! ---------- -! *CALL* *SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, LUPDTUS,* +! *CALL* *SINFLX_BYDRZ (ICALL, NCALL, NGST, KIJS, KIJL, LUPDTUS,* ! & FL1, WAVNUM, CGROUP, CINV, ! & WSWAVE, WDWAVE, AIRD, ! & RAORW, WSTAR, CICOVER, @@ -92,7 +92,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & ! ORIGIN. ! ---------- -! Adapted from Babanin Young Donelan & Banner (ZBRY) physics +! Adapted from Babanin Young Donelan & Banner (BYDRZ) physics ! as implemented as ST6 in WAVEWATCH-III ! Implementation into ECWAM DECEMBER 2021 by J. Kousal @@ -292,7 +292,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & WRITE (IU06,*) '**************************************' WRITE (IU06,*) '* FATAL ERROR *' WRITE (IU06,*) '* =========== *' - WRITE (IU06,*) '* IN SINFLX_ZBRY: NGST > 2 *' + WRITE (IU06,*) '* IN SINFLX_BYDRZ: NGST > 2 *' WRITE (IU06,*) '* NGST = ', NGST WRITE (IU06,*) '* PROGRAM ABORTS. PROGRAM ABORTS. *' WRITE (IU06,*) '* *' @@ -602,7 +602,7 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & Z0 = ZNLEV / ( EXP(KUOUST) - 1.0_JWRB ) Z0 = MAX(Z0, 0.0000001_JWRB) Z0M(IJ) = Z0 ! Update z0 - CHNKOG(IJ) = ( Z0 - RNU_WATER*USTM1 ) * USTM2 ! Update charnock (where Z0=Z0CH+Z0VIS from airsea_zbry) + CHNKOG(IJ) = ( Z0 - RNU_WATER*USTM1 ) * USTM2 ! Update charnock (where Z0=Z0CH+Z0VIS from airsea_bydrz) ALPHAOGMAXU10 = MIN(ALPHAMAX,AMAX+BMAX*WSWAVE(IJ))*GM1 ! protective code taken from outbeta (incl /G) CHNKOG(IJ) = MIN(CHNKOG(IJ),ALPHAOGMAXU10) ! protective code taken from outbeta (incl /G) @@ -660,4 +660,4 @@ SUBROUTINE SINFLX_ZBRY (ICALL, NCALL, NGST, KIJS, KIJL, & IF (LHOOK) CALL DR_HOOK('SINFLX',1,ZHOOK_HANDLE) -END SUBROUTINE SINFLX_ZBRY +END SUBROUTINE SINFLX_BYDRZ diff --git a/src/ecwam/sinput.F90 b/src/ecwam/sinput.F90 index d0f1b11e0..31b8d9d10 100644 --- a/src/ecwam/sinput.F90 +++ b/src/ecwam/sinput.F90 @@ -122,7 +122,7 @@ SUBROUTINE SINPUT (NGST, LLSNEG, KIJS, KIJL, FL1, & & RAORW, WSTAR, RNFAC, & & FLD, SL, SPOS, XLLWS) ! CASE(2) - ! - not called from SINPUT because it is handled input source term in SINFLX_ZBRY + ! - not called from SINPUT because it is handled input source term in SINFLX_BYDRZ END SELECT IF (LHOOK) CALL DR_HOOK('SINPUT',1,ZHOOK_HANDLE) diff --git a/src/ecwam/swldissip_zbry.F90 b/src/ecwam/swldissip_bydrz.F90 similarity index 93% rename from src/ecwam/swldissip_zbry.F90 rename to src/ecwam/swldissip_bydrz.F90 index b5020dc82..eda0b40e0 100644 --- a/src/ecwam/swldissip_zbry.F90 +++ b/src/ecwam/swldissip_bydrz.F90 @@ -7,12 +7,12 @@ ! nor does it submit to any jurisdiction. ! - SUBROUTINE SWLDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & + SUBROUTINE SWLDISSIP_BYDRZ (KIJS, KIJL, FL1, FLD, SL, & & WAVNUM, CGROUP, & & UFRIC, RAORW) ! ---------------------------------------------------------------------- -!**** *SWLDISSIP_ZBRY* - COMPUTATION OF DISSIPATION SOURCE FUNCTION. +!**** *SWLDISSIP_BYDRZ* - COMPUTATION OF DISSIPATION SOURCE FUNCTION. ! ! JOSH KOUSAL & JEAN BIDLOT ECMWF 2023 ! @@ -24,7 +24,7 @@ SUBROUTINE SWLDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & !** INTERFACE. ! ---------- -! *CALL* *SWLDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL,* +! *CALL* *SWLDISSIP_BYDRZ (KIJS, KIJL, FL1, FLD, SL,* ! WAVNUM, CGROUP, ! UFRIC, RAORW)* ! *KIJS* - INDEX OF FIRST GRIDPOINT @@ -53,7 +53,7 @@ SUBROUTINE SWLDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & ! ORIGIN. ! ---------- -! Adapted from Babanin Young Donelan & Banner (ZBRY) physics +! Adapted from Babanin Young Donelan & Banner (BYDRZ) physics ! as implemented as ST6 in WAVEWATCH-III ! Implementation into ECWAM DECEMBER 2021 by J. Kousal @@ -92,7 +92,7 @@ SUBROUTINE SWLDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & ! ---------------------------------------------------------------------- -IF (LHOOK) CALL DR_HOOK('SWLDISSIP_ZBRY',0,ZHOOK_HANDLE) +IF (LHOOK) CALL DR_HOOK('SWLDISSIP_BYDRZ',0,ZHOOK_HANDLE) DO M = 1, NFRE DO K = 1, NANG @@ -200,6 +200,6 @@ SUBROUTINE SWLDISSIP_ZBRY (KIJS, KIJL, FL1, FLD, SL, & END DO -IF (LHOOK) CALL DR_HOOK('SWLDISSIP_ZBRY',1,ZHOOK_HANDLE) +IF (LHOOK) CALL DR_HOOK('SWLDISSIP_BYDRZ',1,ZHOOK_HANDLE) -END SUBROUTINE SWLDISSIP_ZBRY +END SUBROUTINE SWLDISSIP_BYDRZ diff --git a/src/ecwam/tau_wave_atmos.F90 b/src/ecwam/tau_wave_atmos.F90 index 9857a781e..2051c7940 100644 --- a/src/ecwam/tau_wave_atmos.F90 +++ b/src/ecwam/tau_wave_atmos.F90 @@ -42,7 +42,7 @@ SUBROUTINE TAU_WAVE_ATMOS(S, CINV, TAUNWX, TAUNWY) ! ORIGIN. ! ---------- -! Adapted from Babanin Young Donelan & Banner (ZBRY) physics +! Adapted from Babanin Young Donelan & Banner (BYDRZ) physics ! as implemented as ST6 in WAVEWATCH-III ! Implementation into ECWAM DECEMBER 2021 by J. Kousal diff --git a/src/ecwam/tauwindsxy.F90 b/src/ecwam/tauwindsxy.F90 index 764c62adc..eba31485b 100644 --- a/src/ecwam/tauwindsxy.F90 +++ b/src/ecwam/tauwindsxy.F90 @@ -26,7 +26,7 @@ SUBROUTINE TAUWINDSXY(SDENSX_IN, SDENSY_IN, CINV_IN, DSII_IN, NPTS, TAUWX_OUT, T ! ORIGIN. ! ---------- -! Adapted from Babanin Young Donelan & Banner (ZBRY) physics +! Adapted from Babanin Young Donelan & Banner (BYDRZ) physics ! as implemented as ST6 in WAVEWATCH-III ! Implementation into ECWAM DECEMBER 2021 by J. Kousal diff --git a/src/ecwam/yowphys.F90 b/src/ecwam/yowphys.F90 index 293b098a7..bb445b2fd 100644 --- a/src/ecwam/yowphys.F90 +++ b/src/ecwam/yowphys.F90 @@ -150,28 +150,28 @@ MODULE YOWPHYS ! Wave-turbulence interaction coefficient REAL(KIND=JWRB) :: SSDSC5 !! See *SETWAVPHYS* -! ZBRY PHYS :: +! BYDRZ PHYS :: ! ========== -! *SIN6A0* PARAMETER FOR NEGATIVE WIND INPUT (a0) FOR ZBRY PHYS +! *SIN6A0* PARAMETER FOR NEGATIVE WIND INPUT (a0) FOR BYDRZ PHYS REAL(KIND=JWRB) :: ZSIN6A0 -! Swell attenuation logical for ZBRY physics +! Swell attenuation logical for BYDRZ physics LOGICAL :: LLSWL6CSTB1 -! Swell attenuation coefficient for ZBRY physics +! Swell attenuation coefficient for BYDRZ physics REAL(KIND=JWRB) :: ZSWL6B1 -! Dissipation coefficient for inherent breaking term for ZBRY physics (T1,a1) +! Dissipation coefficient for inherent breaking term for BYDRZ physics (T1,a1) REAL(KIND=JWRB) :: ZSDS6A1 -! Dissipation coefficient for forced dissipation term for ZBRY physics (T1,a2) +! Dissipation coefficient for forced dissipation term for BYDRZ physics (T1,a2) REAL(KIND=JWRB) :: ZSDS6A2 -! Dissipation exponent for inherent breaking term for ZBRY physics (T1,p1) +! Dissipation exponent for inherent breaking term for BYDRZ physics (T1,p1) INTEGER(KIND=JWIM) :: ISDS6P1 -! Dissipation exponent for forced dissipation term for ZBRY physics (T2,p2) +! Dissipation exponent for forced dissipation term for BYDRZ physics (T2,p2) INTEGER(KIND=JWIM) :: ISDS6P2 ! Dissipation, logical to normalise by **threshold** spectral density diff --git a/src/ecwam/yowstat.F90 b/src/ecwam/yowstat.F90 index 85835ce30..85e5258e5 100644 --- a/src/ecwam/yowstat.F90 +++ b/src/ecwam/yowstat.F90 @@ -126,7 +126,7 @@ MODULE YOWSTAT ! *CDTINTT* CHAR*14 NEXT DATE TO WRITE INTEG. PARAMETERS. ! *IFRELFMAX* INTEGER FREQUENCY INDEX FOR THE LOW FREQUENCY WAVES (see DELPRO_LF below) -! *ZCDFAC* REAL PARAMETER FOR WIND INPUT FOR ZBRY PHYS. +! *ZCDFAC* REAL PARAMETER FOR WIND INPUT FOR BYDRZ PHYS. ! *DELPRO_LF* REAL TIMESTEP WAM PROPAGATION IN SECONDS FOR LOW FREQUENCY WAVES (can be fraction od seconds) ! FOR ALL WAVES WITH FREQUENCY <= FR(IFRELFMAX), IF IFRELFMAX>0 ! !!! this option is only possible when no refraction effects are used (IREFRA=0) diff --git a/tests/etopo1_oper_an_fc_O48_cy50r1_zbry.yml b/tests/etopo1_oper_an_fc_O48_cy50r1_bydrz.yml similarity index 100% rename from tests/etopo1_oper_an_fc_O48_cy50r1_zbry.yml rename to tests/etopo1_oper_an_fc_O48_cy50r1_bydrz.yml From ec101625d04686bafccca9f78c58456b75e24edc Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Wed, 29 Apr 2026 18:22:57 +0000 Subject: [PATCH 83/89] iterative scheme simplification for IPHYS2_AIRSEA=3; indentation --- src/ecwam/airsea.F90 | 4 ++-- src/ecwam/airsea_bydrz.F90 | 30 ++++++++++++++++++++---------- src/ecwam/lfactor.F90 | 2 +- src/ecwam/sdissip.F90 | 8 ++++---- src/ecwam/sdissip_bydrz.F90 | 10 +++++----- src/ecwam/sinflx_bydrz.F90 | 2 +- src/ecwam/swldissip_bydrz.F90 | 10 +++++----- src/ecwam/tau_wave_atmos.F90 | 2 +- src/ecwam/tauwindsxy.F90 | 2 +- 9 files changed, 40 insertions(+), 30 deletions(-) diff --git a/src/ecwam/airsea.F90 b/src/ecwam/airsea.F90 index 4f507b4db..f94cdab95 100644 --- a/src/ecwam/airsea.F90 +++ b/src/ecwam/airsea.F90 @@ -101,8 +101,8 @@ SUBROUTINE AIRSEA (KIJS, KIJL, & & US, Z0, Z0B, CHRNCK, ICODE_WND, IUSFG) CASE(2) CALL AIRSEA_BYDRZ(KIJS, KIJL, & - & U10, U10DIR, TAUW, TAUWDIR, & - & US, Z0, Z0B, CHRNCK, ICODE_WND, IUSFG) + & U10, U10DIR, TAUW, TAUWDIR, & + & US, Z0, Z0B, CHRNCK, ICODE_WND, IUSFG) END SELECT diff --git a/src/ecwam/airsea_bydrz.F90 b/src/ecwam/airsea_bydrz.F90 index be8e5e390..866e1952d 100644 --- a/src/ecwam/airsea_bydrz.F90 +++ b/src/ecwam/airsea_bydrz.F90 @@ -8,8 +8,8 @@ ! SUBROUTINE AIRSEA_BYDRZ (KIJS, KIJL, & -& U10, U10DIR, TAUW, TAUWDIR, & -& US, Z0, Z0B, CHRNCK, ICODE_WND, IUSFG) +& U10, U10DIR, TAUW, TAUWDIR, & +& US, Z0, Z0B, CHRNCK, ICODE_WND, IUSFG) ! ---------------------------------------------------------------------- @@ -26,8 +26,8 @@ SUBROUTINE AIRSEA_BYDRZ (KIJS, KIJL, & ! ---------- ! *CALL* *AIRSEA_BYDRZ (KIJS, KIJL, -! U10, U10DIR, TAUW, TAUWDIR, -! US, Z0, Z0B, CHRNCK, ICODE_WND, IUSFG)* +! U10, U10DIR, TAUW, TAUWDIR, +! US, Z0, Z0B, CHRNCK, ICODE_WND, IUSFG)* ! *KIJS* - INDEX OF FIRST GRIDPOINT. ! *KIJL* - INDEX OF LAST GRIDPOINT. @@ -133,8 +133,7 @@ SUBROUTINE AIRSEA_BYDRZ (KIJS, KIJL, & ENDDO ! implementation of iterative scheme - CASE(2,3) - ! (IPHYS2_AIRSEA=3 only needs this iteration to get USTARGST -> UABSGST , but there is probably a smarter way to do this) + CASE(2) DO IJ=KIJS,KIJL ! -------------------------------------------- ! Iterative method @@ -180,6 +179,17 @@ SUBROUTINE AIRSEA_BYDRZ (KIJS, KIJL, & ENDDO + + CASE(3) + ! IPHYS2_AIRSEA=3 uses U10 directly for wind input (UABSGST); only a rough US + ! is needed as input to LFACTOR. A direct one-shot estimate is sufficient. + DO IJ=KIJS,KIJL + CD = ACD + BCD*U10(IJ) + US(IJ) = U10(IJ) * SQRT(CD) + Z0(IJ) = ZNLEV * EXP(-RKAP / SQRT(CD)) + Z0B(IJ) = ALPHA * (US(IJ)**2) / G + ENDDO + END SELECT ELSEIF (ICODE_WND == 1 .OR. ICODE_WND == 2) THEN @@ -202,10 +212,10 @@ SUBROUTINE AIRSEA_BYDRZ (KIJS, KIJL, & ENDDO ELSE - WRITE (IU06, * ) ' ++++++++++++++++++++++++++++++++++++++++++' - WRITE (IU06, * ) ' + AIRSEA_BYDRZ : INVALID VALUE OF ICODE_WND +' - WRITE (IU06, * ) ' ICODE_WND = ', ICODE_WND - WRITE (IU06, * ) ' ++++++++++++++++++++++++++++++++++++++++++' + WRITE (IU06, * ) ' +++++++++++++++++++++++++++++++++++++++++++++' + WRITE (IU06, * ) ' + AIRSEA_BYDRZ : INVALID VALUE OF ICODE_WND +' + WRITE (IU06, * ) ' + ICODE_WND = ', ICODE_WND + WRITE (IU06, * ) ' +++++++++++++++++++++++++++++++++++++++++++++' CALL ABORT1 ENDIF diff --git a/src/ecwam/lfactor.F90 b/src/ecwam/lfactor.F90 index 81b81c9d1..61eb96ddf 100644 --- a/src/ecwam/lfactor.F90 +++ b/src/ecwam/lfactor.F90 @@ -66,7 +66,7 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, UPROXY, USDIR, ROAIRN, & ! ORIGIN. ! ---------- -! Adapted from Babanin Young Donelan & Banner (BYDRZ) physics +! Adapted from Babanin Young Donelan Rogers & Zieger (BYDRZ) physics ! as implemented as ST6 in WAVEWATCH-III ! Implementation into ECWAM DECEMBER 2021 by J. Kousal diff --git a/src/ecwam/sdissip.F90 b/src/ecwam/sdissip.F90 index 0a430a234..d994e0f5e 100644 --- a/src/ecwam/sdissip.F90 +++ b/src/ecwam/sdissip.F90 @@ -90,11 +90,11 @@ SUBROUTINE SDISSIP (KIJS, KIJL, FL1, FLD, SL, & CASE(2) !$loki inline CALL SDISSIP_BYDRZ (KIJS, KIJL, FL1 ,FLD, SL, & - & WSWAVE, WAVNUM, CGROUP, & - & UFRIC, RAORW) - CALL SWLDISSIP_BYDRZ(KIJS, KIJL, FL1 ,FLD, SL, & - & WAVNUM, CGROUP, & + & WSWAVE, WAVNUM, CGROUP, & & UFRIC, RAORW) + CALL SWLDISSIP_BYDRZ(KIJS, KIJL, FL1 ,FLD, SL, & + & WAVNUM, CGROUP, & + & UFRIC, RAORW) END SELECT IF (LHOOK) CALL DR_HOOK('SDISSIP',1,ZHOOK_HANDLE) diff --git a/src/ecwam/sdissip_bydrz.F90 b/src/ecwam/sdissip_bydrz.F90 index b3e6dc582..231c5175d 100644 --- a/src/ecwam/sdissip_bydrz.F90 +++ b/src/ecwam/sdissip_bydrz.F90 @@ -8,8 +8,8 @@ ! SUBROUTINE SDISSIP_BYDRZ (KIJS, KIJL, FL1, FLD, SL, & - & WSWAVE, WAVNUM, CGROUP, & - & UFRIC, RAORW) + & WSWAVE, WAVNUM, CGROUP, & + & UFRIC, RAORW) ! ---------------------------------------------------------------------- !**** *SDISSIP_BYDRZ* - COMPUTATION OF DISSIPATION SOURCE FUNCTION. @@ -30,8 +30,8 @@ SUBROUTINE SDISSIP_BYDRZ (KIJS, KIJL, FL1, FLD, SL, & ! ---------- ! *CALL* *SDISSIP_BYDRZ (KIJS, KIJL, FL1, FLD, SL,* -! WSWAVE, WAVNUM, CGROUP, -! UFRIC, RAORW)* +! WSWAVE, WAVNUM, CGROUP, +! UFRIC, RAORW)* ! *KIJS* - INDEX OF FIRST GRIDPOINT ! *KIJL* - INDEX OF LAST GRIDPOINT ! *FL1* - SPECTRUM. @@ -60,7 +60,7 @@ SUBROUTINE SDISSIP_BYDRZ (KIJS, KIJL, FL1, FLD, SL, & ! ORIGIN. ! ---------- -! Adapted from Babanin Young Donelan & Banner (BYDRZ) physics +! Adapted from Babanin Young Donelan Rogers & Zieger (BYDRZ) physics ! as implemented as ST6 in WAVEWATCH-III ! Implementation into ECWAM DECEMBER 2021 by J. Kousal diff --git a/src/ecwam/sinflx_bydrz.F90 b/src/ecwam/sinflx_bydrz.F90 index e64d0eabb..ad23ee19c 100644 --- a/src/ecwam/sinflx_bydrz.F90 +++ b/src/ecwam/sinflx_bydrz.F90 @@ -292,7 +292,7 @@ SUBROUTINE SINFLX_BYDRZ (ICALL, NCALL, NGST, KIJS, KIJL, & WRITE (IU06,*) '**************************************' WRITE (IU06,*) '* FATAL ERROR *' WRITE (IU06,*) '* =========== *' - WRITE (IU06,*) '* IN SINFLX_BYDRZ: NGST > 2 *' + WRITE (IU06,*) '* IN SINFLX_BYDRZ: NGST > 2 *' WRITE (IU06,*) '* NGST = ', NGST WRITE (IU06,*) '* PROGRAM ABORTS. PROGRAM ABORTS. *' WRITE (IU06,*) '* *' diff --git a/src/ecwam/swldissip_bydrz.F90 b/src/ecwam/swldissip_bydrz.F90 index eda0b40e0..9f691b55f 100644 --- a/src/ecwam/swldissip_bydrz.F90 +++ b/src/ecwam/swldissip_bydrz.F90 @@ -8,8 +8,8 @@ ! SUBROUTINE SWLDISSIP_BYDRZ (KIJS, KIJL, FL1, FLD, SL, & - & WAVNUM, CGROUP, & - & UFRIC, RAORW) + & WAVNUM, CGROUP, & + & UFRIC, RAORW) ! ---------------------------------------------------------------------- !**** *SWLDISSIP_BYDRZ* - COMPUTATION OF DISSIPATION SOURCE FUNCTION. @@ -25,8 +25,8 @@ SUBROUTINE SWLDISSIP_BYDRZ (KIJS, KIJL, FL1, FLD, SL, & ! ---------- ! *CALL* *SWLDISSIP_BYDRZ (KIJS, KIJL, FL1, FLD, SL,* -! WAVNUM, CGROUP, -! UFRIC, RAORW)* +! WAVNUM, CGROUP, +! UFRIC, RAORW)* ! *KIJS* - INDEX OF FIRST GRIDPOINT ! *KIJL* - INDEX OF LAST GRIDPOINT ! *FL1* - SPECTRUM. @@ -53,7 +53,7 @@ SUBROUTINE SWLDISSIP_BYDRZ (KIJS, KIJL, FL1, FLD, SL, & ! ORIGIN. ! ---------- -! Adapted from Babanin Young Donelan & Banner (BYDRZ) physics +! Adapted from Babanin Young Donelan Rogers & Zieger (BYDRZ) physics ! as implemented as ST6 in WAVEWATCH-III ! Implementation into ECWAM DECEMBER 2021 by J. Kousal diff --git a/src/ecwam/tau_wave_atmos.F90 b/src/ecwam/tau_wave_atmos.F90 index 2051c7940..0de0a5f2b 100644 --- a/src/ecwam/tau_wave_atmos.F90 +++ b/src/ecwam/tau_wave_atmos.F90 @@ -42,7 +42,7 @@ SUBROUTINE TAU_WAVE_ATMOS(S, CINV, TAUNWX, TAUNWY) ! ORIGIN. ! ---------- -! Adapted from Babanin Young Donelan & Banner (BYDRZ) physics +! Adapted from Babanin Young Donelan Rogers & Zieger (BYDRZ) physics ! as implemented as ST6 in WAVEWATCH-III ! Implementation into ECWAM DECEMBER 2021 by J. Kousal diff --git a/src/ecwam/tauwindsxy.F90 b/src/ecwam/tauwindsxy.F90 index eba31485b..f9923494b 100644 --- a/src/ecwam/tauwindsxy.F90 +++ b/src/ecwam/tauwindsxy.F90 @@ -26,7 +26,7 @@ SUBROUTINE TAUWINDSXY(SDENSX_IN, SDENSY_IN, CINV_IN, DSII_IN, NPTS, TAUWX_OUT, T ! ORIGIN. ! ---------- -! Adapted from Babanin Young Donelan & Banner (BYDRZ) physics +! Adapted from Babanin Young Donelan Rogers & Zieger (BYDRZ) physics ! as implemented as ST6 in WAVEWATCH-III ! Implementation into ECWAM DECEMBER 2021 by J. Kousal From 4f2ca92f5379f109d91c4f62e5b355c8dc3840f0 Mon Sep 17 00:00:00 2001 From: Josh Kousal <41773701+jkousal32@users.noreply.github.com> Date: Thu, 30 Apr 2026 10:56:22 +0200 Subject: [PATCH 84/89] Update src/ecwam/sinput_jan.F90 Co-authored-by: Copilot <175728472+Copilot@users.noreply.github.com> --- src/ecwam/sinput_jan.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/ecwam/sinput_jan.F90 b/src/ecwam/sinput_jan.F90 index 944c8cbc0..aa0734b32 100644 --- a/src/ecwam/sinput_jan.F90 +++ b/src/ecwam/sinput_jan.F90 @@ -101,7 +101,7 @@ SUBROUTINE SINPUT_JAN (NGST, LLSNEG, KIJS, KIJL, FL1 , & ! ------------- ! - REMOVAL OF CALL TO CRAY SPECIFIC FUNCTIONS EXPHF AND LOGHF -! BY THEIR STANDARD FORTRAN EQUIVALENT EXP and LOGHF +! BY THEIR STANDARD FORTRAN EQUIVALENT EXP and LOG ! - MODIFIED TO MAKE INTEGRATION SCHEME FULLY IMPLICIT ! - INTRODUCTION OF VARIABLE AIR DENSITY ! - INTRODUCTION OF WIND GUSTINESS From 081aaf56a5cc02e5099270e4fe502408fab481de Mon Sep 17 00:00:00 2001 From: Josh Kousal <41773701+jkousal32@users.noreply.github.com> Date: Thu, 30 Apr 2026 10:57:27 +0200 Subject: [PATCH 85/89] Update src/ecwam/airsea_jan.F90 Co-authored-by: Copilot <175728472+Copilot@users.noreply.github.com> --- src/ecwam/airsea_jan.F90 | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/ecwam/airsea_jan.F90 b/src/ecwam/airsea_jan.F90 index 379655b20..899b56eb7 100644 --- a/src/ecwam/airsea_jan.F90 +++ b/src/ecwam/airsea_jan.F90 @@ -29,14 +29,12 @@ SUBROUTINE AIRSEA_JAN (KIJS, KIJL, & !** INTERFACE. ! ---------- -! *CALL* *AIRSEA_JAN (KIJS, KIJL, FL1, WAVNUM, +! *CALL* *AIRSEA_JAN (KIJS, KIJL, ! HALP, U10, U10DIR, TAUW, TAUWDIR, RNFAC, ! US, Z0, Z0B, CHRNCK, ICODE_WND, IUSFG)* ! *KIJS* - INDEX OF FIRST GRIDPOINT. ! *KIJL* - INDEX OF LAST GRIDPOINT. -! *FL1* - SPECTRA -! *WAVNUM* - WAVE NUMBER ! *HALP* - 1/2 PHILLIPS PARAMETER ! *U10* - WINDSPEED U10. ! *U10DIR* - WINDSPEED DIRECTION. From 194abdfeec31f213efbb2d8591b704625fb76daf Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Thu, 30 Apr 2026 09:04:29 +0000 Subject: [PATCH 86/89] update comments --- src/ecwam/calcphiwa.F90 | 6 +++--- src/ecwam/mpuserin.F90 | 2 +- src/ecwam/setwavphys.F90 | 10 +++++----- src/ecwam/yowaltas.F90 | 2 +- 4 files changed, 10 insertions(+), 10 deletions(-) diff --git a/src/ecwam/calcphiwa.F90 b/src/ecwam/calcphiwa.F90 index 108337ccd..cf315a493 100644 --- a/src/ecwam/calcphiwa.F90 +++ b/src/ecwam/calcphiwa.F90 @@ -6,9 +6,9 @@ FUNCTION CALCPHIWA(SPOS,SNEG) RESULT(PHIWA) ! ! Calculate energy flux from wind into waves, obtained from wind-energy-input (Sin). ! -! / FRMAX -! tau = g * rho_water * | Sin(f) df -! / +! / FRMAX +! phiwa = g * rho_water * | Sin(f) df +! / !---------------------------------------------------------------------- ! diff --git a/src/ecwam/mpuserin.F90 b/src/ecwam/mpuserin.F90 index 12af24535..ce601220f 100644 --- a/src/ecwam/mpuserin.F90 +++ b/src/ecwam/mpuserin.F90 @@ -335,7 +335,7 @@ SUBROUTINE MPUSERIN ! ITESTB: MAX BLOCK NUMBER FOR OUTPUT IN BLOCK LOOPS. ! IREST: 1 FOR THE PRODUCTION OF RESTART FILE(S). ! IASSI: 1 ASSIMILATION IS DONE IF ANALYSIS RUN. -! IPHYS: WAVE PHYSICS PACKAGE (0 or 1) +! IPHYS: WAVE PHYSICS PACKAGE (0, 1 or 2, see SETWAVPHYS). ! IPHYS2_AIRSEA: 0: AS CLOSE TO WW3-ST6 AS POSSIBLE ! IPHYS2_AIRSEA: 1: AS CLOSE TO WW3-ST6 AS POSSIBLE, BUT ADDITIONALLY USE STRESS BALANCE (LFAC) TO UPDATE USTAR ! IPHYS2_AIRSEA: 2: ITERATIVE METHOD FOR THE AIR-SEA INTERACTION (U10, USTAR, CHARN, Z0) diff --git a/src/ecwam/setwavphys.F90 b/src/ecwam/setwavphys.F90 index 5e57b9297..e4ae57def 100644 --- a/src/ecwam/setwavphys.F90 +++ b/src/ecwam/setwavphys.F90 @@ -102,7 +102,7 @@ SUBROUTINE SETWAVPHYS CDISVIS = 0.0_JWRB ENDIF -!!! EMPIRICAL CONSTANCE FOR SPECTRAL UPDATE FOLLOWING DATA ASSIMILATION +!!! EMPIRICAL CONSTANTS FOR SPECTRAL UPDATE FOLLOWING DATA ASSIMILATION EGRCRV = 1108.0_JWRB AGRCRV = 0.06E+6_JWRB BGRCRV = 9.70_JWRB @@ -192,7 +192,7 @@ SUBROUTINE SETWAVPHYS ENDIF ENDIF -!!! EMPIRICAL CONSTANCE FOR SPECTRAL UPDATE FOLLOWING DATA ASSIMILATION +!!! EMPIRICAL CONSTANTS FOR SPECTRAL UPDATE FOLLOWING DATA ASSIMILATION EGRCRV = 1065.0_JWRB AGRCRV = 0.0655E+6_JWRB BGRCRV = 10.906_JWRB @@ -228,7 +228,7 @@ SUBROUTINE SETWAVPHYS ALPHAMIN = 0.0001_JWRB CHNKMIN_U = 33._JWRB -!!! EMPIRICAL CONSTANCE FOR SPECTRAL UPDATE FOLLOWING DATA ASSIMILATION +!!! EMPIRICAL CONSTANTS FOR SPECTRAL UPDATE FOLLOWING DATA ASSIMILATION ! TODO: THESE WILL REQUIRE RECALIBRATION IF USING W. DATA ASSIMILATION EGRCRV = 1065.0_JWRB AGRCRV = 0.0655E+6_JWRB @@ -257,7 +257,7 @@ SUBROUTINE SETWAVPHYS WRITE (IU06,*) '*************************************' WRITE (IU06,*) '* *' WRITE (IU06,*) '* ERROR IN SETWAVPHYS *' - WRITE (IU06,*) '* UKNOWN PHYSICS SELECTION : *' + WRITE (IU06,*) '* UNKNOWN PHYSICS SELECTION : *' WRITE (IU06,*) '* IPHYS2_AIRSEA =' , IPHYS2_AIRSEA WRITE (IU06,*) '* *' WRITE (IU06,*) '*************************************' @@ -278,7 +278,7 @@ SUBROUTINE SETWAVPHYS WRITE (IU06,*) '*************************************' WRITE (IU06,*) '* *' WRITE (IU06,*) '* ERROR IN SETWAVPHYS *' - WRITE (IU06,*) '* UKNOWN PHYSICS SELECTION : *' + WRITE (IU06,*) '* UNKNOWN PHYSICS SELECTION : *' WRITE (IU06,*) '* IPHYS =' , IPHYS WRITE (IU06,*) '* *' WRITE (IU06,*) '*************************************' diff --git a/src/ecwam/yowaltas.F90 b/src/ecwam/yowaltas.F90 index 72c39b22c..bacbc20e1 100644 --- a/src/ecwam/yowaltas.F90 +++ b/src/ecwam/yowaltas.F90 @@ -102,7 +102,7 @@ MODULE YOWALTAS ! LATITUDONAL BAND OF WIDTH LMAX FOR EACH PE ! *NOBSPE* INTEGER NUMBER OF DATA NEEDED PER PE (it includes data in the communication hallo). -!!! EMPIRICAL CONSTANCE FOR SPECTRAL UPDATE FOLLOWING DATA ASSIMILATION +!!! EMPIRICAL CONSTANTS FOR SPECTRAL UPDATE FOLLOWING DATA ASSIMILATION ! *EGRCRV* REAL PARAMETER OF THE NON DIMENSIONAL ENERGY ! GROWTH CURVE. ! ESTAR=EGRCRV*(TSTAR/(AGRCRV+TSTAR))**BGRCRV From 080a5715fdb165b5a36bd5327dce1d86f13f10ca Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Thu, 30 Apr 2026 12:30:12 +0000 Subject: [PATCH 87/89] remove dummy inits --- src/ecwam/setwavphys.F90 | 22 ---------------------- 1 file changed, 22 deletions(-) diff --git a/src/ecwam/setwavphys.F90 b/src/ecwam/setwavphys.F90 index e4ae57def..d3026c970 100644 --- a/src/ecwam/setwavphys.F90 +++ b/src/ecwam/setwavphys.F90 @@ -206,28 +206,6 @@ SUBROUTINE SETWAVPHYS ELSE IF (IPHYS.EQ.2) THEN - ! Dummy values for IPHYS=1-inherited variables not used in IPHYS=2. - ! N. B. The issue only appears when compiling in coupled mode - ! BYDRZ TODO: these should be cleaned up so they are not required with this physics option. - ZALP = 0.008_JWRB - ANG_GC_A = 0.35_JWRB - ANG_GC_B = 0.65_JWRB - ANG_GC_C = 3.0_JWRB - RN1_RN = 0.25_JWRB - DELTA_THETA_RN = 0.75_JWRB - DTHRN_A = 0.60_JWRB - DTHRN_U = 200.0_JWRB - Z0TUBMAX = 0.0005_JWRB - Z0RAT = 0.04_JWRB - SWELLF4 = 1.5E05_JWRB - SWELLF7 = 3.6E05_JWRB - SWELLF7M1 = 1.0_JWRB/SWELLF7 - SSDSC5 = 0.0_JWRB - BETAMAX = 1.40_JWRB - TAUWSHELTER = 0.25_JWRB - ALPHAMIN = 0.0001_JWRB - CHNKMIN_U = 33._JWRB - !!! EMPIRICAL CONSTANTS FOR SPECTRAL UPDATE FOLLOWING DATA ASSIMILATION ! TODO: THESE WILL REQUIRE RECALIBRATION IF USING W. DATA ASSIMILATION EGRCRV = 1065.0_JWRB From 05e8b506245822191dfb31e011314da5fdd97ca3 Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Tue, 5 May 2026 12:42:13 +0000 Subject: [PATCH 88/89] setup initializations cleanly for different physics --- src/ecwam/CMakeLists.txt | 1 + src/ecwam/init_freqext.F90 | 100 +++++++++++++++++++++++++++++++++++++ src/ecwam/initmdl.F90 | 60 +++++++--------------- src/ecwam/setwavphys.F90 | 4 ++ src/ecwam/sinflx_bydrz.F90 | 2 +- 5 files changed, 124 insertions(+), 43 deletions(-) create mode 100644 src/ecwam/init_freqext.F90 diff --git a/src/ecwam/CMakeLists.txt b/src/ecwam/CMakeLists.txt index 234b2de06..3f5a51a26 100644 --- a/src/ecwam/CMakeLists.txt +++ b/src/ecwam/CMakeLists.txt @@ -103,6 +103,7 @@ list( APPEND ecwam_srcs incdate.F90 inisnonlin.F90 init_fieldg.F90 + init_freqext.F90 init_sdiss_ardh.F90 init_x0tauhf.F90 initdpthflds.F90 diff --git a/src/ecwam/init_freqext.F90 b/src/ecwam/init_freqext.F90 new file mode 100644 index 000000000..22641eb8f --- /dev/null +++ b/src/ecwam/init_freqext.F90 @@ -0,0 +1,100 @@ +! (C) Copyright 1989- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. +! + + SUBROUTINE INIT_FREQEXT + +! ---------------------------------------------------------------------- + +!**** *INIT_FREQEXT* - + +!* PURPOSE. +! --------- + +! INITIALISATION FOR EXTENDED FREQUENCY-SPACE + + +!** INTERFACE. +! ---------- + +! *CALL* *INIT_FREQEXT* + +! METHOD. +! ------- + +! EXTERNALS. +! ---------- + +! NONE. + +! REFERENCE. +! ---------- + +! ---------------------------------------------------------------------- + + USE PARKIND_WAVE, ONLY : JWIM, JWRB + + USE YOWFRED , ONLY : DELTH ,FR ,DFIM ,FRATIO , & + & SIG ,DSII ,SIGM1 ,DF , & + & SIG_EXT ,DSII_EXT ,IFRE_EXT ,NFRE_EXT ,DDEN + USE YOWPARAM , ONLY : NFRE + USE YOWPHYS , ONLY : FRQMAX + USE YOWPCONS , ONLY : ZPI + + USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK + +! ---------------------------------------------------------------------- + + IMPLICIT NONE + + INTEGER(KIND=JWIM) :: M + + REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + +! ---------------------------------------------------------------------- + + IF (LHOOK) CALL DR_HOOK('INIT_FREQEXT',0,ZHOOK_HANDLE) + + IF (.NOT.ALLOCATED(DF)) ALLOCATE(DF(NFRE)) + IF (.NOT.ALLOCATED(SIG)) ALLOCATE(SIG(NFRE)) + IF (.NOT.ALLOCATED(DDEN)) ALLOCATE(DDEN(NFRE)) + IF (.NOT.ALLOCATED(DSII)) ALLOCATE(DSII(NFRE)) + IF (.NOT.ALLOCATED(SIGM1)) ALLOCATE(SIGM1(NFRE)) + DO M=1,NFRE + DF(M) = DFIM(M)/DELTH + SIG(M) = ZPI*FR(M) + DSII(M) = ZPI*DF(M) + DDEN(M) = ZPI*DFIM(M)*SIG(M) + SIGM1(M) = 1.0_JWRB/SIG(M) + ENDDO + + ! DETERMINE THE NUMBER OF FREQUENCIES TO EXTEND TO + NFRE_EXT = CEILING(LOG(FRQMAX/FR(1))/LOG(FRATIO))+1 + NFRE_EXT = MAX(NFRE,NFRE_EXT) + IF (ALLOCATED(IFRE_EXT)) THEN + IF (SIZE(IFRE_EXT) /= NFRE_EXT) DEALLOCATE(IFRE_EXT) + END IF + IF (.NOT.ALLOCATED(IFRE_EXT)) ALLOCATE(IFRE_EXT(NFRE_EXT)) + IFRE_EXT = (/ (REAL(M, KIND=JWRB), M=1,NFRE_EXT) /) + IF (.NOT.ALLOCATED(SIG_EXT)) ALLOCATE(SIG_EXT(NFRE_EXT)) + IF (.NOT.ALLOCATED(DSII_EXT)) ALLOCATE(DSII_EXT(NFRE_EXT)) + IF (NFRE .LT. NFRE_EXT) THEN + SIG_EXT = SIG(1)*FRATIO**(IFRE_EXT-1.0_JWRB) + DSII_EXT = 0.5_JWRB * SIG_EXT * (FRATIO-1.0_JWRB/FRATIO) + ! The first and last frequency bin: + DSII_EXT(1) = 0.5_JWRB * SIG_EXT(1) * (FRATIO-1.0_JWRB) + DSII_EXT(NFRE_EXT) = 0.5_JWRB * SIG_EXT(NFRE_EXT) * (FRATIO-1.0_JWRB) / FRATIO + ELSE + SIG_EXT = SIG + DSII_EXT = DSII + END IF + + + IF (LHOOK) CALL DR_HOOK('INIT_FREQEXT',1,ZHOOK_HANDLE) + + END SUBROUTINE INIT_FREQEXT diff --git a/src/ecwam/initmdl.F90 b/src/ecwam/initmdl.F90 index 598b43d6c..821639610 100644 --- a/src/ecwam/initmdl.F90 +++ b/src/ecwam/initmdl.F90 @@ -177,8 +177,7 @@ SUBROUTINE INITMDL (NADV, & & DFIM ,DFIMOFR ,DFIMFR ,DFIMFR2 , & & DFIM_SIM ,DFIMOFR_SIM ,DFIMFR_SIM ,DFIMFR2_SIM , & & DFIM_END_L, DFIM_END_U, & - & WVPRPT_LAND, SIG ,DSII ,SIGM1 ,DF, & - & SIG_EXT , DSII_EXT ,IFRE_EXT ,NFRE_EXT ,DDEN + & WVPRPT_LAND USE YOWGRIBHD, ONLY : LGRHDIFS USE YOWGRID , ONLY : DELPHI, DELLAM, COSPH, & & NPROMA_WAM, NCHNK, IJFROMCHNK @@ -243,6 +242,7 @@ SUBROUTINE INITMDL (NADV, & #include "headbc.intfb.h" #include "incdate.intfb.h" #include "inisnonlin.intfb.h" +#include "init_freqext.intfb.h" #include "init_sdiss_ardh.intfb.h" #include "init_x0tauhf.intfb.h" #include "initdpthflds.intfb.h" @@ -504,48 +504,24 @@ SUBROUTINE INITMDL (NADV, & ENDDO ! -------------------------------------------------- - ! BYDRZ-specific frequency-space setup (only needed for IPHYS=2). - IF (IPHYS == 2) THEN - IF (.NOT.ALLOCATED(DF)) ALLOCATE(DF(NFRE)) - IF (.NOT.ALLOCATED(SIG)) ALLOCATE(SIG(NFRE)) - IF (.NOT.ALLOCATED(DDEN)) ALLOCATE(DDEN(NFRE)) - IF (.NOT.ALLOCATED(DSII)) ALLOCATE(DSII(NFRE)) - IF (.NOT.ALLOCATED(SIGM1)) ALLOCATE(SIGM1(NFRE)) - DO M=1,NFRE - DF(M) = DFIM(M)/DELTH - SIG(M) = ZPI*FR(M) - DSII(M) = ZPI*DF(M) - DDEN(M) = ZPI*DFIM(M)*SIG(M) - SIGM1(M) = 1.0_JWRB/SIG(M) - ENDDO - - ! DETERMINE THE NUMBER OF FREQUENCIES TO EXTEND TO - NFRE_EXT = CEILING(LOG(FRQMAX/FR(1))/LOG(FRATIO))+1 - NFRE_EXT = MAX(NFRE,NFRE_EXT) - IF (ALLOCATED(IFRE_EXT)) THEN - IF (SIZE(IFRE_EXT) /= NFRE_EXT) DEALLOCATE(IFRE_EXT) - END IF - IF (.NOT.ALLOCATED(IFRE_EXT)) ALLOCATE(IFRE_EXT(NFRE_EXT)) - IFRE_EXT = (/ (REAL(M, KIND=JWRB), M=1,NFRE_EXT) /) - IF (.NOT.ALLOCATED(SIG_EXT)) ALLOCATE(SIG_EXT(NFRE_EXT)) - IF (.NOT.ALLOCATED(DSII_EXT)) ALLOCATE(DSII_EXT(NFRE_EXT)) - IF (NFRE .LT. NFRE_EXT) THEN - SIG_EXT = SIG(1)*FRATIO**(IFRE_EXT-1.0_JWRB) - DSII_EXT = 0.5_JWRB * SIG_EXT * (FRATIO-1.0_JWRB/FRATIO) - ! The first and last frequency bin: - DSII_EXT(1) = 0.5_JWRB * SIG_EXT(1) * (FRATIO-1.0_JWRB) - DSII_EXT(NFRE_EXT) = 0.5_JWRB * SIG_EXT(NFRE_EXT) * (FRATIO-1.0_JWRB) / FRATIO - ELSE - SIG_EXT = SIG - DSII_EXT = DSII - END IF - END IF + ! IPHYS-SPECIFIC INITIALISATIONS + SELECT CASE (IPHYS) + CASE(0,1) + + ! FRICTION COEFFICIENTS IN OSCILLATORY BOUNDARY LAYERS + CALL TABU_SWELLFT + + ! INITIALISATION FOR TAU_PHI_HF + CALL INIT_X0TAUHF + + CASE(2) + + ! INITIALISATION FOR THE EXTENDED FREQUENCY-SPACE + CALL INIT_FREQEXT + + END SELECT ! -------------------------------------------------- - CALL TABU_SWELLFT - - CALL INIT_X0TAUHF - KTAG=100 ! 1.5 DETERMINE LAST OUTPUT DATE diff --git a/src/ecwam/setwavphys.F90 b/src/ecwam/setwavphys.F90 index d3026c970..9aac10d45 100644 --- a/src/ecwam/setwavphys.F90 +++ b/src/ecwam/setwavphys.F90 @@ -205,6 +205,10 @@ SUBROUTINE SETWAVPHYS BSWKM = 0.425_JWRB ELSE IF (IPHYS.EQ.2) THEN + +! MINIMUM SPECTRAL STEEPNESS AND WIND-SPEED DEPENDENCE OF CHARNOCK COEFFICIENT + ALPHAMIN = 0.0001_JWRB + CHNKMIN_U = 33._JWRB !!! EMPIRICAL CONSTANTS FOR SPECTRAL UPDATE FOLLOWING DATA ASSIMILATION ! TODO: THESE WILL REQUIRE RECALIBRATION IF USING W. DATA ASSIMILATION diff --git a/src/ecwam/sinflx_bydrz.F90 b/src/ecwam/sinflx_bydrz.F90 index ad23ee19c..f2a187463 100644 --- a/src/ecwam/sinflx_bydrz.F90 +++ b/src/ecwam/sinflx_bydrz.F90 @@ -116,7 +116,7 @@ SUBROUTINE SINFLX_BYDRZ (ICALL, NCALL, NGST, KIJS, KIJL, & & ABMIN ,ABMAX, DTHRN_A ,DTHRN_U, RNU_WATER, & & ZSIN6A0, FRQMAX, LLFACT USE YOWTEST , ONLY : IU06 - USE YOWTABL , ONLY : IAB ,SWELLFT + USE YOWTABL , ONLY : IAB USE YOWSTAT , ONLY : IPHYS2_AIRSEA, LLLOWWINDS, ZCDFAC USE YOMHOOK , ONLY : LHOOK, DR_HOOK, JPHOOK From c202a3cd0460a33e9e3aead0ed43dfe4314bcb84 Mon Sep 17 00:00:00 2001 From: Josh Kousal Date: Tue, 5 May 2026 16:04:58 +0000 Subject: [PATCH 89/89] address B1 issue --- src/ecwam/swldissip_bydrz.F90 | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/ecwam/swldissip_bydrz.F90 b/src/ecwam/swldissip_bydrz.F90 index 9f691b55f..93bc59e23 100644 --- a/src/ecwam/swldissip_bydrz.F90 +++ b/src/ecwam/swldissip_bydrz.F90 @@ -178,6 +178,10 @@ SUBROUTINE SWLDISSIP_BYDRZ (KIJS, KIJL, FL1, FLD, SL, & DO IJ = KIJS,KIJL B1(IJ) = ZSWL6B1*(2.0_JWRB*SQRT(SUMDIR_IJ(IJ))*WAVNUM(IJ,MPEAK(IJ))) END DO +ELSE + DO IJ = KIJS,KIJL + B1(IJ) = ZSWL6B1 + END DO END IF ! !/ 2) --- Calculate the derivative term only (in units of 1/s) ------- /