From 0f522ddcb9224cd13ed9e6e16c6e93a4d129466f Mon Sep 17 00:00:00 2001 From: Michael Staneker Date: Thu, 21 Mar 2024 12:52:59 +0000 Subject: [PATCH] CUDA Fortran SCC-HOIST: Loki generated and copied to ecwam/src --- .../airsea.cuf_hoist_new.F90 | 182 +++ .../aki_ice.cuf_hoist_new.F90 | 118 ++ .../chnkmin.cuf_hoist_new.F90 | 64 ++ .../cimsstrn.cuf_hoist_new.F90 | 130 +++ .../ciwabr.cuf_hoist_new.F90 | 118 ++ .../femeanws.cuf_hoist_new.F90 | 134 +++ .../fkmean.cuf_hoist_new.F90 | 170 +++ .../frcutindex.cuf_hoist_new.F90 | 126 ++ .../halphap.cuf_hoist_new.F90 | 154 +++ .../imphftail.cuf_hoist_new.F90 | 103 ++ .../implsch.cuf_hoist_new.F90 | 724 ++++++++++++ .../ns_gc.cuf_hoist_new.F90 | 58 + .../peak_ang.cuf_hoist_new.F90 | 184 +++ .../sbottom.cuf_hoist_new.F90 | 110 ++ .../sdepthlim.cuf_hoist_new.F90 | 105 ++ .../sdissip.cuf_hoist_new.F90 | 120 ++ .../sdissip_ard.cuf_hoist_new.F90 | 235 ++++ .../sdissip_jan.cuf_hoist_new.F90 | 145 +++ .../sdiwbk.cuf_hoist_new.F90 | 138 +++ .../setice.cuf_hoist_new.F90 | 97 ++ .../sinflx.cuf_hoist_new.F90 | 285 +++++ .../sinput.cuf_hoist_new.F90 | 171 +++ .../sinput_ard.cuf_hoist_new.F90 | 1013 +++++++++++++++++ .../snonlin.cuf_hoist_new.F90 | 465 ++++++++ .../stokesdrift.cuf_hoist_new.F90 | 159 +++ .../stokestrn.cuf_hoist_new.F90 | 126 ++ .../stress_gc.cuf_hoist_new.F90 | 142 +++ .../stresso.cuf_hoist_new.F90 | 266 +++++ .../tau_phi_hf.cuf_hoist_new.F90 | 459 ++++++++ .../taut_z0.cuf_hoist_new.F90 | 396 +++++++ .../transf.cuf_hoist_new.F90 | 75 ++ .../transf_snl.cuf_hoist_new.F90 | 94 ++ .../wamintgr_loki_gpu.cuf_hoist_new.F90 | 694 +++++++++++ .../wnfluxes.cuf_hoist_new.F90 | 293 +++++ .../yowaltas.cuf_hoist_new.F90 | 176 +++ .../yowcoup.cuf_hoist_new.F90 | 251 ++++ .../yowcout.cuf_hoist_new.F90 | 152 +++ .../yowfred.cuf_hoist_new.F90 | 219 ++++ .../yowice.cuf_hoist_new.F90 | 83 ++ .../yowindn.cuf_hoist_new.F90 | 130 +++ .../yowparam.cuf_hoist_new.F90 | 101 ++ .../yowpcons.cuf_hoist_new.F90 | 133 +++ .../yowphys.cuf_hoist_new.F90 | 195 ++++ .../yowshal.cuf_hoist_new.F90 | 69 ++ .../yowstat.cuf_hoist_new.F90 | 262 +++++ .../yowtabl.cuf_hoist_new.F90 | 142 +++ .../yowwind.cuf_hoist_new.F90 | 91 ++ .../yowwndg.cuf_hoist_new.F90 | 37 + .../z0wave.cuf_hoist_new.F90 | 105 ++ 49 files changed, 9999 insertions(+) create mode 100644 src/phys-scc-cuf-hoist/airsea.cuf_hoist_new.F90 create mode 100644 src/phys-scc-cuf-hoist/aki_ice.cuf_hoist_new.F90 create mode 100644 src/phys-scc-cuf-hoist/chnkmin.cuf_hoist_new.F90 create mode 100644 src/phys-scc-cuf-hoist/cimsstrn.cuf_hoist_new.F90 create mode 100644 src/phys-scc-cuf-hoist/ciwabr.cuf_hoist_new.F90 create mode 100644 src/phys-scc-cuf-hoist/femeanws.cuf_hoist_new.F90 create mode 100644 src/phys-scc-cuf-hoist/fkmean.cuf_hoist_new.F90 create mode 100644 src/phys-scc-cuf-hoist/frcutindex.cuf_hoist_new.F90 create mode 100644 src/phys-scc-cuf-hoist/halphap.cuf_hoist_new.F90 create mode 100644 src/phys-scc-cuf-hoist/imphftail.cuf_hoist_new.F90 create mode 100644 src/phys-scc-cuf-hoist/implsch.cuf_hoist_new.F90 create mode 100644 src/phys-scc-cuf-hoist/ns_gc.cuf_hoist_new.F90 create mode 100644 src/phys-scc-cuf-hoist/peak_ang.cuf_hoist_new.F90 create mode 100644 src/phys-scc-cuf-hoist/sbottom.cuf_hoist_new.F90 create mode 100644 src/phys-scc-cuf-hoist/sdepthlim.cuf_hoist_new.F90 create mode 100644 src/phys-scc-cuf-hoist/sdissip.cuf_hoist_new.F90 create mode 100644 src/phys-scc-cuf-hoist/sdissip_ard.cuf_hoist_new.F90 create mode 100644 src/phys-scc-cuf-hoist/sdissip_jan.cuf_hoist_new.F90 create mode 100644 src/phys-scc-cuf-hoist/sdiwbk.cuf_hoist_new.F90 create mode 100644 src/phys-scc-cuf-hoist/setice.cuf_hoist_new.F90 create mode 100644 src/phys-scc-cuf-hoist/sinflx.cuf_hoist_new.F90 create mode 100644 src/phys-scc-cuf-hoist/sinput.cuf_hoist_new.F90 create mode 100644 src/phys-scc-cuf-hoist/sinput_ard.cuf_hoist_new.F90 create mode 100644 src/phys-scc-cuf-hoist/snonlin.cuf_hoist_new.F90 create mode 100644 src/phys-scc-cuf-hoist/stokesdrift.cuf_hoist_new.F90 create mode 100644 src/phys-scc-cuf-hoist/stokestrn.cuf_hoist_new.F90 create mode 100644 src/phys-scc-cuf-hoist/stress_gc.cuf_hoist_new.F90 create mode 100644 src/phys-scc-cuf-hoist/stresso.cuf_hoist_new.F90 create mode 100644 src/phys-scc-cuf-hoist/tau_phi_hf.cuf_hoist_new.F90 create mode 100644 src/phys-scc-cuf-hoist/taut_z0.cuf_hoist_new.F90 create mode 100644 src/phys-scc-cuf-hoist/transf.cuf_hoist_new.F90 create mode 100644 src/phys-scc-cuf-hoist/transf_snl.cuf_hoist_new.F90 create mode 100644 src/phys-scc-cuf-hoist/wamintgr_loki_gpu.cuf_hoist_new.F90 create mode 100644 src/phys-scc-cuf-hoist/wnfluxes.cuf_hoist_new.F90 create mode 100644 src/phys-scc-cuf-hoist/yowaltas.cuf_hoist_new.F90 create mode 100644 src/phys-scc-cuf-hoist/yowcoup.cuf_hoist_new.F90 create mode 100644 src/phys-scc-cuf-hoist/yowcout.cuf_hoist_new.F90 create mode 100644 src/phys-scc-cuf-hoist/yowfred.cuf_hoist_new.F90 create mode 100644 src/phys-scc-cuf-hoist/yowice.cuf_hoist_new.F90 create mode 100644 src/phys-scc-cuf-hoist/yowindn.cuf_hoist_new.F90 create mode 100644 src/phys-scc-cuf-hoist/yowparam.cuf_hoist_new.F90 create mode 100644 src/phys-scc-cuf-hoist/yowpcons.cuf_hoist_new.F90 create mode 100644 src/phys-scc-cuf-hoist/yowphys.cuf_hoist_new.F90 create mode 100644 src/phys-scc-cuf-hoist/yowshal.cuf_hoist_new.F90 create mode 100644 src/phys-scc-cuf-hoist/yowstat.cuf_hoist_new.F90 create mode 100644 src/phys-scc-cuf-hoist/yowtabl.cuf_hoist_new.F90 create mode 100644 src/phys-scc-cuf-hoist/yowwind.cuf_hoist_new.F90 create mode 100644 src/phys-scc-cuf-hoist/yowwndg.cuf_hoist_new.F90 create mode 100644 src/phys-scc-cuf-hoist/z0wave.cuf_hoist_new.F90 diff --git a/src/phys-scc-cuf-hoist/airsea.cuf_hoist_new.F90 b/src/phys-scc-cuf-hoist/airsea.cuf_hoist_new.F90 new file mode 100644 index 00000000..4863d4de --- /dev/null +++ b/src/phys-scc-cuf-hoist/airsea.cuf_hoist_new.F90 @@ -0,0 +1,182 @@ +! (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. +! +MODULE AIRSEA_CUF_HOIST_NEW_MOD + CONTAINS + ATTRIBUTES(DEVICE) SUBROUTINE AIRSEA_CUF_HOIST_NEW (KIJS, KIJL, HALP, U10, U10DIR, TAUW, TAUWDIR, RNFAC, US, Z0, Z0B, CHRNCK, & + & ICODE_WND, IUSFG, ACD, ALPHA, ALPHAMAX, ALPHAMIN, ANG_GC_A, ANG_GC_B, ANG_GC_C, BCD, BETAMAXOXKAPPA2, BMAXOKAP, & + & C2OSQRTVG_GC, CDMAX, CHNKMIN_U, CM_GC, DELKCC_GC_NS, DELKCC_OMXKM3_GC, EPS1, EPSMIN, EPSUS, G, GM1, LLCAPCHNK, LLGCBZ0, & + & LLNORMAGAM, NWAV_GC, OM3GMKM_GC, OMXKM3_GC, RN1_RN, RNU, RNUM, SQRTGOSURFT, WSPMIN, XKAPPA, XKMSQRTVGOC2_GC, XKM_GC, XK_GC, & + & XLOGKRATIOM1_GC, XNLEV, ZALP, ICHNK, NCHNK, IJ) + + ! ---------------------------------------------------------------------- + + !**** *AIRSEA* - 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 (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 Z0WAVE_CUF_HOIST_NEW_MOD, ONLY: Z0WAVE_CUF_HOIST_NEW + USE TAUT_Z0_CUF_HOIST_NEW_MOD, ONLY: TAUT_Z0_CUF_HOIST_NEW + USE cudafor + USE PARKIND_WAVE, ONLY: JWIM, JWRU, JWRB + + USE YOWPARAM, ONLY: NFRE, NANG + USE YOWTEST, ONLY: IU06 + + + ! ---------------------------------------------------------------------- + IMPLICIT NONE + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJS + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJL + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: ICODE_WND + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: IUSFG + REAL(KIND=JWRB), INTENT(IN) :: HALP(KIJL) + REAL(KIND=JWRB), INTENT(IN) :: RNFAC(KIJL) + REAL(KIND=JWRB), INTENT(IN) :: U10DIR(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: TAUW(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: TAUWDIR(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: U10(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: US(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(OUT) :: Z0(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(OUT) :: Z0B(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(OUT) :: CHRNCK(KIJL, NCHNK) + + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: IJ + INTEGER(KIND=JWIM) :: I + INTEGER(KIND=JWIM) :: J + + REAL(KIND=JWRB) :: XI + REAL(KIND=JWRB) :: XJ + REAL(KIND=JWRB) :: DELI1 + REAL(KIND=JWRB) :: DELI2 + REAL(KIND=JWRB) :: DELJ1 + REAL(KIND=JWRB) :: DELJ2 + REAL(KIND=JWRB) :: UST2 + REAL(KIND=JWRB) :: ARG + REAL(KIND=JWRB) :: SQRTCDM1 + REAL(KIND=JWRB) :: XKAPPAD + REAL(KIND=JWRB) :: XLOGLEV + REAL(KIND=JWRB) :: XLEV + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ACD + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ALPHA + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ALPHAMAX + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ALPHAMIN + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ANG_GC_A + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ANG_GC_B + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ANG_GC_C + REAL(KIND=JWRB), VALUE, INTENT(IN) :: BCD + REAL(KIND=JWRB), VALUE, INTENT(IN) :: BETAMAXOXKAPPA2 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: BMAXOKAP + REAL(KIND=JWRB), INTENT(IN), DEVICE :: C2OSQRTVG_GC(NWAV_GC) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: CDMAX + REAL(KIND=JWRB), VALUE, INTENT(IN) :: CHNKMIN_U + REAL(KIND=JWRB), INTENT(IN), DEVICE :: CM_GC(NWAV_GC) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: DELKCC_GC_NS(NWAV_GC) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: DELKCC_OMXKM3_GC(NWAV_GC) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: EPS1 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: EPSMIN + REAL(KIND=JWRB), VALUE, INTENT(IN) :: EPSUS + REAL(KIND=JWRB), VALUE, INTENT(IN) :: G + REAL(KIND=JWRB), VALUE, INTENT(IN) :: GM1 + LOGICAL, VALUE, INTENT(IN) :: LLCAPCHNK + LOGICAL, VALUE, INTENT(IN) :: LLGCBZ0 + LOGICAL, VALUE, INTENT(IN) :: LLNORMAGAM + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NWAV_GC + REAL(KIND=JWRB), INTENT(IN), DEVICE :: OM3GMKM_GC(NWAV_GC) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: OMXKM3_GC(NWAV_GC) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: RN1_RN + REAL(KIND=JWRB), VALUE, INTENT(IN) :: RNU + REAL(KIND=JWRB), VALUE, INTENT(IN) :: RNUM + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SQRTGOSURFT + REAL(KIND=JWRB), VALUE, INTENT(IN) :: WSPMIN + REAL(KIND=JWRB), VALUE, INTENT(IN) :: XKAPPA + REAL(KIND=JWRB), INTENT(IN), DEVICE :: XKMSQRTVGOC2_GC(NWAV_GC) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: XKM_GC(NWAV_GC) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: XK_GC(NWAV_GC) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: XLOGKRATIOM1_GC + REAL(KIND=JWRB), VALUE, INTENT(IN) :: XNLEV + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ZALP + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: ICHNK + INTEGER, VALUE, INTENT(IN) :: NCHNK + + ! ---------------------------------------------------------------------- + + !* 2. DETERMINE TOTAL STRESS (if needed) + ! ---------------------------------- + + IF (ICODE_WND == 3) THEN + + CALL TAUT_Z0_CUF_HOIST_NEW(KIJS, KIJL, IUSFG, HALP(:), U10(:, :), U10DIR(:, :), TAUW(:, :), TAUWDIR(:, :), RNFAC(:), & + & US(:, :), Z0(:, :), Z0B(:, :), CHRNCK(:, :), ACD, ALPHA, ALPHAMAX, ALPHAMIN, ANG_GC_A, ANG_GC_B, ANG_GC_C, BCD, & + & BETAMAXOXKAPPA2, BMAXOKAP, C2OSQRTVG_GC(:), CDMAX, CHNKMIN_U, CM_GC(:), DELKCC_GC_NS(:), DELKCC_OMXKM3_GC(:), EPS1, & + & EPSMIN, EPSUS, G, GM1, LLCAPCHNK, LLGCBZ0, LLNORMAGAM, NWAV_GC, OM3GMKM_GC(:), OMXKM3_GC(:), RN1_RN, RNU, RNUM, & + & SQRTGOSURFT, XKAPPA, XKMSQRTVGOC2_GC(:), XKM_GC(:), XK_GC(:), XLOGKRATIOM1_GC, XNLEV, ZALP, ICHNK, NCHNK, IJ) + + ELSE IF (ICODE_WND == 1 .or. ICODE_WND == 2) THEN + + !* 3. DETERMINE ROUGHNESS LENGTH (if needed). + ! --------------------------- + + CALL Z0WAVE_CUF_HOIST_NEW(KIJS, KIJL, US(:, :), TAUW(:, :), U10(:, :), Z0(:, :), Z0B(:, :), CHRNCK(:, :), ALPHA, ALPHAMIN, & + & CHNKMIN_U, EPS1, G, GM1, LLCAPCHNK, ICHNK, NCHNK, IJ) + + !* 3. DETERMINE U10 (if needed). + ! --------------------------- + + XKAPPAD = 1.0_JWRB / XKAPPA + XLOGLEV = LOG(XNLEV) + + + U10(IJ, ICHNK) = XKAPPAD*US(IJ, ICHNK)*(XLOGLEV - LOG(Z0(IJ, ICHNK))) + U10(IJ, ICHNK) = MAX(U10(IJ, ICHNK), WSPMIN) + + + END IF + + + END SUBROUTINE AIRSEA_CUF_HOIST_NEW +END MODULE AIRSEA_CUF_HOIST_NEW_MOD diff --git a/src/phys-scc-cuf-hoist/aki_ice.cuf_hoist_new.F90 b/src/phys-scc-cuf-hoist/aki_ice.cuf_hoist_new.F90 new file mode 100644 index 00000000..6de39f6e --- /dev/null +++ b/src/phys-scc-cuf-hoist/aki_ice.cuf_hoist_new.F90 @@ -0,0 +1,118 @@ +! (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. +! +MODULE AKI_ICE_CUF_HOIST_NEW_MOD + CONTAINS + ATTRIBUTES(DEVICE) FUNCTION AKI_ICE_CUF_HOIST_NEW (G, XK, DEPTH, RHOW, CITH) + + ! ---------------------------------------------------------------------- + + !**** *AKI_ICE* - FUNCTION TO COMPUTE WAVE NUMBER UNDER THE ICE. + ! FOR A GIVEN OPEN WATER WAVE NUMBER. + + !* PURPOSE. + ! ------- + + ! *AKI_ICE* COMPUTES THE REAL WAVE NUMBER UNDER THE ICE AS FUNCTION OF + ! OPEN OCEAN WAVE NUMBER, THE WATER DEPTH AND THE ICE THICKNESS. + + !** INTERFACE. + ! ---------- + + ! *FUNCTION* *AKI_ICE (G,XK,DEPTH,RHOW,CITH))* + ! *G* - ACCELERATION OF GRAVITY (m/s**2). + ! *XK* - OPEN OCEAN WAVE NUMBER (1/m). + ! *DEPTH* - WATER DEPTH (m). + ! *RHOW* - WATER DENSITY (kg/m**3). + ! *CITH* - SEA ICE THICKNESS (m). + + ! METHOD. + ! ------- + + ! NEWTONS METHOD TO SOLVE THE LINEAR DISPERSION RELATION IN + ! SHALLOW WATER UNDER AN INFINITELY LONG ELASTIC FLOATING PLATE + ! REPRESENTING THE SEA ICE. THE MECHANICAL PROPERTIES OF THE SEA + ! ICE IS GIVEn BY ITS YOUNG MODULUS, THE POISSON'S RATIO AND ITS + ! DENSITY (these are fixed for now, see below). + + ! IF F(x)=0, then solve iteratively + ! x(n+1) = x(n) - F(x(n))/F'(x(n)) + + ! WHERE F'(x) IS THE FIRST DERIVATIVE OF F WITH RESPECT TO x. + + ! EXTERNALS. + ! ---------- + + ! NONE. + + ! REFERENCE. + ! ---------- + + ! FOX AND SQUIRE, 1991, JGR 96, C3, 4531-4547. + + ! NONE. + + ! ---------------------------------------------------------------------- + + USE cudafor + USE PARKIND_WAVE, ONLY: JWIM, JWRU, JWRB + + IMPLICIT NONE + + REAL(KIND=JWRB) :: AKI_ICE_CUF_HOIST_NEW + REAL(KIND=JWRB), INTENT(IN) :: G, XK, DEPTH, RHOW, CITH + + ! ICE PROPERTIES (assumed fixed for now) + REAL(KIND=JWRB), PARAMETER :: YMICE = 5.5E+9_JWRB ! typical value of Young modulus of sea ice + REAL(KIND=JWRB), PARAMETER :: RMUICE = 0.3_JWRB ! Poisson's ratio of sea ice + REAL(KIND=JWRB), PARAMETER :: RHOI = 922.5_JWRB ! typical value of the sea ice density + + ! RELATIVE ERROR LIMIT OF NEWTONS METHOD. + REAL(KIND=JWRB), PARAMETER :: EBS = 0.000001_JWRB + ! MAXIMUM WAVE NUMBER + REAL(KIND=JWRB), PARAMETER :: AKI_MAX = 20.0_JWRB + + REAL(KIND=JWRB) :: FICSTF, RDH + REAL(KIND=JWRB) :: OM2, AKI, AKIOLD, F, FPRIME, AKID +!$acc routine seq + + + IF (CITH <= 0.0_JWRB) THEN + AKI = XK + ELSE + ! BENDING STIFFNESS / WATER DENSITY + FICSTF = (YMICE*CITH**3 / (12*(1 - RMUICE**2))) / RHOW + + ! DENSITY RATIO * ICE THICKNESS + RDH = (RHOI / RHOW)*CITH + + ! SQUARE OF THE OPEN OCEAN ANGULAR FREQUENCY + OM2 = G*XK*TANH(XK*DEPTH) + + !* 2. ITERATION LOOP. + ! --------------- + + AKIOLD = 0.0_JWRB + AKI = MIN(XK, (OM2 / MAX(FICSTF, 1.0_JWRB))**0.2_JWRB) + + DO WHILE (ABS(AKI - AKIOLD) > EBS*AKIOLD .and. AKI < AKI_MAX) + AKIOLD = AKI + AKID = MIN(DEPTH*AKI, 50.0_JWRB) + F = FICSTF*AKI**5 + G*AKI - OM2*(RDH*AKI + 1. / TANH(AKID)) + FPRIME = 5._JWRB*FICSTF*AKI**4 + G - OM2*(RDH - DEPTH / (SINH(AKID)**2)) + AKI = AKI - F / FPRIME + ! in case of overshoot because it is trying to find a very large wave number + IF (AKI <= 0.0_JWRB) AKI = AKI_MAX + END DO + + END IF + + AKI_ICE_CUF_HOIST_NEW = AKI + + END FUNCTION AKI_ICE_CUF_HOIST_NEW +END MODULE AKI_ICE_CUF_HOIST_NEW_MOD diff --git a/src/phys-scc-cuf-hoist/chnkmin.cuf_hoist_new.F90 b/src/phys-scc-cuf-hoist/chnkmin.cuf_hoist_new.F90 new file mode 100644 index 00000000..da47cbcb --- /dev/null +++ b/src/phys-scc-cuf-hoist/chnkmin.cuf_hoist_new.F90 @@ -0,0 +1,64 @@ +! (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. +! +MODULE CHNKMIN_CUF_HOIST_NEW_MOD + CONTAINS + ATTRIBUTES(DEVICE) FUNCTION CHNKMIN_CUF_HOIST_NEW (U10, ALPHA, ALPHAMIN, CHNKMIN_U) + + ! ---------------------------------------------------------------------- + + !**** *CHNKMIN* - FUNCTION TO COMPUTE THE MINMUM CHARNOCK + + !* PURPOSE. + ! ------- + + + !** INTERFACE. + ! ---------- + + ! *FUNCTION* *CHNKMIN (U10)* + + ! METHOD. + ! ------- + + ! CHNKMIN = ALPHAMIN + (ALPHA-ALPHAMIN)*0.5_JWRB*(1.0_JWRB-TANH(U10-A)) + + ! EXTERNALS. + ! ---------- + + ! NONE. + + ! REFERENCE. + ! ---------- + + ! NONE. + + ! ---------------------------------------------------------------------- + + USE cudafor + USE PARKIND_WAVE, ONLY: JWIM, JWRU, JWRB + + ! ---------------------------------------------------------------------- + + IMPLICIT NONE + + REAL(KIND=JWRB) :: CHNKMIN_CUF_HOIST_NEW + REAL(KIND=JWRB), INTENT(IN) :: U10 + REAL(KIND=JWRB), INTENT(IN) :: ALPHA + REAL(KIND=JWRB), INTENT(IN) :: ALPHAMIN + REAL(KIND=JWRB), INTENT(IN) :: CHNKMIN_U +!$acc routine seq + + ! ---------------------------------------------------------------------- + + + CHNKMIN_CUF_HOIST_NEW = ALPHAMIN + (ALPHA - ALPHAMIN)*0.5_JWRB*(1.0_JWRB - TANH(U10 - CHNKMIN_U)) + + + END FUNCTION CHNKMIN_CUF_HOIST_NEW +END MODULE CHNKMIN_CUF_HOIST_NEW_MOD diff --git a/src/phys-scc-cuf-hoist/cimsstrn.cuf_hoist_new.F90 b/src/phys-scc-cuf-hoist/cimsstrn.cuf_hoist_new.F90 new file mode 100644 index 00000000..3010f0e8 --- /dev/null +++ b/src/phys-scc-cuf-hoist/cimsstrn.cuf_hoist_new.F90 @@ -0,0 +1,130 @@ +! (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. +! +MODULE CIMSSTRN_CUF_HOIST_NEW_MOD + CONTAINS + ATTRIBUTES(DEVICE) SUBROUTINE CIMSSTRN_CUF_HOIST_NEW (KIJS, KIJL, FL1, WAVNUM, DEPTH, CITHICK, STRN, DELTH, DFIM, FLMIN, G, & + & NANG, NFRE, ROWATER, ICHNK, NCHNK, IJ) + + ! ---------------------------------------------------------------------- + + !**** *CIMSSTRN* - COMPUTATION OF THE MEAN SQUARE WAVE STRAIN IN SEA ICE. + + ! J. BIDLOT ECMWF JANUARY 2013. + + !* PURPOSE. + ! -------- + + ! COMPUTES MEAN SQUARE WAVE STRAIN AT EACH GRID POINT. + + !** INTERFACE. + ! ---------- + + ! *CALL* *CIMSSTRN (KIJS, KIJL, FL1, WAVNUM, DEPTH, CITHICK, STRN)* + ! *KIJS* - INDEX OF FIRST GRIDPOINT + ! *KIJL* - INDEX OF LAST GRIDPOINT + ! *FL1* - SPECTRUM. + ! *WAVNUM* - OPEN WATER WAVE NUMBER + ! *DEPTH* - WATER DEPTH + ! *CITHICK* - SEA ICE THICKNESS + ! *STRN* - MEAN SQUARE WAVE STRAIN IN ICE (OUTPUT). + + ! METHOD. + ! ------- + + ! !!! IT ASSUMES SO DEFAULT SETTING FOR THE MECHANICAL PROPERTIES OF + ! THE SEA ICE (SEE AKI_ICE) !!!!!!! + + ! NONE. + + ! EXTERNALS. + ! ---------- + + ! NONE. + + ! REFERENCE. + ! ---------- + + ! NONE. + + ! ---------------------------------------------------------------------- + + USE AKI_ICE_CUF_HOIST_NEW_MOD, ONLY: AKI_ICE_CUF_HOIST_NEW + USE cudafor + USE PARKIND_WAVE, ONLY: JWIM, JWRU, JWRB + + USE YOWFRED, ONLY: FR + USE YOWPCONS, ONLY: ZPI + + + ! ---------------------------------------------------------------------- + + IMPLICIT NONE + INTEGER(KIND=JWIM), PARAMETER :: NANG_loki_param = 24 + INTEGER(KIND=JWIM), PARAMETER :: NFRE_loki_param = 36 + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJS + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJL + REAL(KIND=JWRB), INTENT(IN) :: FL1(KIJL, NANG_loki_param, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: WAVNUM(KIJL, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: DEPTH(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: CITHICK(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(OUT) :: STRN(KIJL, NCHNK) + + + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: IJ + INTEGER(KIND=JWIM) :: M + INTEGER(KIND=JWIM) :: K + REAL(KIND=JWRB) :: F1LIM + REAL(KIND=JWRB) :: XKI + REAL(KIND=JWRB) :: E + REAL(KIND=JWRB) :: SUME + REAL(KIND=JWRB), VALUE, INTENT(IN) :: DELTH + REAL(KIND=JWRB), INTENT(IN), DEVICE :: DFIM(NFRE_loki_param) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: FLMIN + REAL(KIND=JWRB), VALUE, INTENT(IN) :: G + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NANG + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NFRE + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ROWATER + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: ICHNK + INTEGER, VALUE, INTENT(IN) :: NCHNK + + ! ---------------------------------------------------------------------- + + + !* 1. INITIALISE + ! ---------- + + F1LIM = FLMIN / DELTH + + + STRN(IJ, ICHNK) = 0.0_JWRB + + ! ---------------------------------------------------------------------- + + !* 2. INTEGRATE OVER FREQUENCIES AND DIRECTIONS. + ! ------------------------------------------ + + DO M=1,NFRE + XKI = AKI_ICE_CUF_HOIST_NEW(G, WAVNUM(IJ, M, ICHNK), DEPTH(IJ, ICHNK), ROWATER, CITHICK(IJ, ICHNK)) + E = 0.5_JWRB*CITHICK(IJ, ICHNK)*XKI**3 / WAVNUM(IJ, M, ICHNK) + + SUME = 0.0_JWRB + DO K=1,NANG + SUME = SUME + FL1(IJ, K, M, ICHNK) + END DO + + IF (SUME > F1LIM) THEN + STRN(IJ, ICHNK) = STRN(IJ, ICHNK) + E**2*SUME*DFIM(M) + END IF + + END DO + + + + END SUBROUTINE CIMSSTRN_CUF_HOIST_NEW +END MODULE CIMSSTRN_CUF_HOIST_NEW_MOD diff --git a/src/phys-scc-cuf-hoist/ciwabr.cuf_hoist_new.F90 b/src/phys-scc-cuf-hoist/ciwabr.cuf_hoist_new.F90 new file mode 100644 index 00000000..d698fa6f --- /dev/null +++ b/src/phys-scc-cuf-hoist/ciwabr.cuf_hoist_new.F90 @@ -0,0 +1,118 @@ +! (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. +! +MODULE CIWABR_CUF_HOIST_NEW_MOD + CONTAINS + ATTRIBUTES(DEVICE) SUBROUTINE CIWABR_CUF_HOIST_NEW (KIJS, KIJL, CICOVER, FL1, WAVNUM, CGROUP, CIWAB, CDICWA, DFIM, EPSMIN, & + & IDELT, LICERUN, LMASKICE, NANG, NFRE, ICHNK, NCHNK, IJ) + + ! ---------------------------------------------------------------------- + + !**** *CIWABR* - COMPUTE SEA ICE WAVE ATTENUATION FACTORS DUE TO ICE FLOES + ! BOTTOM FRICTION. + + !* PURPOSE. + ! -------- + + ! CIWABR COMPUTES SEA ICE WAVE ATTENUATION FACTORS DUE TO ICE FLOES + ! BOTTOM FRICTION. + + !** INTERFACE. + ! ---------- + + ! *CALL* *CIWABR (KIJS,KIJL,CICOVER,FL1,CIWAB) + + ! *KIJS* - INDEX OF FIRST POINT. + ! *KIJL* - INDEX OF LAST POINT. + ! *CICOVER* -SEA ICE COVER. + ! *FL1* -ENERGY SPECTRUM. + ! *CIWAB* -SEA ICE WAVE ATTENUATION FACTOR DUE TO ICE FLOE BOTTOM FRICTION + + ! METHOD. + ! ------- + + ! EXTERNALS. + ! ---------- + + ! REFERENCES. + ! ----------- + + ! KOHOUT A., M. MEYLAN, D PLEW, 2011: ANNALS OF GLACIOLOGY, 2011. + + + ! ---------------------------------------------------------------------- + + USE cudafor + USE PARKIND_WAVE, ONLY: JWIM, JWRU, JWRB + + USE YOWFRED, ONLY: FR, DELTH + USE YOWPCONS, ONLY: ZPI4GM2, ZPI, G + + + ! ---------------------------------------------------------------------- + IMPLICIT NONE + + INTEGER(KIND=JWIM), PARAMETER :: NANG_loki_param = 24 + INTEGER(KIND=JWIM), PARAMETER :: NFRE_loki_param = 36 + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJS + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJL + REAL(KIND=JWRB), INTENT(IN) :: CICOVER(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: FL1(KIJL, NANG_loki_param, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: WAVNUM(KIJL, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: CGROUP(KIJL, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(OUT) :: CIWAB(KIJL, NANG_loki_param, NFRE_loki_param) + + + INTEGER(KIND=JWIM) :: K + INTEGER(KIND=JWIM) :: M + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: IJ + REAL(KIND=JWRB) :: EWH + REAL(KIND=JWRB) :: X + REAL(KIND=JWRB) :: ALP + REAL(KIND=JWRB) :: XK2 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: CDICWA + REAL(KIND=JWRB), INTENT(IN), DEVICE :: DFIM(NFRE_loki_param) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: EPSMIN + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: IDELT + LOGICAL, VALUE, INTENT(IN) :: LICERUN + LOGICAL, VALUE, INTENT(IN) :: LMASKICE + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NANG + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NFRE + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: ICHNK + INTEGER, VALUE, INTENT(IN) :: NCHNK + + ! ---------------------------------------------------------------------- + + + + IF (.not.LICERUN .or. LMASKICE) THEN + + DO M=1,NFRE + DO K=1,NANG + CIWAB(IJ, K, M) = 1.0_JWRB + END DO + END DO + + ELSE + + DO M=1,NFRE + DO K=1,NANG + EWH = 4.0_JWRB*SQRT(MAX(EPSMIN, FL1(IJ, K, M, ICHNK)*DFIM(M))) + XK2 = WAVNUM(IJ, M, ICHNK)**2 + ALP = CDICWA*XK2*EWH + X = ALP*CGROUP(IJ, M, ICHNK)*IDELT + CIWAB(IJ, K, M) = 1.0_JWRB - CICOVER(IJ, ICHNK)*(1.0_JWRB - EXP(-MIN(X, 50.0_JWRB))) + END DO + END DO + + END IF + + + + END SUBROUTINE CIWABR_CUF_HOIST_NEW +END MODULE CIWABR_CUF_HOIST_NEW_MOD diff --git a/src/phys-scc-cuf-hoist/femeanws.cuf_hoist_new.F90 b/src/phys-scc-cuf-hoist/femeanws.cuf_hoist_new.F90 new file mode 100644 index 00000000..6ffaae29 --- /dev/null +++ b/src/phys-scc-cuf-hoist/femeanws.cuf_hoist_new.F90 @@ -0,0 +1,134 @@ +! (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. +! +MODULE FEMEANWS_CUF_HOIST_NEW_MOD + CONTAINS + ATTRIBUTES(DEVICE) SUBROUTINE FEMEANWS_CUF_HOIST_NEW (KIJS, KIJL, FL1, XLLWS, FM, EM, DELTH, DFIM, DFIMOFR, EPSMIN, FR, & + & FRTAIL, NANG, NFRE, WETAIL, ICHNK, NCHNK, IJ) + + ! ---------------------------------------------------------------------- + + !**** *FEMEANWS* - COMPUTATION OF MEAN ENERGY, MEAN FREQUENCY + ! FOR WINDSEA PART OF THE SPECTRUM AS DETERMINED + ! BY XLLWS + + !* PURPOSE. + ! -------- + + ! COMPUTE MEAN FREQUENCY AT EACH GRID POINT FOR PART OF THE + ! SPECTRUM WHERE XLLWS IS NON ZERO. + + !** INTERFACE. + ! ---------- + + ! *CALL* *FEMEANWS (KIJS, KIJL, FL1, XLLWS, EM, FM)* + ! *KIJS* - INDEX OF FIRST GRIDPOINT + ! *KIJL* - INDEX OF LAST GRIDPOINT + ! *FL1* - SPECTRUM. + ! *XLLWS* - TOTAL WINDSEA MASK FROM INPUT SOURCE TERM + ! *EM* - MEAN WAVE ENERGY (OUTPUT) + ! *FM* - MEAN WAVE FREQUENCY (OUTPUT) + + ! METHOD. + ! ------- + + ! NONE. + + ! EXTERNALS. + ! ---------- + + ! NONE. + + ! REFERENCE. + ! ---------- + + ! NONE. + + ! ---------------------------------------------------------------------- + + USE cudafor + USE PARKIND_WAVE, ONLY: JWIM, JWRU, JWRB + + + + ! ---------------------------------------------------------------------- + + IMPLICIT NONE + + INTEGER(KIND=JWIM), PARAMETER :: NANG_loki_param = 24 + INTEGER(KIND=JWIM), PARAMETER :: NFRE_loki_param = 36 + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJS + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJL + REAL(KIND=JWRB), INTENT(IN) :: FL1(KIJL, NANG_loki_param, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: XLLWS(KIJL, NANG_loki_param, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(OUT) :: FM(KIJL) + REAL(KIND=JWRB), OPTIONAL, INTENT(OUT) :: EM(KIJL) + + + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: IJ + INTEGER(KIND=JWIM) :: M + INTEGER(KIND=JWIM) :: K + + REAL(KIND=JWRB) :: DELT25 + REAL(KIND=JWRB) :: DELT2 + REAL(KIND=JWRB) :: TEMP2 + REAL(KIND=JWRB) :: EM_LOC + REAL(KIND=JWRB), VALUE, INTENT(IN) :: DELTH + REAL(KIND=JWRB), INTENT(IN), DEVICE :: DFIM(NFRE_loki_param) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: DFIMOFR(NFRE_loki_param) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: EPSMIN + REAL(KIND=JWRB), INTENT(IN), DEVICE :: FR(NFRE_loki_param) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: FRTAIL + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NANG + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NFRE + REAL(KIND=JWRB), VALUE, INTENT(IN) :: WETAIL + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: ICHNK + INTEGER, VALUE, INTENT(IN) :: NCHNK + + ! ---------------------------------------------------------------------- + + + !* 1. INITIALISE MEAN FREQUENCY ARRAY AND TAIL FACTOR. + ! ------------------------------------------------ + + + EM_LOC = EPSMIN + FM(IJ) = EPSMIN + + DELT25 = WETAIL*FR(NFRE)*DELTH + DELT2 = FRTAIL*DELTH + + + !* 2. INTEGRATE OVER FREQUENCIES AND DIRECTIONS. + ! ------------------------------------------ + + DO M=1,NFRE + TEMP2 = 0.0_JWRB + DO K=1,NANG + TEMP2 = TEMP2 + XLLWS(IJ, K, M, ICHNK)*FL1(IJ, K, M, ICHNK) + END DO + EM_LOC = EM_LOC + DFIM(M)*TEMP2 + FM(IJ) = FM(IJ) + DFIMOFR(M)*TEMP2 + END DO + + !* 3. ADD TAIL CORRECTION TO MEAN FREQUENCY AND + !* NORMALIZE WITH TOTAL ENERGY. + ! ------------------------------------------ + + EM_LOC = EM_LOC + DELT25*TEMP2 + FM(IJ) = FM(IJ) + DELT2*TEMP2 + FM(IJ) = EM_LOC / FM(IJ) + + IF (PRESENT(EM)) THEN + EM(IJ) = EM_LOC + END IF + + + + END SUBROUTINE FEMEANWS_CUF_HOIST_NEW +END MODULE FEMEANWS_CUF_HOIST_NEW_MOD diff --git a/src/phys-scc-cuf-hoist/fkmean.cuf_hoist_new.F90 b/src/phys-scc-cuf-hoist/fkmean.cuf_hoist_new.F90 new file mode 100644 index 00000000..e752d97a --- /dev/null +++ b/src/phys-scc-cuf-hoist/fkmean.cuf_hoist_new.F90 @@ -0,0 +1,170 @@ +! (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. +! +MODULE FKMEAN_CUF_HOIST_NEW_MOD + CONTAINS + ATTRIBUTES(DEVICE) SUBROUTINE FKMEAN_CUF_HOIST_NEW (KIJS, KIJL, FL1, WAVNUM, EM, FM1, F1, AK, XK, DELTH, DFIM, DFIMFR, & + & DFIMOFR, EPSMIN, FR, FRTAIL, G, NANG, NFRE, WETAIL, WP1TAIL, ZPI, ICHNK, NCHNK, IJ) + + ! ---------------------------------------------------------------------- + + !**** *FKMEAN* - COMPUTATION OF MEAN FREQUENCIES AT EACH GRID POINT + ! AND MEAN WAVE NUMBER (based in sqrt(k)*F moment) . + ! COMPUTATION OF THE MEAN WAVE ENERGY WAS ALSO + ! ADDED SUCH THAT A CALL TO FKMEAN DOES NOT NEED + + + !* PURPOSE. + ! -------- + + ! COMPUTE MEAN FREQUENCIES AND WAVE NUMBER AT EACH GRID POINT. + + !** INTERFACE. + ! ---------- + + ! *CALL* *FKMEAN (KIJS, KIJL, FL1, WAVNUM, EM, FM1, F1, AK, XK)* + ! *KIJS* - LOCAL INDEX OF FIRST GRIDPOINT + ! *KIJL* - LOCAL INDEX OF LAST GRIDPOINT + ! *FL1* - SPECTRUM. + ! *WAVNUM* - WAVE NUMBER. + ! *EM* - MEAN WAVE ENERGY + ! *FM1* - MEAN WAVE FREQUENCY BASED ON (1/f)*FL1 INTEGRATION + ! *F1* - MEAN WAVE FREQUENCY BASED ON f*FL1 INTEGRATION + ! *AK* - MEAN WAVE NUMBER BASED ON sqrt(1/k)*FL1 INTGRATION + ! ONLY FOR SHALLOW WATER RUNS. + !!! AK IS STILL NEEDED IN SNONLIN !!!! + !!! IF THE OLD FORMULATION IS USED. + ! *XK* - MEAN WAVE NUMBER BASED ON sqrt(k)*FL1 INTEGRATION + ! ONLY FOR SHALLOW WATER RUNS. + + ! METHOD. + ! ------- + + ! NONE. + + ! EXTERNALS. + ! ---------- + + ! NONE. + + ! REFERENCE. + ! ---------- + + ! NONE. + + ! ---------------------------------------------------------------------- + + USE cudafor + USE PARKIND_WAVE, ONLY: JWIM, JWRU, JWRB + + + ! ---------------------------------------------------------------------- + + IMPLICIT NONE + + INTEGER(KIND=JWIM), PARAMETER :: NANG_loki_param = 24 + INTEGER(KIND=JWIM), PARAMETER :: NFRE_loki_param = 36 + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJS + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJL + + REAL(KIND=JWRB), INTENT(IN) :: FL1(KIJL, NANG_loki_param, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: WAVNUM(KIJL, NFRE_loki_param, NCHNK) + + REAL(KIND=JWRB), INTENT(OUT) :: EM(KIJL) + REAL(KIND=JWRB), INTENT(OUT) :: FM1(KIJL) + REAL(KIND=JWRB), INTENT(OUT) :: F1(KIJL) + REAL(KIND=JWRB), INTENT(OUT) :: AK(KIJL) + REAL(KIND=JWRB), INTENT(OUT) :: XK(KIJL) + + + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: IJ + INTEGER(KIND=JWIM) :: M + INTEGER(KIND=JWIM) :: K + REAL(KIND=JWRB) :: DELT25 + REAL(KIND=JWRB) :: COEFM1 + REAL(KIND=JWRB) :: COEF1 + REAL(KIND=JWRB) :: COEFA + REAL(KIND=JWRB) :: COEFX + REAL(KIND=JWRB) :: SQRTK + REAL(KIND=JWRB) :: TEMPA + REAL(KIND=JWRB) :: TEMPX + REAL(KIND=JWRB) :: TEMP2 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: DELTH + REAL(KIND=JWRB), INTENT(IN), DEVICE :: DFIM(NFRE_loki_param) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: DFIMFR(NFRE_loki_param) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: DFIMOFR(NFRE_loki_param) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: EPSMIN + REAL(KIND=JWRB), INTENT(IN), DEVICE :: FR(NFRE_loki_param) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: FRTAIL + REAL(KIND=JWRB), VALUE, INTENT(IN) :: G + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NANG + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NFRE + REAL(KIND=JWRB), VALUE, INTENT(IN) :: WETAIL + REAL(KIND=JWRB), VALUE, INTENT(IN) :: WP1TAIL + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ZPI + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: ICHNK + INTEGER, VALUE, INTENT(IN) :: NCHNK + + ! ---------------------------------------------------------------------- + + + + !* 1. INITIALISE MEAN FREQUENCY ARRAY AND TAIL FACTOR. + ! ------------------------------------------------ + + + EM(IJ) = EPSMIN + FM1(IJ) = EPSMIN + F1(IJ) = EPSMIN + AK(IJ) = EPSMIN + XK(IJ) = EPSMIN + + DELT25 = WETAIL*FR(NFRE)*DELTH + COEFM1 = FRTAIL*DELTH + COEF1 = WP1TAIL*DELTH*FR(NFRE)**2 + COEFA = COEFM1*SQRT(G) / ZPI + COEFX = COEF1*(ZPI / SQRT(G)) + + !* 2. INTEGRATE OVER FREQUENCIES AND DIRECTIONS. + ! ------------------------------------------ + + !* 2.2 SHALLOW WATER INTEGRATION. + ! -------------------------- + + DO M=1,NFRE + SQRTK = SQRT(WAVNUM(IJ, M, ICHNK)) + TEMPA = DFIM(M) / SQRTK + TEMPX = SQRTK*DFIM(M) + K = 1 + TEMP2 = FL1(IJ, K, M, ICHNK) + DO K=2,NANG + TEMP2 = TEMP2 + FL1(IJ, K, M, ICHNK) + END DO + EM(IJ) = EM(IJ) + DFIM(M)*TEMP2 + FM1(IJ) = FM1(IJ) + DFIMOFR(M)*TEMP2 + F1(IJ) = F1(IJ) + DFIMFR(M)*TEMP2 + AK(IJ) = AK(IJ) + TEMPA*TEMP2 + XK(IJ) = XK(IJ) + TEMPX*TEMP2 + END DO + + !* ADD TAIL CORRECTION TO MEAN FREQUENCY AND + !* NORMALIZE WITH TOTAL ENERGY. + EM(IJ) = EM(IJ) + DELT25*TEMP2 + FM1(IJ) = FM1(IJ) + COEFM1*TEMP2 + FM1(IJ) = EM(IJ) / FM1(IJ) + F1(IJ) = F1(IJ) + COEF1*TEMP2 + F1(IJ) = F1(IJ) / EM(IJ) + AK(IJ) = AK(IJ) + COEFA*TEMP2 + AK(IJ) = (EM(IJ) / AK(IJ))**2 + XK(IJ) = XK(IJ) + COEFX*TEMP2 + XK(IJ) = (XK(IJ) / EM(IJ))**2 + + + + END SUBROUTINE FKMEAN_CUF_HOIST_NEW +END MODULE FKMEAN_CUF_HOIST_NEW_MOD diff --git a/src/phys-scc-cuf-hoist/frcutindex.cuf_hoist_new.F90 b/src/phys-scc-cuf-hoist/frcutindex.cuf_hoist_new.F90 new file mode 100644 index 00000000..0918ac50 --- /dev/null +++ b/src/phys-scc-cuf-hoist/frcutindex.cuf_hoist_new.F90 @@ -0,0 +1,126 @@ +! (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. +! +MODULE FRCUTINDEX_CUF_HOIST_NEW_MOD + CONTAINS + ATTRIBUTES(DEVICE) SUBROUTINE FRCUTINDEX_CUF_HOIST_NEW (KIJS, KIJL, FM, FMWS, UFRIC, CICOVER, MIJ, RHOWGDFTH, CITHRSH_TAIL, & + & EPSMIN, FLOGSPRDM1, FR, FRIC, G, NFRE, RHOWG_DFIM, TAILFACTOR, TAILFACTOR_PM, ZPIFR, ICHNK, NCHNK, IJ) + + ! ---------------------------------------------------------------------- + + !**** *FRCUTINDEX* - RETURNS THE LAST FREQUENCY INDEX OF + ! PROGNOSTIC PART OF SPECTRUM. + + !** INTERFACE. + ! ---------- + + ! *CALL* *FRCUTINDEX (KIJS, KIJL, FM, FMWS, CICOVER, MIJ, RHOWGDFTH) + ! *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 + ! *RHOWGDFTH - WATER DENSITY * G * DF * DTHETA + ! FOR TRAPEZOIDAL INTEGRATION BETWEEN FR(1) and FR(MIJ) + ! !!!!!!!! RHOWGDFTH=0 FOR FR > FR(MIJ) + + + ! 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 cudafor + USE PARKIND_WAVE, ONLY: JWIM, JWRU, JWRB + + USE YOWFRED, ONLY: DELTH, DFIM, FRATIO + + + ! ---------------------------------------------------------------------- + + IMPLICIT NONE + + INTEGER(KIND=JWIM), PARAMETER :: NFRE_loki_param = 36 + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJS + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJL + INTEGER(KIND=JWIM), INTENT(OUT) :: MIJ(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: FM(KIJL) + REAL(KIND=JWRB), INTENT(IN) :: FMWS(KIJL) + REAL(KIND=JWRB), INTENT(IN) :: UFRIC(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: CICOVER(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(OUT) :: RHOWGDFTH(KIJL, NFRE_loki_param) + + + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: IJ + INTEGER(KIND=JWIM) :: M + + REAL(KIND=JWRB) :: FPMH + REAL(KIND=JWRB) :: FPPM + REAL(KIND=JWRB) :: FM2 + REAL(KIND=JWRB) :: FPM + REAL(KIND=JWRB) :: FPM4 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: CITHRSH_TAIL + REAL(KIND=JWRB), VALUE, INTENT(IN) :: EPSMIN + REAL(KIND=JWRB), VALUE, INTENT(IN) :: FLOGSPRDM1 + REAL(KIND=JWRB), INTENT(IN), DEVICE :: FR(NFRE_loki_param) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: FRIC + REAL(KIND=JWRB), VALUE, INTENT(IN) :: G + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NFRE + REAL(KIND=JWRB), INTENT(IN), DEVICE :: RHOWG_DFIM(NFRE_loki_param) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: TAILFACTOR + REAL(KIND=JWRB), VALUE, INTENT(IN) :: TAILFACTOR_PM + REAL(KIND=JWRB), INTENT(IN), DEVICE :: ZPIFR(NFRE_loki_param) + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: ICHNK + INTEGER, VALUE, INTENT(IN) :: NCHNK + + ! ---------------------------------------------------------------------- + + + !* 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)) + + + IF (CICOVER(IJ, ICHNK) <= CITHRSH_TAIL) THEN + FM2 = MAX(FMWS(IJ), FM(IJ))*FPMH + FPM = FPPM / MAX(UFRIC(IJ, ICHNK), EPSMIN) + FPM4 = MAX(FM2, FPM) + MIJ(IJ, ICHNK) = NINT(LOG10(FPM4)*FLOGSPRDM1) + 1 + MIJ(IJ, ICHNK) = MIN(MAX(1, MIJ(IJ, ICHNK)), NFRE) + ELSE + MIJ(IJ, ICHNK) = NFRE + END IF + + ! SET RHOWGDFTH + DO M=1,MIJ(IJ, ICHNK) + RHOWGDFTH(IJ, M) = RHOWG_DFIM(M) + END DO + IF (MIJ(IJ, ICHNK) /= NFRE) RHOWGDFTH(IJ, MIJ(IJ, ICHNK)) = 0.5_JWRB*RHOWGDFTH(IJ, MIJ(IJ, ICHNK)) + DO M=MIJ(IJ, ICHNK) + 1,NFRE + RHOWGDFTH(IJ, M) = 0.0_JWRB + END DO + + + + END SUBROUTINE FRCUTINDEX_CUF_HOIST_NEW +END MODULE FRCUTINDEX_CUF_HOIST_NEW_MOD diff --git a/src/phys-scc-cuf-hoist/halphap.cuf_hoist_new.F90 b/src/phys-scc-cuf-hoist/halphap.cuf_hoist_new.F90 new file mode 100644 index 00000000..64110620 --- /dev/null +++ b/src/phys-scc-cuf-hoist/halphap.cuf_hoist_new.F90 @@ -0,0 +1,154 @@ +! (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. +! +MODULE HALPHAP_CUF_HOIST_NEW_MOD + CONTAINS + ATTRIBUTES(DEVICE) SUBROUTINE HALPHAP_CUF_HOIST_NEW (KIJS, KIJL, WAVNUM, COSWDIF, FL1, HALP, ALPHAPMAX, DELTH, DFIM, DFIMOFR, & + & EPSMIN, FR, FR5, FRTAIL, NANG, NFRE, WETAIL, ZPI4GM2, ICHNK, NCHNK, IJ) + + ! ---------------------------------------------------------------------- + + !**** *HALPHAP* - COMPUTATION OF 1/2 PHILLIPS PARAMETER + + + !** INTERFACE. + ! ---------- + + ! *CALL* *HALPHAP(KIJS, KIJL, WAVNUM, UDIR, FL1, HALP) + ! *KIJS* - INDEX OF FIRST GRIDPOINT + ! *KIJL* - INDEX OF LAST GRIDPOINT + ! *WAVNUM* - WAVE NUMBER + ! *COSWDIF*- COSINE ( WIND SPEED DIRECTION - WAVE DIRECTIONS) + ! *FL1* - SPECTRA + ! *HALP* - 1/2 PHILLIPS PARAMETER + + ! METHOD. + ! ------- + + ! ---------------------------------------------------------------------- + + USE cudafor + USE PARKIND_WAVE, ONLY: JWIM, JWRU, JWRB + + USE YOWFRED, ONLY: TH + USE YOWPARAM, ONLY: NANG_PARAM + USE YOWPCONS, ONLY: ZPI, G + + + ! ---------------------------------------------------------------------- + + IMPLICIT NONE + + INTEGER(KIND=JWIM), PARAMETER :: NFRE_loki_param = 36 + INTEGER(KIND=JWIM), PARAMETER :: NANG_loki_param = 24 + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJS + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJL + REAL(KIND=JWRB), INTENT(IN) :: WAVNUM(KIJL, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: COSWDIF(KIJL, NANG_loki_param) + REAL(KIND=JWRB), INTENT(IN) :: FL1(KIJL, NANG_loki_param, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(OUT) :: HALP(KIJL) + + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: IJ + INTEGER(KIND=JWIM) :: K + INTEGER(KIND=JWIM) :: M + + REAL(KIND=JWRB) :: ZLNFRNFRE + REAL(KIND=JWRB) :: DELT25 + REAL(KIND=JWRB) :: DELT2 + REAL(KIND=JWRB) :: DEL2 + REAL(KIND=JWRB) :: TEMP1 + REAL(KIND=JWRB) :: TEMP2 + REAL(KIND=JWRB) :: ALPHAP + REAL(KIND=JWRB) :: XMSS + REAL(KIND=JWRB) :: EM + REAL(KIND=JWRB) :: FM + REAL(KIND=JWRB) :: F1D + REAL(KIND=JWRB) :: FLWD(NANG_PARAM) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ALPHAPMAX + REAL(KIND=JWRB), VALUE, INTENT(IN) :: DELTH + REAL(KIND=JWRB), INTENT(IN), DEVICE :: DFIM(NFRE_loki_param) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: DFIMOFR(NFRE_loki_param) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: EPSMIN + REAL(KIND=JWRB), INTENT(IN), DEVICE :: FR(NFRE_loki_param) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: FR5(NFRE_loki_param) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: FRTAIL + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NANG + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NFRE + REAL(KIND=JWRB), VALUE, INTENT(IN) :: WETAIL + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ZPI4GM2 + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: ICHNK + INTEGER, VALUE, INTENT(IN) :: NCHNK + + ! ---------------------------------------------------------------------- + + + ZLNFRNFRE = LOG(FR(NFRE)) + + DELT25 = WETAIL*FR(NFRE)*DELTH + DELT2 = FRTAIL*DELTH + + ! Find spectrum in wind direction + + DO M=1,NFRE + DO K=1,NANG + FLWD(K) = FL1(IJ, K, M, ICHNK)*0.5_JWRB + 0.5_JWRB*SIGN(1.0_JWRB, COSWDIF(IJ, K)) + END DO + + XMSS = 0._JWRB + TEMP1 = DFIM(M)*WAVNUM(IJ, M, ICHNK)**2 + TEMP2 = 0.0_JWRB + DO K=1,NANG + TEMP2 = TEMP2 + FLWD(K) + END DO + XMSS = XMSS + TEMP1*TEMP2 + + K = 1 + EM = 0._JWRB + FM = 0._JWRB + TEMP2 = MAX(FLWD(K), EPSMIN) + DO K=2,NANG + TEMP2 = TEMP2 + MAX(FLWD(K), EPSMIN) + END DO + EM = EM + TEMP2*DFIM(M) + FM = FM + DFIMOFR(M)*TEMP2 + END DO + + DO K=1,NANG + FLWD(K) = FL1(IJ, K, NFRE, ICHNK)*0.5_JWRB + 0.5_JWRB*SIGN(1.0_JWRB, COSWDIF(IJ, K)) + END DO + + EM = EM + DELT25*TEMP2 + FM = FM + DELT2*TEMP2 + FM = EM / FM + FM = MAX(FM, FR(1)) + + IF (EM > 0.0_JWRB .and. FM < FR(-2 + NFRE)) THEN + ALPHAP = XMSS / (ZLNFRNFRE - LOG(FM)) + IF (ALPHAP > ALPHAPMAX) THEN + ! some odd cases, revert to tail value + F1D = 0.0_JWRB + DO K=1,NANG + F1D = F1D + FLWD(K)*DELTH + END DO + ALPHAP = ZPI4GM2*FR5(NFRE)*F1D + END IF + ELSE + F1D = 0.0_JWRB + DO K=1,NANG + F1D = F1D + FLWD(K)*DELTH + END DO + ALPHAP = ZPI4GM2*FR5(NFRE)*F1D + END IF + + ! 1/2 ALPHAP: + HALP(IJ) = 0.5_JWRB*MIN(ALPHAP, ALPHAPMAX) + + + + END SUBROUTINE HALPHAP_CUF_HOIST_NEW +END MODULE HALPHAP_CUF_HOIST_NEW_MOD diff --git a/src/phys-scc-cuf-hoist/imphftail.cuf_hoist_new.F90 b/src/phys-scc-cuf-hoist/imphftail.cuf_hoist_new.F90 new file mode 100644 index 00000000..2cdb0c7e --- /dev/null +++ b/src/phys-scc-cuf-hoist/imphftail.cuf_hoist_new.F90 @@ -0,0 +1,103 @@ +! (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. +! +MODULE IMPHFTAIL_CUF_HOIST_NEW_MOD + CONTAINS + ATTRIBUTES(DEVICE) SUBROUTINE IMPHFTAIL_CUF_HOIST_NEW (KIJS, KIJL, MIJ, FLM, WAVNUM, XK2CG, FL1, NANG, NFRE, ICHNK, NCHNK, IJ) + ! ---------------------------------------------------------------------- + + !**** *IMPHFTAIL* - IMPOSE A HIGH FREQUENCY TAIL TO THE SPECTRUM + + + !* PURPOSE. + ! -------- + + ! IMPOSE A HIGH FREQUENCY TAIL TO THE SPECTRUM ABOVE FREQUENCY INDEX MIJ + + + !** INTERFACE. + ! ---------- + + ! *CALL* *IMPHFTAIL (KIJS, KIJL, MIJ, FLM, WAVNUM, XK2CG, FL1) + ! *KIJS* - INDEX OF FIRST GRIDPOINT + ! *KIJL* - INDEX OF LAST GRIDPOINT + ! *MIJ* - LAST FREQUENCY INDEX OF THE PROGNOSTIC RANGE. + ! *FLM* - SPECTAL DENSITY MINIMUM VALUE + ! *WAVNUM* - WAVENUMBER + ! *XK2CG* - (WAVNUM)**2 * GROUP SPEED + ! *FL1* - SPECTRUM (INPUT AND OUTPUT). + + ! METHOD. + ! ------- + + ! EXTERNALS. + ! --------- + + ! REFERENCE. + ! ---------- + + ! ---------------------------------------------------------------------- + USE cudafor + USE PARKIND_WAVE, ONLY: JWIM, JWRU, JWRB + + + ! ---------------------------------------------------------------------- + + IMPLICIT NONE + + INTEGER(KIND=JWIM), PARAMETER :: NANG_loki_param = 24 + INTEGER(KIND=JWIM), PARAMETER :: NFRE_loki_param = 36 + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJS + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJL + INTEGER(KIND=JWIM), INTENT(IN) :: MIJ(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: FLM(KIJL, NANG_loki_param) + REAL(KIND=JWRB), INTENT(IN) :: WAVNUM(KIJL, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: XK2CG(KIJL, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: FL1(KIJL, NANG_loki_param, NFRE_loki_param, NCHNK) + + + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: IJ + INTEGER(KIND=JWIM) :: K + INTEGER(KIND=JWIM) :: M + + REAL(KIND=JWRB) :: AKM1 + REAL(KIND=JWRB) :: TFAC + REAL(KIND=JWRB) :: TEMP1 + REAL(KIND=JWRB) :: TEMP2 + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NANG + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NFRE + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: ICHNK + INTEGER, VALUE, INTENT(IN) :: NCHNK + + ! ---------------------------------------------------------------------- + + + !* DIAGNOSTIC TAIL. + ! ---------------- + + + TEMP1 = 1.0_JWRB / XK2CG(IJ, MIJ(IJ, ICHNK), ICHNK) / WAVNUM(IJ, MIJ(IJ, ICHNK), ICHNK) + + DO M=MIJ(IJ, ICHNK) + 1,NFRE + TEMP2 = 1.0_JWRB / XK2CG(IJ, M, ICHNK) / WAVNUM(IJ, M, ICHNK) + TEMP2 = TEMP2 / TEMP1 + + !* MERGE TAIL INTO SPECTRA. + ! ------------------------ + DO K=1,NANG + TFAC = FL1(IJ, K, MIJ(IJ, ICHNK), ICHNK) + FL1(IJ, K, M, ICHNK) = MAX(TEMP2*TFAC, FLM(IJ, K)) + END DO + END DO + + + ! ---------------------------------------------------------------------- + + + END SUBROUTINE IMPHFTAIL_CUF_HOIST_NEW +END MODULE IMPHFTAIL_CUF_HOIST_NEW_MOD diff --git a/src/phys-scc-cuf-hoist/implsch.cuf_hoist_new.F90 b/src/phys-scc-cuf-hoist/implsch.cuf_hoist_new.F90 new file mode 100644 index 00000000..d0424c80 --- /dev/null +++ b/src/phys-scc-cuf-hoist/implsch.cuf_hoist_new.F90 @@ -0,0 +1,724 @@ +! (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. +! +MODULE IMPLSCH_CUF_HOIST_NEW_MOD + CONTAINS + ATTRIBUTES(GLOBAL) SUBROUTINE IMPLSCH_CUF_HOIST_NEW (KIJS, KIJL, FL1, WAVNUM, CGROUP, CIWA, CINV, XK2CG, STOKFAC, EMAXDPT, & + & INDEP, DEPTH, IOBND, IODP, AIRD, WDWAVE, CICOVER, WSWAVE, WSTAR, UFRIC, TAUW, TAUWDIR, Z0M, Z0B, CHRNCK, CITHICK, & + & NEMOUSTOKES, NEMOVSTOKES, NEMOSTRN, NPHIEPS, NTAUOC, NSWH, NMWP, NEMOTAUX, NEMOTAUY, NEMOWSWAVE, NEMOPHIF, WSEMEAN, WSFMEAN, & + & USTOKES, VSTOKES, STRNMS, TAUXD, TAUYD, TAUOCXD, TAUOCYD, TAUOC, PHIOCD, PHIEPS, PHIAW, MIJ, XLLWS, ABMAX, ABMIN, ACD, & + & ACDLIN, AF11, AFCRV, ALPHA, ALPHAMAX, ALPHAMIN, ALPHAPMAX, ANG_GC_A, ANG_GC_B, ANG_GC_C, BATHYMAX, BCD, BCDLIN, & + & BETAMAXOXKAPPA2, BFCRV, BMAXOKAP, C2OSQRTVG_GC, CDICWA, CDIS, CDISVIS, CDMAX, CHNKMIN_U, CIBLOCK, CITHRSH, CITHRSH_TAIL, & + & CM_GC, COFRM4, COSTH, CUMULW, DAL1, DAL2, DELKCC_GC_NS, DELKCC_OMXKM3_GC, DELTA_SDIS, DELTH, DFIM, DFIMFR, DFIMFR2, DFIMOFR, & + & DFIM_SIM, DKMAX, DTHRN_A, DTHRN_U, EGRCRV, EPS1, EPSMIN, EPSU10, EPSUS, FKLAM, FKLAM1, FKLAP, FKLAP1, FLMAX, FLMIN, & + & FLOGSPRDM1, FR, FR5, FRATIO, FRIC, FRTAIL, G, GAMNCONST, GM1, IAB, ICODE, ICODE_CPL, IDAMPING, IDELT, IKM, IKM1, IKP, IKP1, & + & INDICESSAT, INLCOEF, IPHYS, IPSAT, ISNONLIN, JTOT_TAUHF, K11W, K1W, K21W, K2W, KFRH, LBIWBK, LCIWABR, LICERUN, LLCAPCHNK, & + & LLGCBZ0, LLNORMAGAM, LLUNSTR, LMASKICE, LWAMRSETCI, LWCOU, LWFLUX, LWFLUXOUT, LWNEMOCOU, LWNEMOCOUSEND, LWNEMOCOUSTK, & + & LWNEMOCOUSTRN, LWNEMOTAUOC, LWVFLX_SNL, MFRSTLW, MICHE, MLSTHG, NANG, NDEPTH, NDIKCUMUL, NFRE, NFRE_ODD, NFRE_RED, NSDSNTH, & + & NWAV_GC, OM3GMKM_GC, OMEGA_GC, OMXKM3_GC, PHIEPSMAX, PHIEPSMIN, RHOWG_DFIM, RN1_RN, RNLCOEF, RNU, RNUM, ROWATER, ROWATERM1, & + & SATWEIGHTS, SDSBR, SINTH, SQRTGOSURFT, SSDSC2, SSDSC3, SSDSC4, SSDSC5, SSDSC6, SWELLF, SWELLF2, SWELLF3, SWELLF4, SWELLF5, & + & SWELLF6, SWELLF7, SWELLF7M1, SWELLFT, TAILFACTOR, TAILFACTOR_PM, TAUOCMAX, TAUOCMIN, TAUWSHELTER, TH, WETAIL, WP1TAIL, & + & WP2TAIL, WSEMEAN_MIN, WSPMIN, WTAUHF, X0TAUHF, XKAPPA, XKDMIN, XKMSQRTVGOC2_GC, XKM_GC, XK_GC, XLOGKRATIOM1_GC, XNLEV, & + & Z0RAT, Z0TUBMAX, ZALP, ZPI, ZPI4GM1, ZPI4GM2, ZPIFR, ICHNK_start, ICHNK_end, ICHNK_step, NCHNK, RAORW, EMEAN, FMEAN, HALP, & + & EMEANWS, FMEANWS, F1MEAN, AKMEAN, XKMEAN, PHIWA, FLM, COSWDIF, SINWDIF2, RHOWGDFTH, FLD, SL, SPOS, CIREDUC, SSOURCE, & + & SINFLX_RNFAC, SINFLX_TMP_EM, STRESSO_TAUHF, STRESSO_PHIHF, STRESSO_UST, SNONLIN_XNU, SNONLIN_SIG_TH, ENH) + + ! ---------------------------------------------------------------------- + + !**** *IMPLSCH* - IMPLICIT SCHEME FOR TIME INTEGRATION OF SOURCE + !**** FUNCTIONS. + + + !* PURPOSE. + ! -------- + + ! THE IMPLICIT SCHEME ENABLES THE USE OF A TIMESTEP WHICH IS + ! LARGE COMPARED WITH THE CHARACTERISTIC DYNAMIC TIME SCALE. + ! THE SCHEME IS REQUIRED FOR THE HIGH FREQUENCIES WHICH + ! RAPIDLY ADJUST TO A QUASI-EQUILIBRIUM. + + !** INTERFACE. + ! ---------- + + ! *CALL* *IMPLSCH (KIJS, KIJL, FL1, + ! & WVPRPT, + ! & WVENVI, FF_NOW, + ! & INTFLDS, WAM2NEMO, + ! & MIJ, XLLWS) + ! *KIJS* - LOCAL INDEX OF FIRST GRIDPOINT + ! *KIJL* - LOCAL INDEX OF LAST GRIDPOINT + ! *FL1* - FREQUENCY SPECTRUM(INPUT AND OUTPUT). + ! *WVPRPT* - WAVE PROPERTIES FIELDS + ! *WVENVI* - WAVE ENVIRONMENT + ! *FF_NOW* FORCING FIELDS + ! *INTFLDS* INTEGRATED/DERIVED PARAMETERS + ! *WAM2NEMO* WAVE FIELDS PASSED TO NEMO + ! *MIJ* LAST FREQUENCY INDEX OF THE PROGNOSTIC RANGE. + ! *XLLWS* TOTAL WINDSEA MASK FROM INPUT SOURCE TERM + + + ! METHOD. + ! ------- + + ! THE SPECTRUM AT TIME (TN+1) IS COMPUTED AS + ! FN+1=FN+DELT*(SN+SN+1)/2., WHERE SN IS THE TOTAL SOURCE + ! FUNCTION AT TIME TN, SN+1=SN+(DS/DF)*DF - ONLY THE DIAGONAL + ! TERMS OF THE FUNCTIONAL MATRIX DS/DF ARE YOWPUTED, THE + ! NONDIAGONAL TERMS ARE NEGLIGIBLE. + ! THE ROUTINE IS CALLED AFTER PROPAGATION FOR TIME PERIOD + ! BETWEEN TWO PROPAGATION CALLS - ARRAY FL1 CONTAINS THE + ! SPECTRUM AND FL IS USED AS AN INTERMEDIATE STORAGE FOR THE + ! DIAGONAL TERM OF THE FUNCTIONAL MATRIX. + + + ! REFERENCE. + ! ---------- + + ! S. HASSELMANN AND K. HASSELMANN, "A GLOBAL WAVE MODEL", + ! 30/6/85 (UNPUBLISHED NOTE) + + ! ---------------------------------------------------------------------- + + USE WNFLUXES_CUF_HOIST_NEW_MOD, ONLY: WNFLUXES_CUF_HOIST_NEW + USE STOKESTRN_CUF_HOIST_NEW_MOD, ONLY: STOKESTRN_CUF_HOIST_NEW + USE SNONLIN_CUF_HOIST_NEW_MOD, ONLY: SNONLIN_CUF_HOIST_NEW + USE SINFLX_CUF_HOIST_NEW_MOD, ONLY: SINFLX_CUF_HOIST_NEW + USE SETICE_CUF_HOIST_NEW_MOD, ONLY: SETICE_CUF_HOIST_NEW + USE SDIWBK_CUF_HOIST_NEW_MOD, ONLY: SDIWBK_CUF_HOIST_NEW + USE SDISSIP_CUF_HOIST_NEW_MOD, ONLY: SDISSIP_CUF_HOIST_NEW + USE SDEPTHLIM_CUF_HOIST_NEW_MOD, ONLY: SDEPTHLIM_CUF_HOIST_NEW + USE IMPHFTAIL_CUF_HOIST_NEW_MOD, ONLY: IMPHFTAIL_CUF_HOIST_NEW + USE SBOTTOM_CUF_HOIST_NEW_MOD, ONLY: SBOTTOM_CUF_HOIST_NEW + USE FKMEAN_CUF_HOIST_NEW_MOD, ONLY: FKMEAN_CUF_HOIST_NEW + USE FEMEANWS_CUF_HOIST_NEW_MOD, ONLY: FEMEANWS_CUF_HOIST_NEW + USE CIWABR_CUF_HOIST_NEW_MOD, ONLY: CIWABR_CUF_HOIST_NEW + USE cudafor + USE PARKIND_WAVE, ONLY: JWIM, JWRU, JWRO, JWRB + USE YOWDRVTYPE, ONLY: INTGT_PARAM_FIELDS, FORCING_FIELDS, FREQUENCY, ENVIRONMENT, WAVE2OCEAN + + + + IMPLICIT NONE + ! ---------------------------------------------------------------------- + + + INTEGER(KIND=JWIM), PARAMETER :: NANG_loki_param = 24 + INTEGER(KIND=JWIM), PARAMETER :: NFRE_loki_param = 36 + INTEGER(KIND=JWIM), PARAMETER :: NRNL = 25 + INTEGER(KIND=JWIM), PARAMETER :: NINL = 5 + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJS + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJL + REAL(KIND=JWRB), INTENT(INOUT) :: FL1(KIJL, NANG_loki_param, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: WAVNUM(KIJL, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: CGROUP(KIJL, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: CIWA(KIJL, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: CINV(KIJL, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: XK2CG(KIJL, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: STOKFAC(KIJL, NFRE_loki_param, NCHNK) + + REAL(KIND=JWRB), INTENT(IN) :: EMAXDPT(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: DEPTH(KIJL, NCHNK) + INTEGER(KIND=JWIM), INTENT(IN) :: INDEP(KIJL, NCHNK) + INTEGER(KIND=JWIM), INTENT(IN) :: IODP(KIJL, NCHNK) + INTEGER(KIND=JWIM), INTENT(IN) :: IOBND(KIJL, NCHNK) + + REAL(KIND=JWRB), INTENT(IN) :: WDWAVE(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: CICOVER(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: AIRD(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: WSTAR(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: CITHICK(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: UFRIC(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: TAUW(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: TAUWDIR(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: Z0M(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: Z0B(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: CHRNCK(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: WSWAVE(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: WSEMEAN(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: WSFMEAN(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: USTOKES(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: VSTOKES(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: STRNMS(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: TAUXD(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: TAUYD(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: TAUOCXD(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: TAUOCYD(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: TAUOC(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: PHIOCD(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: PHIEPS(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: PHIAW(KIJL, NCHNK) + REAL(KIND=JWRO), INTENT(INOUT) :: NEMOUSTOKES(KIJL, NCHNK) + REAL(KIND=JWRO), INTENT(INOUT) :: NEMOVSTOKES(KIJL, NCHNK) + REAL(KIND=JWRO), INTENT(INOUT) :: NEMOSTRN(KIJL, NCHNK) + REAL(KIND=JWRO), INTENT(INOUT) :: NPHIEPS(KIJL, NCHNK) + REAL(KIND=JWRO), INTENT(INOUT) :: NTAUOC(KIJL, NCHNK) + REAL(KIND=JWRO), INTENT(INOUT) :: NSWH(KIJL, NCHNK) + REAL(KIND=JWRO), INTENT(INOUT) :: NMWP(KIJL, NCHNK) + REAL(KIND=JWRO), INTENT(INOUT) :: NEMOTAUX(KIJL, NCHNK) + REAL(KIND=JWRO), INTENT(INOUT) :: NEMOTAUY(KIJL, NCHNK) + REAL(KIND=JWRO), INTENT(INOUT) :: NEMOWSWAVE(KIJL, NCHNK) + REAL(KIND=JWRO), INTENT(INOUT) :: NEMOPHIF(KIJL, NCHNK) + INTEGER(KIND=JWIM), INTENT(OUT) :: MIJ(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(OUT) :: XLLWS(KIJL, NANG_loki_param, NFRE_loki_param, NCHNK) + +REAL(KIND=JWRB), INTENT(INOUT), DEVICE, DIMENSION(KIJL, MLSTHG, NCHNK) :: ENH + + INTEGER(KIND=JWIM) :: IJ + INTEGER(KIND=JWIM) :: K + INTEGER(KIND=JWIM) :: M + + REAL(KIND=JWRB) :: DELT + REAL(KIND=JWRB) :: DELTM + REAL(KIND=JWRB) :: XIMP + REAL(KIND=JWRB) :: DELT5 + REAL(KIND=JWRB) :: GTEMP1 + REAL(KIND=JWRB) :: GTEMP2 + REAL(KIND=JWRB) :: FLHAB + REAL(KIND=JWRB), INTENT(INOUT) :: RAORW(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: EMEAN(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: FMEAN(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: HALP(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: EMEANWS(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: FMEANWS(KIJL, NCHNK) + REAL(KIND=JWRB) :: USFM + REAL(KIND=JWRB), INTENT(INOUT) :: F1MEAN(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: AKMEAN(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: XKMEAN(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: PHIWA(KIJL, NCHNK) + + REAL(KIND=JWRB), INTENT(INOUT) :: FLM(KIJL, NANG_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: COSWDIF(KIJL, NANG_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: SINWDIF2(KIJL, NANG_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: RHOWGDFTH(KIJL, NFRE_loki_param, NCHNK) + ! *FLD* DIAGONAL MATRIX OF FUNCTIONAL DERIVATIVE + ! *SL* TOTAL SOURCE FUNCTION ARRAY. + ! *SPOS* : POSITIVE SINPUT ONLY + REAL(KIND=JWRB), INTENT(INOUT) :: FLD(KIJL, NANG_loki_param, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: SL(KIJL, NANG_loki_param, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: SPOS(KIJL, NANG_loki_param, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: CIREDUC(KIJL, NANG_loki_param, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: SSOURCE(KIJL, NANG_loki_param, NFRE_loki_param, NCHNK) + + LOGICAL :: LCFLX + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ABMAX + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ABMIN + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ACD + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ACDLIN + REAL(KIND=JWRB), INTENT(IN), DEVICE :: AF11(MFRSTLW:MLSTHG) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: AFCRV + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ALPHA + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ALPHAMAX + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ALPHAMIN + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ALPHAPMAX + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ANG_GC_A + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ANG_GC_B + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ANG_GC_C + REAL(KIND=JWRB), VALUE, INTENT(IN) :: BATHYMAX + REAL(KIND=JWRB), VALUE, INTENT(IN) :: BCD + REAL(KIND=JWRB), VALUE, INTENT(IN) :: BCDLIN + REAL(KIND=JWRB), VALUE, INTENT(IN) :: BETAMAXOXKAPPA2 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: BFCRV + REAL(KIND=JWRB), VALUE, INTENT(IN) :: BMAXOKAP + REAL(KIND=JWRB), INTENT(IN), DEVICE :: C2OSQRTVG_GC(NWAV_GC) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: CDICWA + REAL(KIND=JWRB), VALUE, INTENT(IN) :: CDIS + REAL(KIND=JWRB), VALUE, INTENT(IN) :: CDISVIS + REAL(KIND=JWRB), VALUE, INTENT(IN) :: CDMAX + REAL(KIND=JWRB), VALUE, INTENT(IN) :: CHNKMIN_U + REAL(KIND=JWRB), VALUE, INTENT(IN) :: CIBLOCK + REAL(KIND=JWRB), VALUE, INTENT(IN) :: CITHRSH + REAL(KIND=JWRB), VALUE, INTENT(IN) :: CITHRSH_TAIL + REAL(KIND=JWRB), INTENT(IN), DEVICE :: CM_GC(NWAV_GC) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: COFRM4(NFRE_loki_param) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: COSTH(NFRE_loki_param) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: CUMULW(NDEPTH, 0:NANG/2, NFRE_loki_param, NFRE_loki_param) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: DAL1 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: DAL2 + REAL(KIND=JWRB), INTENT(IN), DEVICE :: DELKCC_GC_NS(NWAV_GC) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: DELKCC_OMXKM3_GC(NWAV_GC) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: DELTA_SDIS + REAL(KIND=JWRB), VALUE, INTENT(IN) :: DELTH + REAL(KIND=JWRB), INTENT(IN), DEVICE :: DFIM(NFRE_loki_param) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: DFIMFR(NFRE_loki_param) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: DFIMFR2(NFRE_loki_param) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: DFIMOFR(NFRE_loki_param) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: DFIM_SIM(NFRE_loki_param) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: DKMAX + REAL(KIND=JWRB), VALUE, INTENT(IN) :: DTHRN_A + REAL(KIND=JWRB), VALUE, INTENT(IN) :: DTHRN_U + REAL(KIND=JWRB), VALUE, INTENT(IN) :: EGRCRV + REAL(KIND=JWRB), VALUE, INTENT(IN) :: EPS1 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: EPSMIN + REAL(KIND=JWRB), VALUE, INTENT(IN) :: EPSU10 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: EPSUS + REAL(KIND=JWRB), INTENT(IN), DEVICE :: FKLAM(MFRSTLW:MLSTHG) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: FKLAM1(MFRSTLW:MLSTHG) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: FKLAP(MFRSTLW:MLSTHG) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: FKLAP1(MFRSTLW:MLSTHG) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: FLMAX(NFRE_loki_param) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: FLMIN + REAL(KIND=JWRB), VALUE, INTENT(IN) :: FLOGSPRDM1 + REAL(KIND=JWRB), INTENT(IN), DEVICE :: FR(NFRE_loki_param) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: FR5(NFRE_loki_param) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: FRATIO + REAL(KIND=JWRB), VALUE, INTENT(IN) :: FRIC + REAL(KIND=JWRB), VALUE, INTENT(IN) :: FRTAIL + REAL(KIND=JWRB), VALUE, INTENT(IN) :: G + REAL(KIND=JWRB), VALUE, INTENT(IN) :: GAMNCONST + REAL(KIND=JWRB), VALUE, INTENT(IN) :: GM1 + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: IAB + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: ICODE + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: ICODE_CPL + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: IDAMPING + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: IDELT + INTEGER(KIND=JWIM), INTENT(IN), DEVICE :: IKM(MFRSTLW:MLSTHG) + INTEGER(KIND=JWIM), INTENT(IN), DEVICE :: IKM1(MFRSTLW:MLSTHG) + INTEGER(KIND=JWIM), INTENT(IN), DEVICE :: IKP(MFRSTLW:MLSTHG) + INTEGER(KIND=JWIM), INTENT(IN), DEVICE :: IKP1(MFRSTLW:MLSTHG) + INTEGER(KIND=JWIM), INTENT(IN), DEVICE :: INDICESSAT(NANG_loki_param, NSDSNTH*2+1) + INTEGER(KIND=JWIM), INTENT(IN), DEVICE :: INLCOEF(NINL, 1:MLSTHG) + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: IPHYS + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: IPSAT + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: ISNONLIN + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: JTOT_TAUHF + INTEGER(KIND=JWIM), INTENT(IN), DEVICE :: K11W(NANG_loki_param, 2) + INTEGER(KIND=JWIM), INTENT(IN), DEVICE :: K1W(NANG_loki_param, 2) + INTEGER(KIND=JWIM), INTENT(IN), DEVICE :: K21W(NANG_loki_param, 2) + INTEGER(KIND=JWIM), INTENT(IN), DEVICE :: K2W(NANG_loki_param, 2) + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KFRH + LOGICAL, VALUE, INTENT(IN) :: LBIWBK + LOGICAL, VALUE, INTENT(IN) :: LCIWABR + LOGICAL, VALUE, INTENT(IN) :: LICERUN + LOGICAL, VALUE, INTENT(IN) :: LLCAPCHNK + LOGICAL, VALUE, INTENT(IN) :: LLGCBZ0 + LOGICAL, VALUE, INTENT(IN) :: LLNORMAGAM + LOGICAL, VALUE, INTENT(IN) :: LLUNSTR + LOGICAL, VALUE, INTENT(IN) :: LMASKICE + LOGICAL, VALUE, INTENT(IN) :: LWAMRSETCI + LOGICAL, VALUE, INTENT(IN) :: LWCOU + LOGICAL, VALUE, INTENT(IN) :: LWFLUX + LOGICAL, VALUE, INTENT(IN) :: LWFLUXOUT + LOGICAL, VALUE, INTENT(IN) :: LWNEMOCOU + LOGICAL, VALUE, INTENT(IN) :: LWNEMOCOUSEND + LOGICAL, VALUE, INTENT(IN) :: LWNEMOCOUSTK + LOGICAL, VALUE, INTENT(IN) :: LWNEMOCOUSTRN + LOGICAL, VALUE, INTENT(IN) :: LWNEMOTAUOC + LOGICAL, VALUE, INTENT(IN) :: LWVFLX_SNL + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: MFRSTLW + REAL(KIND=JWRB), VALUE, INTENT(IN) :: MICHE + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: MLSTHG + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NANG + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NDEPTH + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NDIKCUMUL + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NFRE + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NFRE_ODD + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NFRE_RED + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NSDSNTH + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NWAV_GC + REAL(KIND=JWRB), INTENT(IN), DEVICE :: OM3GMKM_GC(NWAV_GC) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: OMEGA_GC(NWAV_GC) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: OMXKM3_GC(NWAV_GC) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: PHIEPSMAX + REAL(KIND=JWRB), VALUE, INTENT(IN) :: PHIEPSMIN + REAL(KIND=JWRB), INTENT(IN), DEVICE :: RHOWG_DFIM(NFRE_loki_param) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: RN1_RN + REAL(KIND=JWRB), INTENT(IN), DEVICE :: RNLCOEF(NRNL, 1:MLSTHG) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: RNU + REAL(KIND=JWRB), VALUE, INTENT(IN) :: RNUM + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ROWATER + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ROWATERM1 + REAL(KIND=JWRB), INTENT(IN), DEVICE :: SATWEIGHTS(NANG_loki_param, NSDSNTH*2+1) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SDSBR + REAL(KIND=JWRB), INTENT(IN), DEVICE :: SINTH(NFRE_loki_param) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SQRTGOSURFT + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SSDSC2 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SSDSC3 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SSDSC4 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SSDSC5 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SSDSC6 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SWELLF + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SWELLF2 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SWELLF3 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SWELLF4 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SWELLF5 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SWELLF6 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SWELLF7 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SWELLF7M1 + REAL(KIND=JWRB), INTENT(IN) :: SWELLFT(IAB) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: TAILFACTOR + REAL(KIND=JWRB), VALUE, INTENT(IN) :: TAILFACTOR_PM + REAL(KIND=JWRB), VALUE, INTENT(IN) :: TAUOCMAX + REAL(KIND=JWRB), VALUE, INTENT(IN) :: TAUOCMIN + REAL(KIND=JWRB), VALUE, INTENT(IN) :: TAUWSHELTER + REAL(KIND=JWRB), INTENT(IN), DEVICE :: TH(NFRE_loki_param) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: WETAIL + REAL(KIND=JWRB), VALUE, INTENT(IN) :: WP1TAIL + REAL(KIND=JWRB), VALUE, INTENT(IN) :: WP2TAIL + REAL(KIND=JWRB), VALUE, INTENT(IN) :: WSEMEAN_MIN + REAL(KIND=JWRB), VALUE, INTENT(IN) :: WSPMIN + REAL(KIND=JWRB), INTENT(IN) :: WTAUHF(JTOT_TAUHF) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: X0TAUHF + REAL(KIND=JWRB), VALUE, INTENT(IN) :: XKAPPA + REAL(KIND=JWRB), VALUE, INTENT(IN) :: XKDMIN + REAL(KIND=JWRB), INTENT(IN), DEVICE :: XKMSQRTVGOC2_GC(NWAV_GC) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: XKM_GC(NWAV_GC) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: XK_GC(NWAV_GC) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: XLOGKRATIOM1_GC + REAL(KIND=JWRB), VALUE, INTENT(IN) :: XNLEV + REAL(KIND=JWRB), VALUE, INTENT(IN) :: Z0RAT + REAL(KIND=JWRB), VALUE, INTENT(IN) :: Z0TUBMAX + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ZALP + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ZPI + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ZPI4GM1 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ZPI4GM2 + REAL(KIND=JWRB), INTENT(IN), DEVICE :: ZPIFR(NFRE_loki_param) + INTEGER(KIND=JWIM) :: ICHNK + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: ICHNK_start + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: ICHNK_end + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: ICHNK_step + INTEGER, VALUE, INTENT(IN) :: NCHNK + REAL(KIND=JWRB), INTENT(INOUT) :: SINFLX_RNFAC(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: SINFLX_TMP_EM(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: STRESSO_TAUHF(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: STRESSO_PHIHF(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: STRESSO_UST(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: SNONLIN_XNU(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: SNONLIN_SIG_TH(KIJL, NCHNK) + IJ = THREADIDX%X + ICHNK = BLOCKIDX%Z + + IF (ICHNK <= NCHNK .and. IJ <= KIJL) THEN + + ! START of Loki inserted loop ICHNK + + + ! ---------------------------------------------------------------------- + + + + !* 1. INITIALISATION. + ! --------------- + + DELT = IDELT + DELTM = 1.0_JWRB / DELT + XIMP = 1.0_JWRB + DELT5 = XIMP*DELT + + LCFLX = LWFLUX .or. LWFLUXOUT .or. LWNEMOCOU + + + + RAORW(IJ, ICHNK) = MAX(AIRD(IJ, ICHNK), 1.0_JWRB)*ROWATERM1 + + DO K=1,NANG + COSWDIF(IJ, K, ICHNK) = COS(TH(K) - WDWAVE(IJ, ICHNK)) + SINWDIF2(IJ, K, ICHNK) = SIN(TH(K) - WDWAVE(IJ, ICHNK))**2 + END DO + + + ! ---------------------------------------------------------------------- + + !* 2. COMPUTATION OF IMPLICIT INTEGRATION. + ! ------------------------------------ + + ! INTEGRATION IS DONE FROM CDATE UNTIL CDTPRO FOR A BLOCK + ! OF LATITUDES BETWEEN PROPAGATION CALLS. + + + ! REDUCE WAVE ENERGY IF LARGER THAN DEPTH LIMITED WAVE HEIGHT + IF (LBIWBK) THEN + CALL SDEPTHLIM_CUF_HOIST_NEW(KIJS, KIJL, EMAXDPT(:, :), FL1(:, :, :, :), DELTH, DFIM(:), EPSMIN, FR(:), NANG, NFRE, & + & WETAIL, ICHNK, NCHNK, IJ) + END IF + + ! IF (IJ .eq. 1 .AND. ICHNK .eq. 1) THEN + ! print *, "within implsch after sdepthlim FL1(1, 1, 1, 1) = ", FL1(1, 1, 1, 1) + ! END IF + + !* 2.2 COMPUTE MEAN PARAMETERS. + ! ------------------------ + + CALL FKMEAN_CUF_HOIST_NEW(KIJS, KIJL, FL1(:, :, :, :), WAVNUM(:, :, :), EMEAN(:, ICHNK), FMEAN(:, ICHNK), & + & F1MEAN(:, ICHNK), AKMEAN(:, ICHNK), XKMEAN(:, ICHNK), DELTH, DFIM(:), DFIMFR(:), DFIMOFR(:), EPSMIN, FR(:), FRTAIL, G, & + & NANG, NFRE, WETAIL, WP1TAIL, ZPI, ICHNK, NCHNK, IJ) + + + ! IF (IJ .eq. 1 .AND. ICHNK .eq. 1) THEN + ! print *, "within implsch after fkmean FL1(1, 1, 1, 1) = ", FL1(1, 1, 1, 1) + ! END IF + + DO K=1,NANG + FLM(IJ, K, ICHNK) = FLMIN*MAX(0.0_JWRB, COSWDIF(IJ, K, ICHNK))**2 + END DO + + ! IF (IJ .eq. 1 .AND. ICHNK .eq. 1) THEN + ! print *, "within implsch after fkmean FLM(1, 1, 1) = ", FLM(1, 1, 1) + ! print *, " FLMIN: ", FLMIN + ! print *, " COSWDIF(1, 1, 1): ", COSWDIF(1, 1, 1) + ! END IF + + ! COMPUTE DAMPING COEFFICIENT DUE TO FRICTION ON BOTTOM OF THE SEA ICE. + !!! testing sea ice attenuation (might need to restrict usage when needed) + IF (LCIWABR) THEN + CALL CIWABR_CUF_HOIST_NEW(KIJS, KIJL, CICOVER(:, :), FL1(:, :, :, :), WAVNUM(:, :, :), CGROUP(:, :, :), & + & CIREDUC(:, :, :, ICHNK), CDICWA, DFIM(:), EPSMIN, IDELT, LICERUN, LMASKICE, NANG, NFRE, ICHNK, NCHNK, IJ) + ! IF (IJ .eq. 1 .AND. ICHNK .eq. 1) THEN + ! print *, "within implsch after ciwabr FL1(1, 1, 1, 1) = ", FL1(1, 1, 1, 1) + ! END IF + DO M=1,NFRE + DO K=1,NANG + CIREDUC(IJ, K, M, ICHNK) = CIWA(IJ, M, ICHNK)*CIREDUC(IJ, K, M, ICHNK) + END DO + END DO + + ELSE + + DO M=1,NFRE + DO K=1,NANG + CIREDUC(IJ, K, M, ICHNK) = CIWA(IJ, M, ICHNK) + END DO + END DO + + END IF + + ! ---------------------------------------------------------------------- + + !* 2.3 COMPUTATION OF SOURCE FUNCTIONS. + ! -------------------------------- + + !* 2.3.1 ITERATIVELY UPDATE STRESS AND COMPUTE WIND INPUT TERMS. + ! ------------------------------------------------------- + + CALL SINFLX_CUF_HOIST_NEW(1, KIJS, KIJL, .true., FL1(:, :, :, :), WAVNUM(:, :, :), CINV(:, :, :), XK2CG(:, :, :), & + & WSWAVE(:, :), WDWAVE(:, :), AIRD(:, :), RAORW(:, ICHNK), WSTAR(:, :), CICOVER(:, :), COSWDIF(:, :, ICHNK), & + & SINWDIF2(:, :, ICHNK), FMEAN(:, ICHNK), HALP(:, ICHNK), FMEANWS(:, ICHNK), FLM(:, :, ICHNK), UFRIC(:, :), TAUW(:, :), & + & TAUWDIR(:, :), Z0M(:, :), Z0B(:, :), CHRNCK(:, :), PHIWA(:, ICHNK), FLD(:, :, :, ICHNK), SL(:, :, :, ICHNK), & + & SPOS(:, :, :, ICHNK), MIJ(:, :), RHOWGDFTH(:, :, ICHNK), XLLWS(:, :, :, :), ABMAX, ABMIN, ACD, ACDLIN, ALPHA, ALPHAMAX, & + & ALPHAMIN, ALPHAPMAX, ANG_GC_A, ANG_GC_B, ANG_GC_C, BCD, BCDLIN, BETAMAXOXKAPPA2, BMAXOKAP, C2OSQRTVG_GC(:), CDMAX, & + & CHNKMIN_U, CITHRSH_TAIL, CM_GC(:), COSTH(:), DELKCC_GC_NS(:), DELKCC_OMXKM3_GC(:), DELTH, DFIM(:), DFIMOFR(:), DTHRN_A, & + & DTHRN_U, EPS1, EPSMIN, EPSUS, FLOGSPRDM1, FR(:), FR5(:), FRIC, FRTAIL, G, GAMNCONST, GM1, IAB, ICODE, ICODE_CPL, & + & IDAMPING, IPHYS, JTOT_TAUHF, LLCAPCHNK, LLGCBZ0, LLNORMAGAM, LWCOU, NANG, NFRE, NWAV_GC, OM3GMKM_GC(:), OMEGA_GC(:), & + & OMXKM3_GC(:), RHOWG_DFIM(:), RN1_RN, RNU, RNUM, SINTH(:), SQRTGOSURFT, SWELLF, SWELLF2, SWELLF3, SWELLF4, SWELLF5, & + & SWELLF6, SWELLF7, SWELLF7M1, SWELLFT(:), TAILFACTOR, TAILFACTOR_PM, TAUWSHELTER, TH(:), WETAIL, WSPMIN, WTAUHF(:), & + & X0TAUHF, XKAPPA, XKMSQRTVGOC2_GC(:), XKM_GC(:), XK_GC(:), XLOGKRATIOM1_GC, XNLEV, Z0RAT, Z0TUBMAX, ZALP, ZPI, ZPI4GM1, & + & ZPI4GM2, ZPIFR(:), ICHNK, NCHNK, IJ, RNFAC=SINFLX_RNFAC, TMP_EM=SINFLX_TMP_EM, STRESSO_TAUHF=STRESSO_TAUHF, & + & STRESSO_PHIHF=STRESSO_PHIHF, STRESSO_UST=STRESSO_UST) + ! IF (IJ .eq. 1 .AND. ICHNK .eq. 1) THEN + ! print *, "within implsch after sinflx (1) FL1(1, 1, 1, 1) = ", FL1(1, 1, 1, 1) + ! END IF + CALL SINFLX_CUF_HOIST_NEW(2, KIJS, KIJL, .true., FL1(:, :, :, :), WAVNUM(:, :, :), CINV(:, :, :), XK2CG(:, :, :), & + & WSWAVE(:, :), WDWAVE(:, :), AIRD(:, :), RAORW(:, ICHNK), WSTAR(:, :), CICOVER(:, :), COSWDIF(:, :, ICHNK), & + & SINWDIF2(:, :, ICHNK), FMEAN(:, ICHNK), HALP(:, ICHNK), FMEANWS(:, ICHNK), FLM(:, :, ICHNK), UFRIC(:, :), TAUW(:, :), & + & TAUWDIR(:, :), Z0M(:, :), Z0B(:, :), CHRNCK(:, :), PHIWA(:, ICHNK), FLD(:, :, :, ICHNK), SL(:, :, :, ICHNK), & + & SPOS(:, :, :, ICHNK), MIJ(:, :), RHOWGDFTH(:, :, ICHNK), XLLWS(:, :, :, :), ABMAX, ABMIN, ACD, ACDLIN, ALPHA, ALPHAMAX, & + & ALPHAMIN, ALPHAPMAX, ANG_GC_A, ANG_GC_B, ANG_GC_C, BCD, BCDLIN, BETAMAXOXKAPPA2, BMAXOKAP, C2OSQRTVG_GC(:), CDMAX, & + & CHNKMIN_U, CITHRSH_TAIL, CM_GC(:), COSTH(:), DELKCC_GC_NS(:), DELKCC_OMXKM3_GC(:), DELTH, DFIM(:), DFIMOFR(:), DTHRN_A, & + & DTHRN_U, EPS1, EPSMIN, EPSUS, FLOGSPRDM1, FR(:), FR5(:), FRIC, FRTAIL, G, GAMNCONST, GM1, IAB, ICODE, ICODE_CPL, & + & IDAMPING, IPHYS, JTOT_TAUHF, LLCAPCHNK, LLGCBZ0, LLNORMAGAM, LWCOU, NANG, NFRE, NWAV_GC, OM3GMKM_GC(:), OMEGA_GC(:), & + & OMXKM3_GC(:), RHOWG_DFIM(:), RN1_RN, RNU, RNUM, SINTH(:), SQRTGOSURFT, SWELLF, SWELLF2, SWELLF3, SWELLF4, SWELLF5, & + & SWELLF6, SWELLF7, SWELLF7M1, SWELLFT(:), TAILFACTOR, TAILFACTOR_PM, TAUWSHELTER, TH(:), WETAIL, WSPMIN, WTAUHF(:), & + & X0TAUHF, XKAPPA, XKMSQRTVGOC2_GC(:), XKM_GC(:), XK_GC(:), XLOGKRATIOM1_GC, XNLEV, Z0RAT, Z0TUBMAX, ZALP, ZPI, ZPI4GM1, & + & ZPI4GM2, ZPIFR(:), ICHNK, NCHNK, IJ, RNFAC=SINFLX_RNFAC, TMP_EM=SINFLX_TMP_EM, STRESSO_TAUHF=STRESSO_TAUHF, & + & STRESSO_PHIHF=STRESSO_PHIHF, STRESSO_UST=STRESSO_UST) + ! IF (IJ .eq. 1 .AND. ICHNK .eq. 1) THEN + ! print *, "within implsch after sinflux (2) FL1(1, 1, 1, 1) = ", FL1(1, 1, 1, 1) + ! END IF + ! 2.3.3 ADD THE OTHER SOURCE TERMS. + ! --------------------------- + + CALL SDISSIP_CUF_HOIST_NEW(KIJS, KIJL, FL1(:, :, :, :), FLD(:, :, :, ICHNK), SL(:, :, :, ICHNK), INDEP(:, :), & + & WAVNUM(:, :, :), XK2CG(:, :, :), EMEAN(:, ICHNK), F1MEAN(:, ICHNK), XKMEAN(:, ICHNK), UFRIC(:, :), COSWDIF(:, :, ICHNK), & + & RAORW(:, ICHNK), CDIS, CDISVIS, CUMULW(:, :, :, :), DELTA_SDIS, G, INDICESSAT(:, :), IPHYS, IPSAT, MICHE, NANG, NDEPTH, & + & NDIKCUMUL, NFRE, NSDSNTH, RNU, SATWEIGHTS(:, :), SDSBR, SSDSC2, SSDSC3, SSDSC4, SSDSC5, SSDSC6, ZPI, ZPIFR(:), ICHNK, & + & NCHNK, IJ) + ! IF (IJ .eq. 1 .AND. ICHNK .eq. 1) THEN + ! print *, "within implsch after sdissip FL1(1, 1, 1, 1) = ", FL1(1, 1, 1, 1) + ! END IF + ! Save source term contributions relevant for the calculation of ocean fluxes + + IF (LCFLX .and. .not.LWVFLX_SNL) THEN + DO M=1,NFRE + DO K=1,NANG + SSOURCE(IJ, K, M, ICHNK) = SL(IJ, K, M, ICHNK) + END DO + END DO + END IF + + + CALL SNONLIN_CUF_HOIST_NEW(KIJS, KIJL, FL1(:, :, :, :), FLD(:, :, :, ICHNK), SL(:, :, :, ICHNK), WAVNUM(:, :, :), & + & DEPTH(:, :), AKMEAN(:, ICHNK), AF11(:), BATHYMAX, COSTH(:), DAL1, DAL2, DELTH, DFIM(:), DFIMFR(:), DFIMFR2(:), DKMAX, & + & FKLAM(:), FKLAM1(:), FKLAP(:), FKLAP1(:), FR(:), FRATIO, G, GM1, IKM(:), IKM1(:), IKP(:), IKP1(:), INLCOEF(:, :), & + & ISNONLIN, K11W(:, :), K1W(:, :), K21W(:, :), K2W(:, :), KFRH, MFRSTLW, MLSTHG, NANG, NFRE, RNLCOEF(:, :), SINTH(:), & + & TH(:), WETAIL, WP1TAIL, WP2TAIL, XKDMIN, ZPIFR(:), ICHNK, NCHNK, IJ, XNU=SNONLIN_XNU, SIG_TH=SNONLIN_SIG_TH, ENH=ENH(:,:,ICHNK)) + + ! IF (IJ .eq. 1 .AND. ICHNK .eq. 1) THEN + ! print *, "within implsch after snonlin FL1(1, 1, 1, 1) = ", FL1(1, 1, 1, 1) + ! END IF + IF (LCFLX .and. LWVFLX_SNL) THEN + ! Save source term contributions relevant for the calculation of ocean fluxes + !!!!!! SL must only contain contributions contributed to fluxes into the oceans + ! MODULATE SL BY IMPLICIT FACTOR + DO M=1,NFRE + DO K=1,NANG + GTEMP1 = MAX((1.0_JWRB - DELT5*FLD(IJ, K, M, ICHNK)), 1.0_JWRB) + SSOURCE(IJ, K, M, ICHNK) = SL(IJ, K, M, ICHNK) / GTEMP1 + END DO + END DO + END IF + + + + CALL SDIWBK_CUF_HOIST_NEW(KIJS, KIJL, FL1(:, :, :, :), FLD(:, :, :, ICHNK), SL(:, :, :, ICHNK), DEPTH(:, :), & + & EMAXDPT(:, :), EMEAN(:, ICHNK), F1MEAN(:, ICHNK), LBIWBK, NANG, NFRE_RED, ICHNK, NCHNK, IJ) + + ! IF (IJ .eq. 1 .AND. ICHNK .eq. 1) THEN + ! print *, "within implsch after sdiwbk FL1(1, 1, 1, 1) = ", FL1(1, 1, 1, 1) + ! END IF + + CALL SBOTTOM_CUF_HOIST_NEW(KIJS, KIJL, FL1(:, :, :, :), FLD(:, :, :, ICHNK), SL(:, :, :, ICHNK), WAVNUM(:, :, :), & + & DEPTH(:, :), BATHYMAX, GM1, NANG, NFRE_RED, ICHNK, NCHNK, IJ) + + ! IF (IJ .eq. 1 .AND. ICHNK .eq. 1) THEN + ! print *, "within implsch after sbottom FL1(1, 1, 1, 1) = ", FL1(1, 1, 1, 1) + ! END IF + ! ---------------------------------------------------------------------- + + !* 2.4 COMPUTATION OF NEW SPECTRA. + ! --------------------------- + + ! INCREASE OF SPECTRUM IN A TIME STEP IS LIMITED TO A FINITE + ! FRACTION OF A TYPICAL F**(-4) EQUILIBRIUM SPECTRUM. + + + USFM = UFRIC(IJ, ICHNK)*MAX(FMEANWS(IJ, ICHNK), FMEAN(IJ, ICHNK)) + + IF (LLUNSTR) THEN + ! IF (IJ .eq. 1 .AND. ICHNK .eq. 1) THEN + ! print *, "within branch 1 ..." + ! ENDIF + DO K=1,NANG + DO M=1,NFRE + GTEMP1 = MAX((1.0_JWRB - DELT5*FLD(IJ, K, M, ICHNK)), 1.0_JWRB) + GTEMP2 = DELT*SL(IJ, K, M, ICHNK) / GTEMP1 + FLHAB = ABS(GTEMP2) + FLHAB = MIN(FLHAB, USFM*COFRM4(M)*DELT) + FL1(IJ, K, M, ICHNK) = FL1(IJ, K, M, ICHNK) + IOBND(IJ, ICHNK)*SIGN(FLHAB, GTEMP2) + FL1(IJ, K, M, ICHNK) = MAX(IODP(IJ, ICHNK)*CIREDUC(IJ, K, M, ICHNK)*FL1(IJ, K, M, ICHNK), FLM(IJ, K, ICHNK)) + SSOURCE(IJ, K, M, ICHNK) = SSOURCE(IJ, K, M, ICHNK) + DELTM*MIN(FLMAX(M) - FL1(IJ, K, M, ICHNK), 0.0_JWRB) + FL1(IJ, K, M, ICHNK) = MIN(FL1(IJ, K, M, ICHNK), FLMAX(M)) + END DO + END DO + ELSE + ! IF (IJ .eq. 1 .AND. ICHNK .eq. 1) THEN + ! print *, "within branch 2 ..." + ! ENDIF + DO K=1,NANG + DO M=1,NFRE + GTEMP1 = MAX((1.0_JWRB - DELT5*FLD(IJ, K, M, ICHNK)), 1.0_JWRB) + GTEMP2 = DELT*SL(IJ, K, M, ICHNK) / GTEMP1 + FLHAB = ABS(GTEMP2) + FLHAB = MIN(FLHAB, USFM*COFRM4(M)*DELT) + FL1(IJ, K, M, ICHNK) = FL1(IJ, K, M, ICHNK) + SIGN(FLHAB, GTEMP2) + FL1(IJ, K, M, ICHNK) = MAX(CIREDUC(IJ, K, M, ICHNK)*FL1(IJ, K, M, ICHNK), FLM(IJ, K, ICHNK)) + SSOURCE(IJ, K, M, ICHNK) = SSOURCE(IJ, K, M, ICHNK) + DELTM*MIN(FLMAX(M) - FL1(IJ, K, M, ICHNK), 0.0_JWRB) + FL1(IJ, K, M, ICHNK) = MIN(FL1(IJ, K, M, ICHNK), FLMAX(M)) + END DO + END DO + END IF + + ! IF (IJ .eq. 1 .AND. ICHNK .eq. 1) THEN + ! print *, "within implsch after computation of new spectra FL1(1, 1, 1, 1) = ", FL1(1, 1, 1, 1) + ! print *, " FLM(1, 1, 1) = ", FLM(1, 1, 1) + ! print *, " CIREDUC(1, 1, 1, 1) = ", CIREDUC(1, 1, 1, 1) + ! print *, " FLHAB = ", FLHAB + ! print *, " GTEMP2 = ", GTEMP2 + ! END IF + + + IF (LCFLX) THEN + CALL WNFLUXES_CUF_HOIST_NEW(KIJS, KIJL, MIJ(:, :), RHOWGDFTH(:, :, ICHNK), CINV(:, :, :), SSOURCE(:, :, :, ICHNK), & + & CICOVER(:, :), PHIWA(:, ICHNK), EMEAN(:, ICHNK), F1MEAN(:, ICHNK), WSWAVE(:, :), WDWAVE(:, :), UFRIC(:, :), & + & AIRD(:, :), NPHIEPS(:, :), NTAUOC(:, :), NSWH(:, :), NMWP(:, :), NEMOTAUX(:, :), NEMOTAUY(:, :), NEMOWSWAVE(:, :), & + & NEMOPHIF(:, :), TAUXD(:, :), TAUYD(:, :), TAUOCXD(:, :), TAUOCYD(:, :), TAUOC(:, :), PHIOCD(:, :), PHIEPS(:, :), & + & PHIAW(:, :), .true., AFCRV, BFCRV, CIBLOCK, CITHRSH, COSTH(:), EGRCRV, EPSU10, EPSUS, FR(:), G, LICERUN, LWAMRSETCI, & + & LWNEMOCOU, LWNEMOTAUOC, NANG, NFRE, PHIEPSMAX, PHIEPSMIN, SINTH(:), TAUOCMAX, TAUOCMIN, ICHNK, NCHNK, IJ) + END IF + ! ---------------------------------------------------------------------- + + !* 2.5 REPLACE DIAGNOSTIC PART OF SPECTRA BY A F**(-5) TAIL. + ! ----------------------------------------------------- + + CALL FKMEAN_CUF_HOIST_NEW(KIJS, KIJL, FL1(:, :, :, :), WAVNUM(:, :, :), EMEAN(:, ICHNK), FMEAN(:, ICHNK), & + & F1MEAN(:, ICHNK), AKMEAN(:, ICHNK), XKMEAN(:, ICHNK), DELTH, DFIM(:), DFIMFR(:), DFIMOFR(:), EPSMIN, FR(:), FRTAIL, G, & + & NANG, NFRE, WETAIL, WP1TAIL, ZPI, ICHNK, NCHNK, IJ) + + ! IF (IJ .eq. 1 .AND. ICHNK .eq. 1) THEN + ! print *, "within implsch after fkmean FL1(1, 1, 1, 1) = ", FL1(1, 1, 1, 1) + ! END IF + + ! MEAN FREQUENCY CHARACTERISTIC FOR WIND SEA + CALL FEMEANWS_CUF_HOIST_NEW(KIJS, KIJL, FL1(:, :, :, :), XLLWS(:, :, :, :), FMEANWS(:, ICHNK), EMEANWS(:, ICHNK), DELTH, & + & DFIM(:), DFIMOFR(:), EPSMIN, FR(:), FRTAIL, NANG, NFRE, WETAIL, ICHNK, NCHNK, IJ) + + ! IF (IJ .eq. 1 .AND. ICHNK .eq. 1) THEN + ! print *, "within implsch after femeanws FL1(1, 1, 1, 1) = ", FL1(1, 1, 1, 1) + ! END IF + + CALL IMPHFTAIL_CUF_HOIST_NEW(KIJS, KIJL, MIJ(:, :), FLM(:, :, ICHNK), WAVNUM(:, :, :), XK2CG(:, :, :), FL1(:, :, :, :), & + & NANG, NFRE, ICHNK, NCHNK, IJ) + + ! IF (IJ .eq. 1 .AND. ICHNK .eq. 1) THEN + ! print *, "within implsch after imphftail FL1(1, 1, 1, 1) = ", FL1(1, 1, 1, 1) + ! END IF + ! UPDATE WINDSEA VARIANCE AND MEAN FREQUENCY IF PASSED TO ATMOSPHERE + ! ------------------------------------------------------------------ + + IF (LWFLUX) THEN + IF (EMEANWS(IJ, ICHNK) < WSEMEAN_MIN) THEN + WSEMEAN(IJ, ICHNK) = WSEMEAN_MIN + WSFMEAN(IJ, ICHNK) = 2._JWRB*FR(NFRE) + ELSE + WSEMEAN(IJ, ICHNK) = EMEANWS(IJ, ICHNK) + WSFMEAN(IJ, ICHNK) = FMEANWS(IJ, ICHNK) + END IF + END IF + + + + !* 2.6 SET FL1 ON ICE POINTS TO ZERO + ! ----------------------------- + + IF (LICERUN .and. LMASKICE) THEN + CALL SETICE_CUF_HOIST_NEW(KIJS, KIJL, FL1(:, :, :, :), CICOVER(:, :), COSWDIF(:, :, ICHNK), CITHRSH, EPSMIN, FLMIN, & + & NANG, NFRE, ICHNK, NCHNK, IJ) + END IF + + ! IF (IJ .eq. 1 .AND. ICHNK .eq. 1) THEN + ! print *, "within implsch after settice FL1(1, 1, 1, 1) = ", FL1(1, 1, 1, 1) + ! END IF + + !* 2.7 SURFACE STOKES DRIFT AND STRAIN IN SEA ICE + ! ------------------------------------------ + + CALL STOKESTRN_CUF_HOIST_NEW(KIJS, KIJL, FL1(:, :, :, :), WAVNUM(:, :, :), STOKFAC(:, :, :), DEPTH(:, :), WSWAVE(:, :), & + & WDWAVE(:, :), CICOVER(:, :), CITHICK(:, :), USTOKES(:, :), VSTOKES(:, :), STRNMS(:, :), NEMOUSTOKES(:, :), & + & NEMOVSTOKES(:, :), NEMOSTRN(:, :), CITHRSH, COSTH(:), DELTH, DFIM(:), DFIM_SIM(:), FLMIN, FR(:), G, LICERUN, LWAMRSETCI, & + & LWCOU, LWNEMOCOU, LWNEMOCOUSEND, LWNEMOCOUSTK, LWNEMOCOUSTRN, NANG, NFRE, NFRE_ODD, ROWATER, SINTH(:), ZPI, ICHNK, & + & NCHNK, IJ) + + ! IF (IJ .eq. 1 .AND. ICHNK .eq. 1) THEN + ! print *, "within implsch after stokestrn FL1(1, 1, 1, 1) = ", FL1(1, 1, 1, 1) + ! END IF + + ! ---------------------------------------------------------------------- + + + ! END of Loki inserted loop ICHNK + END IF + END SUBROUTINE IMPLSCH_CUF_HOIST_NEW +END MODULE IMPLSCH_CUF_HOIST_NEW_MOD diff --git a/src/phys-scc-cuf-hoist/ns_gc.cuf_hoist_new.F90 b/src/phys-scc-cuf-hoist/ns_gc.cuf_hoist_new.F90 new file mode 100644 index 00000000..7b8201e2 --- /dev/null +++ b/src/phys-scc-cuf-hoist/ns_gc.cuf_hoist_new.F90 @@ -0,0 +1,58 @@ +! (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. +! +MODULE NS_GC_CUF_HOIST_NEW_MOD + CONTAINS + ATTRIBUTES(DEVICE) FUNCTION NS_GC_CUF_HOIST_NEW (USTAR, NWAV_GC, SQRTGOSURFT, XKM_GC, XLOGKRATIOM1_GC) + + ! ---------------------------------------------------------------------- + + !**** *NS_GC* - FUNCTION TO DETERMINE THE CUT-OFF ANGULAR FREQUENCY INDEX + ! FOR THE GRAVITY-CAPILLARY MODEL + ! !!!! rounded to the closest index of XK_GC !!!!! + + !** INTERFACE. + ! ---------- + + ! *FUNCTION* *NS_GC (USTAR)* + + ! *USTAR* - FRICTION VELOCITY. + + ! ---------------------------------------------------------------------- + + USE cudafor + USE PARKIND_WAVE, ONLY: JWIM, JWRU, JWRB + + + ! ---------------------------------------------------------------------- + + IMPLICIT NONE + + INTEGER :: NS_GC_CUF_HOIST_NEW + REAL(KIND=JWRB), INTENT(IN) :: USTAR + + REAL(KIND=JWRB) :: Y, XKS + INTEGER(KIND=JWIM), INTENT(IN) :: NWAV_GC + REAL(KIND=JWRB), INTENT(IN) :: SQRTGOSURFT + REAL(KIND=JWRB), INTENT(IN), DEVICE :: XKM_GC(NWAV_GC) + REAL(KIND=JWRB), INTENT(IN) :: XLOGKRATIOM1_GC +!$acc routine seq + + ! ---------------------------------------------------------------------- + + + !!!Y = 1.0_JWRB/(1.48_JWRB+2.05_JWRB*UST) + !!!Y = (1.0_JWRB + UST**2)/(1.0_JWRB+10.0_JWRB*UST**2) + + XKS = SQRTGOSURFT / (1.48_JWRB + 2.05_JWRB*USTAR) + + NS_GC_CUF_HOIST_NEW = MIN(INT(LOG(XKS*XKM_GC(1))*XLOGKRATIOM1_GC) + 1, NWAV_GC - 1) + + + END FUNCTION NS_GC_CUF_HOIST_NEW +END MODULE NS_GC_CUF_HOIST_NEW_MOD diff --git a/src/phys-scc-cuf-hoist/peak_ang.cuf_hoist_new.F90 b/src/phys-scc-cuf-hoist/peak_ang.cuf_hoist_new.F90 new file mode 100644 index 00000000..8284c5a9 --- /dev/null +++ b/src/phys-scc-cuf-hoist/peak_ang.cuf_hoist_new.F90 @@ -0,0 +1,184 @@ +! (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. +! +MODULE PEAK_ANG_CUF_HOIST_NEW_MOD + CONTAINS + ATTRIBUTES(DEVICE) SUBROUTINE PEAK_ANG_CUF_HOIST_NEW (KIJS, KIJL, FL1, XNU, SIG_TH, COSTH, DELTH, DFIM, DFIMFR, DFIMFR2, FR, & + & FRATIO, NANG, NFRE, SINTH, TH, WETAIL, WP1TAIL, WP2TAIL, ICHNK, NCHNK, IJ) + + !*** *PEAK_ANG* DETERMINES ANGULAR WIDTH NEAR PEAK OF SPECTRUM + + ! PETER JANSSEN + + ! PURPOSE. + ! -------- + + ! DETERMINATION OF PEAK PARAMETERS + + ! INTERFACE. + ! ---------- + ! *CALL* *PEAK_ANG(KIJS,KIJL,FL1,XNU,SIG_TH)* + + ! INPUT: + ! *KIJS* - FIRST GRIDPOINT + ! *KIJL* - LAST GRIDPOINT + ! *FL1* - SPECTRUM + ! OUTPUT: + ! *XNU* - RELATIVE SPECTRAL WIDTH + ! *SIG_TH* - RELATIVE WIDTH IN DIRECTION + + ! METHOD. + ! ------- + ! NONE + + ! EXTERNALS. + ! ---------- + ! NONE + + !----------------------------------------------------------------------- + + USE cudafor + USE PARKIND_WAVE, ONLY: JWIM, JWRU, JWRB + + USE YOWFRED, ONLY: DFIMOFR + + + ! ---------------------------------------------------------------------- + IMPLICIT NONE + + INTEGER(KIND=JWIM), PARAMETER :: NANG_loki_param = 24 + INTEGER(KIND=JWIM), PARAMETER :: NFRE_loki_param = 36 + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJS + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJL + REAL(KIND=JWRB), INTENT(IN) :: FL1(KIJL, NANG_loki_param, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(OUT) :: XNU(KIJL) + REAL(KIND=JWRB), INTENT(OUT) :: SIG_TH(KIJL) + + + INTEGER(KIND=JWIM) :: NSH + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: IJ + INTEGER(KIND=JWIM) :: M + INTEGER(KIND=JWIM) :: K + INTEGER(KIND=JWIM) :: MMAX + INTEGER(KIND=JWIM) :: MMSTART + INTEGER(KIND=JWIM) :: MMSTOP + REAL(KIND=JWRB), PARAMETER :: CONST_SIG = 1.0_JWRB + REAL(KIND=JWRB) :: R1 + REAL(KIND=JWRB) :: DELT25 + REAL(KIND=JWRB) :: COEF_FR + REAL(KIND=JWRB) :: COEF_FR2 + REAL(KIND=JWRB) :: ZEPSILON + REAL(KIND=JWRB) :: SUM0 + REAL(KIND=JWRB) :: SUM1 + REAL(KIND=JWRB) :: SUM2 + REAL(KIND=JWRB) :: XMAX + REAL(KIND=JWRB) :: TEMP + REAL(KIND=JWRB) :: THMEAN + REAL(KIND=JWRB) :: SUM_S + REAL(KIND=JWRB) :: SUM_C + REAL(KIND=JWRB), INTENT(IN), DEVICE :: COSTH(NFRE_loki_param) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: DELTH + REAL(KIND=JWRB), INTENT(IN), DEVICE :: DFIM(NFRE_loki_param) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: DFIMFR(NFRE_loki_param) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: DFIMFR2(NFRE_loki_param) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: FR(NFRE_loki_param) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: FRATIO + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NANG + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NFRE + REAL(KIND=JWRB), INTENT(IN), DEVICE :: SINTH(NFRE_loki_param) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: TH(NFRE_loki_param) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: WETAIL + REAL(KIND=JWRB), VALUE, INTENT(IN) :: WP1TAIL + REAL(KIND=JWRB), VALUE, INTENT(IN) :: WP2TAIL + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: ICHNK + INTEGER, VALUE, INTENT(IN) :: NCHNK + + ! ---------------------------------------------------------------------- + + !*** 1. DETERMINE L-H SPECTRAL WIDTH OF THE 2-D SPECTRUM. + ! --------------------------------------------------- + + ZEPSILON = 10._JWRB*EPSILON(ZEPSILON) + NSH = 1 + INT(LOG(1.5_JWRB) / LOG(FRATIO)) + + + SUM0 = ZEPSILON + SUM1 = 0._JWRB + SUM2 = 0._JWRB + + DO M=1,NFRE + K = 1 + TEMP = FL1(IJ, K, M, ICHNK) + DO K=2,NANG + TEMP = TEMP + FL1(IJ, K, M, ICHNK) + END DO + SUM0 = SUM0 + TEMP*DFIM(M) + SUM1 = SUM1 + TEMP*DFIMFR(M) + SUM2 = SUM2 + TEMP*DFIMFR2(M) + END DO + + ! ADD TAIL CORRECTIONS + DELT25 = WETAIL*FR(NFRE)*DELTH + COEF_FR = WP1TAIL*DELTH*FR(NFRE)**2 + COEF_FR2 = WP2TAIL*DELTH*FR(NFRE)**3 + SUM0 = SUM0 + DELT25*TEMP + SUM1 = SUM1 + COEF_FR*TEMP + SUM2 = SUM2 + COEF_FR2*TEMP + + IF (SUM0 > ZEPSILON) THEN + XNU(IJ) = SQRT(MAX(ZEPSILON, SUM2*SUM0 / SUM1**2 - 1._JWRB)) + ELSE + XNU(IJ) = ZEPSILON + END IF + + !*** 2. DETERMINE ANGULAR WIDTH OF THE 2-D SPECTRUM. + ! ---------------------------------------------- + + ! MAX OF 2-D SPECTRUM + XMAX = 0._JWRB + MMAX = 2 + + DO M=2,NFRE - 1 + DO K=1,NANG + IF (FL1(IJ, K, M, ICHNK) > XMAX) THEN + MMAX = M + XMAX = FL1(IJ, K, M, ICHNK) + END IF + END DO + END DO + + SUM1 = ZEPSILON + SUM2 = 0._JWRB + + MMSTART = MAX(1, MMAX - NSH) + MMSTOP = MIN(NFRE, MMAX + NSH) + DO M=MMSTART,MMSTOP + SUM_S = 0._JWRB + SUM_C = ZEPSILON + DO K=1,NANG + SUM_S = SUM_S + SINTH(K)*FL1(IJ, K, M, ICHNK) + SUM_C = SUM_C + COSTH(K)*FL1(IJ, K, M, ICHNK) + END DO + THMEAN = ATAN2(SUM_S, SUM_C) + DO K=1,NANG + SUM1 = SUM1 + FL1(IJ, K, M, ICHNK)*DFIM(M) + SUM2 = SUM2 + COS(TH(K) - THMEAN)*FL1(IJ, K, M, ICHNK)*DFIM(M) + END DO + END DO + + IF (SUM1 > ZEPSILON) THEN + R1 = SUM2 / SUM1 + SIG_TH(IJ) = CONST_SIG*SQRT(2._JWRB*(1._JWRB - R1)) + ELSE + SIG_TH(IJ) = 0._JWRB + END IF + + + + END SUBROUTINE PEAK_ANG_CUF_HOIST_NEW +END MODULE PEAK_ANG_CUF_HOIST_NEW_MOD diff --git a/src/phys-scc-cuf-hoist/sbottom.cuf_hoist_new.F90 b/src/phys-scc-cuf-hoist/sbottom.cuf_hoist_new.F90 new file mode 100644 index 00000000..4bfafbd4 --- /dev/null +++ b/src/phys-scc-cuf-hoist/sbottom.cuf_hoist_new.F90 @@ -0,0 +1,110 @@ +! (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. +! +MODULE SBOTTOM_CUF_HOIST_NEW_MOD + CONTAINS + ATTRIBUTES(DEVICE) SUBROUTINE SBOTTOM_CUF_HOIST_NEW (KIJS, KIJL, FL1, FLD, SL, WAVNUM, DEPTH, BATHYMAX, GM1, NANG, NFRE_RED, & + & ICHNK, NCHNK, IJ) + + !SHALLOW + ! ---------------------------------------------------------------------- + + !**** *SBOTTOM* - COMPUTATION OF BOTTOM FRICTION. + + ! G.J.KOMEN AND Q.D.GAO + ! OPTIMIZED BY L.F. ZAMBRESKY + ! J. BIDLOT ECMWF FEBRUARY 1997 ADD SL IN SUBROUTINE CALL + + !* PURPOSE. + ! -------- + + ! COMPUTATION OF BOTTOM FRICTION DISSIPATION + + !** INTERFACE. + ! ---------- + + ! *CALL* *SBOTTOM (KIJS, KIJL, FL1, FLD, SL, WAVNUM, DEPTH) + ! *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 + ! *DEPTH* - WATER DEPTH + + ! METHOD. + ! ------- + + ! SEE REFERENCES. + + ! REFERENCES. + ! ----------- + + ! HASSELMANN ET AL, D. HYDR. Z SUPPL A12(1973) (JONSWAP) + ! BOUWS AND KOMEN, JPO 13(1983)1653-1658 + + ! ---------------------------------------------------------------------- + + USE cudafor + USE PARKIND_WAVE, ONLY: JWIM, JWRU, JWRB + + USE YOWPARAM, ONLY: NFRE + + + ! ---------------------------------------------------------------------- + + IMPLICIT NONE + + INTEGER(KIND=JWIM), PARAMETER :: NANG_loki_param = 24 + INTEGER(KIND=JWIM), PARAMETER :: NFRE_loki_param = 36 + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJS + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJL + REAL(KIND=JWRB), INTENT(IN) :: FL1(KIJL, NANG_loki_param, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: FLD(KIJL, NANG_loki_param, NFRE_loki_param) + REAL(KIND=JWRB), INTENT(INOUT) :: SL(KIJL, NANG_loki_param, NFRE_loki_param) + REAL(KIND=JWRB), INTENT(IN) :: WAVNUM(KIJL, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: DEPTH(KIJL, NCHNK) + + + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: IJ + INTEGER(KIND=JWIM) :: K + INTEGER(KIND=JWIM) :: M + REAL(KIND=JWRB) :: CONST + REAL(KIND=JWRB) :: ARG + REAL(KIND=JWRB) :: SBO + REAL(KIND=JWRB), VALUE, INTENT(IN) :: BATHYMAX + REAL(KIND=JWRB), VALUE, INTENT(IN) :: GM1 + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NANG + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NFRE_RED + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: ICHNK + INTEGER, VALUE, INTENT(IN) :: NCHNK + + ! ---------------------------------------------------------------------- + + + CONST = -2.0_JWRB*0.038_JWRB*GM1 + + DO M=1,NFRE_RED + IF (DEPTH(IJ, ICHNK) < BATHYMAX) THEN + ARG = 2.0_JWRB*DEPTH(IJ, ICHNK)*WAVNUM(IJ, M, ICHNK) + ARG = MIN(ARG, 50.0_JWRB) + SBO = CONST*WAVNUM(IJ, M, ICHNK) / SINH(ARG) + ELSE + SBO = 0.0_JWRB + END IF + + DO K=1,NANG + SL(IJ, K, M) = SL(IJ, K, M) + SBO*FL1(IJ, K, M, ICHNK) + FLD(IJ, K, M) = FLD(IJ, K, M) + SBO + END DO + END DO + + + + END SUBROUTINE SBOTTOM_CUF_HOIST_NEW +END MODULE SBOTTOM_CUF_HOIST_NEW_MOD diff --git a/src/phys-scc-cuf-hoist/sdepthlim.cuf_hoist_new.F90 b/src/phys-scc-cuf-hoist/sdepthlim.cuf_hoist_new.F90 new file mode 100644 index 00000000..03614412 --- /dev/null +++ b/src/phys-scc-cuf-hoist/sdepthlim.cuf_hoist_new.F90 @@ -0,0 +1,105 @@ +! (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. +! +MODULE SDEPTHLIM_CUF_HOIST_NEW_MOD + CONTAINS + ATTRIBUTES(DEVICE) SUBROUTINE SDEPTHLIM_CUF_HOIST_NEW (KIJS, KIJL, EMAXDPT, FL1, DELTH, DFIM, EPSMIN, FR, NANG, NFRE, WETAIL, & + & ICHNK, NCHNK, IJ) + ! ---------------------------------------------------------------------- + ! J. BIDLOT ECMWF NOVEMBER 2017 + + !* PURPOSE. + ! -------- + ! LIMITS THE SPECTRAL VARIANCE SUCH THAT THE TOTAL VARIANCE + ! DOES NOT EXCEED THE MAXIMUM WAVE VARIANCE ALLOWED FOR A GIVEN DEPTH + + !** INTERFACE. + ! ---------- + ! *CALL* *SDEPTHLIM((KIJS, KIJL, EMAXDPT, FL1) + ! *KIJS* - LOCAL INDEX OF FIRST GRIDPOINT + ! *KIJL* - LOCAL INDEX OF LAST GRIDPOIN + ! *EMAXDPT - MAXIMUM WAVE VARIANCE ALLOWED FOR A GIVEN DEPTH + ! *FL1* - SPECTRUM. + + + ! METHOD. + ! ------- + + ! EXTERNALS. + ! ---------- + + ! REFERENCE. + ! ---------- + ! NONE + + ! ---------------------------------------------------------------------- + USE cudafor + USE PARKIND_WAVE, ONLY: JWIM, JWRU, JWRB + + + + ! ---------------------------------------------------------------------- + IMPLICIT NONE + + INTEGER(KIND=JWIM), PARAMETER :: NANG_loki_param = 24 + INTEGER(KIND=JWIM), PARAMETER :: NFRE_loki_param = 36 + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJS + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJL + REAL(KIND=JWRB), INTENT(IN) :: EMAXDPT(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: FL1(KIJL, NANG_loki_param, NFRE_loki_param, NCHNK) + + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: IJ + INTEGER(KIND=JWIM) :: K + INTEGER(KIND=JWIM) :: M + REAL(KIND=JWRB) :: DELT25 + REAL(KIND=JWRB) :: EM + REAL(KIND=JWRB) :: TEMP + LOGICAL :: LLEPSMIN + REAL(KIND=JWRB), VALUE, INTENT(IN) :: DELTH + REAL(KIND=JWRB), INTENT(IN), DEVICE :: DFIM(NFRE_loki_param) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: EPSMIN + REAL(KIND=JWRB), INTENT(IN), DEVICE :: FR(NFRE_loki_param) + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NANG + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NFRE + REAL(KIND=JWRB), VALUE, INTENT(IN) :: WETAIL + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: ICHNK + INTEGER, VALUE, INTENT(IN) :: NCHNK + + ! ---------------------------------------------------------------------- + + + + EM = EPSMIN + DO M=1,NFRE + K = 1 + TEMP = FL1(IJ, K, M, ICHNK) + DO K=2,NANG + TEMP = TEMP + FL1(IJ, K, M, ICHNK) + END DO + EM = EM + DFIM(M)*TEMP + END DO + ! ---------------------------------------------------------------------- + + !* 3. ADD TAIL ENERGY. + ! ---------------- + + DELT25 = WETAIL*FR(NFRE)*DELTH + EM = EM + DELT25*TEMP + + EM = MIN(EMAXDPT(IJ, ICHNK) / EM, 1.0_JWRB) + + DO M=1,NFRE + DO K=1,NANG + FL1(IJ, K, M, ICHNK) = MAX(FL1(IJ, K, M, ICHNK)*EM, EPSMIN) + END DO + END DO + + + + END SUBROUTINE SDEPTHLIM_CUF_HOIST_NEW +END MODULE SDEPTHLIM_CUF_HOIST_NEW_MOD diff --git a/src/phys-scc-cuf-hoist/sdissip.cuf_hoist_new.F90 b/src/phys-scc-cuf-hoist/sdissip.cuf_hoist_new.F90 new file mode 100644 index 00000000..0ac8518a --- /dev/null +++ b/src/phys-scc-cuf-hoist/sdissip.cuf_hoist_new.F90 @@ -0,0 +1,120 @@ +! (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. +! +MODULE SDISSIP_CUF_HOIST_NEW_MOD + CONTAINS + ATTRIBUTES(DEVICE) SUBROUTINE SDISSIP_CUF_HOIST_NEW (KIJS, KIJL, FL1, FLD, SL, INDEP, WAVNUM, XK2CG, EMEAN, F1MEAN, XKMEAN, & + & UFRIC, COSWDIF, RAORW, CDIS, CDISVIS, CUMULW, DELTA_SDIS, G, INDICESSAT, IPHYS, IPSAT, MICHE, NANG, NDEPTH, NDIKCUMUL, NFRE, & + & NSDSNTH, RNU, SATWEIGHTS, SDSBR, SSDSC2, SSDSC3, SSDSC4, SSDSC5, SSDSC6, ZPI, ZPIFR, ICHNK, NCHNK, IJ) + ! ---------------------------------------------------------------------- + + !**** *SDISSIP* - COMPUTATION OF DEEP WATER DISSIPATION SOURCE FUNCTION. + + + !* PURPOSE. + ! -------- + ! COMPUTE DISSIPATION SOURCE FUNCTION AND STORE ADDITIVELY INTO + ! NET SOURCE FUNCTION ARRAY. ALSO COMPUTE FUNCTIONAL DERIVATIVE + ! OF DISSIPATION SOURCE FUNCTION. + + !** INTERFACE. + ! ---------- + + ! *CALL* *SDISSIP (KIJS, KIJL, FL1, FLD, SL, * + ! INDEP, WAVNUM, XK2CG, + ! EMEAN, F1MEAN, XKMEAN,* + ! 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 + ! *INDEP* - DEPTH INDEX + ! *WAVNUM* - WAVE NUMBER + ! *XK2CG* - (WAVNUM)**2 * GROUP SPEED + ! *EMEAN* - MEAN ENERGY DENSITY + ! *F1MEAN* - MEAN FREQUENCY BASED ON 1st MOMENT. + ! *XKMEAN* - MEAN WAVE NUMBER BASED ON 1st MOMENT. + ! *UFRIC* - FRICTION VELOCITY IN M/S. + ! *RAORW* - RATIO AIR DENSITY TO WATER DENSITY + ! *COSWDIF*- COS(TH(K)-WDWAVE(IJ)) + + ! ---------------------------------------------------------------------- + USE SDISSIP_JAN_CUF_HOIST_NEW_MOD, ONLY: SDISSIP_JAN_CUF_HOIST_NEW + USE SDISSIP_ARD_CUF_HOIST_NEW_MOD, ONLY: SDISSIP_ARD_CUF_HOIST_NEW + USE cudafor + USE PARKIND_WAVE, ONLY: JWIM, JWRU, JWRB + + + + ! ---------------------------------------------------------------------- + + IMPLICIT NONE + INTEGER(KIND=JWIM), PARAMETER :: NANG_loki_param = 24 + INTEGER(KIND=JWIM), PARAMETER :: NFRE_loki_param = 36 + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJS + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJL + REAL(KIND=JWRB), INTENT(IN) :: FL1(KIJL, NANG_loki_param, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: FLD(KIJL, NANG_loki_param, NFRE_loki_param) + REAL(KIND=JWRB), INTENT(INOUT) :: SL(KIJL, NANG_loki_param, NFRE_loki_param) + INTEGER(KIND=JWIM), INTENT(IN) :: INDEP(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: WAVNUM(KIJL, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: XK2CG(KIJL, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: EMEAN(KIJL) + REAL(KIND=JWRB), INTENT(IN) :: F1MEAN(KIJL) + REAL(KIND=JWRB), INTENT(IN) :: XKMEAN(KIJL) + REAL(KIND=JWRB), INTENT(IN) :: UFRIC(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: RAORW(KIJL) + REAL(KIND=JWRB), INTENT(IN) :: COSWDIF(KIJL, NANG_loki_param) + + REAL(KIND=JWRB), VALUE, INTENT(IN) :: CDIS + REAL(KIND=JWRB), VALUE, INTENT(IN) :: CDISVIS + REAL(KIND=JWRB), INTENT(IN), DEVICE :: CUMULW(NDEPTH, 0:NANG/2, NFRE_loki_param, NFRE_loki_param) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: DELTA_SDIS + REAL(KIND=JWRB), VALUE, INTENT(IN) :: G + INTEGER(KIND=JWIM), INTENT(IN), DEVICE :: INDICESSAT(NANG_loki_param, NSDSNTH*2+1) + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: IPHYS + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: IPSAT + REAL(KIND=JWRB), VALUE, INTENT(IN) :: MICHE + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NANG + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NDEPTH + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NDIKCUMUL + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NFRE + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NSDSNTH + REAL(KIND=JWRB), VALUE, INTENT(IN) :: RNU + REAL(KIND=JWRB), INTENT(IN), DEVICE :: SATWEIGHTS(NANG_loki_param, NSDSNTH*2+1) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SDSBR + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SSDSC2 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SSDSC3 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SSDSC4 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SSDSC5 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SSDSC6 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ZPI + REAL(KIND=JWRB), INTENT(IN), DEVICE :: ZPIFR(NFRE_loki_param) + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: ICHNK + INTEGER, VALUE, INTENT(IN) :: NCHNK + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: IJ + + ! ---------------------------------------------------------------------- + + + SELECT CASE (IPHYS) + CASE (0) + CALL SDISSIP_JAN_CUF_HOIST_NEW(KIJS, KIJL, FL1(:, :, :, :), FLD(:, :, :), SL(:, :, :), WAVNUM(:, :, :), EMEAN(:), & + & F1MEAN(:), XKMEAN(:), CDIS, CDISVIS, DELTA_SDIS, NANG, NFRE, RNU, ZPI, ICHNK, NCHNK, IJ) + + CASE (1) + CALL SDISSIP_ARD_CUF_HOIST_NEW(KIJS, KIJL, FL1(:, :, :, :), FLD(:, :, :), SL(:, :, :), INDEP(:, :), WAVNUM(:, :, :), & + & XK2CG(:, :, :), UFRIC(:, :), COSWDIF(:, :), RAORW(:), CUMULW(:, :, :, :), G, INDICESSAT(:, :), IPSAT, MICHE, NANG, & + & NDEPTH, NDIKCUMUL, NFRE, NSDSNTH, SATWEIGHTS(:, :), SDSBR, SSDSC2, SSDSC3, SSDSC4, SSDSC5, SSDSC6, ZPI, ZPIFR(:), ICHNK, & + & NCHNK, IJ) + END SELECT + + + END SUBROUTINE SDISSIP_CUF_HOIST_NEW +END MODULE SDISSIP_CUF_HOIST_NEW_MOD diff --git a/src/phys-scc-cuf-hoist/sdissip_ard.cuf_hoist_new.F90 b/src/phys-scc-cuf-hoist/sdissip_ard.cuf_hoist_new.F90 new file mode 100644 index 00000000..5c2fd804 --- /dev/null +++ b/src/phys-scc-cuf-hoist/sdissip_ard.cuf_hoist_new.F90 @@ -0,0 +1,235 @@ +! (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. +! +MODULE SDISSIP_ARD_CUF_HOIST_NEW_MOD + CONTAINS + ATTRIBUTES(DEVICE) SUBROUTINE SDISSIP_ARD_CUF_HOIST_NEW (KIJS, KIJL, FL1, FLD, SL, INDEP, WAVNUM, XK2CG, UFRIC, COSWDIF, & + & RAORW, CUMULW, G, INDICESSAT, IPSAT, MICHE, NANG, NDEPTH, NDIKCUMUL, NFRE, NSDSNTH, SATWEIGHTS, SDSBR, SSDSC2, SSDSC3, & + & SSDSC4, SSDSC5, SSDSC6, ZPI, ZPIFR, ICHNK, NCHNK, IJ) + ! ---------------------------------------------------------------------- + + !**** *SDISSIP_ARD* - COMPUTATION OF DISSIPATION SOURCE FUNCTION. + + ! LOTFI AOUF METEO FRANCE 2013 + ! FABRICE ARDHUIN IFREMER 2013 + + + !* PURPOSE. + ! -------- + ! COMPUTE DISSIPATION SOURCE FUNCTION AND STORE ADDITIVELY INTO + ! NET SOURCE FUNCTION ARRAY. ALSO COMPUTE FUNCTIONAL DERIVATIVE + ! OF DISSIPATION SOURCE FUNCTION. + + !** INTERFACE. + ! ---------- + + ! *CALL* *SDISSIP_ARD (KIJS, KIJL, FL1, FLD,SL,* + ! INDEP, WAVNUM, 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 + ! *INDEP* - DEPTH INDEX + ! *WAVNUM* - WAVE NUMBER + ! *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. + ! ---------- + + ! NONE. + + ! REFERENCE. + ! ---------- + + ! ARDHUIN et AL. JPO DOI:10.1175/20110JPO4324.1 + + + ! ---------------------------------------------------------------------- + USE cudafor + USE PARKIND_WAVE, ONLY: JWIM, JWRU, JWRB + + USE YOWFRED, ONLY: FR, TH + USE YOWPARAM, ONLY: NANG_PARAM + USE YOWPHYS, ONLY: SSDSBRF1, ISDSDTH, ISB, BRKPBCOEF + + + ! ---------------------------------------------------------------------- + + IMPLICIT NONE + + INTEGER(KIND=JWIM), PARAMETER :: NANG_loki_param = 24 + INTEGER(KIND=JWIM), PARAMETER :: NFRE_loki_param = 36 + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJS + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJL + + REAL(KIND=JWRB), INTENT(IN) :: FL1(KIJL, NANG_loki_param, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: FLD(KIJL, NANG_loki_param, NFRE_loki_param) + REAL(KIND=JWRB), INTENT(INOUT) :: SL(KIJL, NANG_loki_param, NFRE_loki_param) + INTEGER(KIND=JWIM), INTENT(IN) :: INDEP(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: WAVNUM(KIJL, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: XK2CG(KIJL, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: UFRIC(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: RAORW(KIJL) + REAL(KIND=JWRB), INTENT(IN) :: COSWDIF(KIJL, NANG_loki_param) + + + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: IJ + INTEGER(KIND=JWIM) :: K + INTEGER(KIND=JWIM) :: M + INTEGER(KIND=JWIM) :: I + INTEGER(KIND=JWIM) :: J + INTEGER(KIND=JWIM) :: M2 + INTEGER(KIND=JWIM) :: K2 + INTEGER(KIND=JWIM) :: KK + + REAL(KIND=JWRB) :: TPIINV + REAL(KIND=JWRB) :: TPIINVH + REAL(KIND=JWRB) :: TMP01 + REAL(KIND=JWRB) :: TMP03 + REAL(KIND=JWRB) :: EPSR + REAL(KIND=JWRB) :: SSDSC6M1 + REAL(KIND=JWRB) :: ZCOEF + REAL(KIND=JWRB) :: ZCOEFM1 + + + REAL(KIND=JWRB) :: SSDSC2_SIG + REAL(KIND=JWRB) :: FACTURB + REAL(KIND=JWRB) :: BTH + REAL(KIND=JWRB) :: BTH0 + REAL(KIND=JWRB) :: SCUMUL(NANG_PARAM) + REAL(KIND=JWRB) :: D(NANG_PARAM) + + REAL(KIND=JWRB) :: RENEWALFREQ + INTEGER :: FOO + REAL(KIND=JWRB), INTENT(IN), DEVICE :: CUMULW(NDEPTH, 0:NANG/2, NFRE_loki_param, NFRE_loki_param) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: G + INTEGER(KIND=JWIM), INTENT(IN), DEVICE :: INDICESSAT(NANG_loki_param, NSDSNTH*2+1) + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: IPSAT + REAL(KIND=JWRB), VALUE, INTENT(IN) :: MICHE + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NANG + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NDEPTH + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NDIKCUMUL + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NFRE + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NSDSNTH + REAL(KIND=JWRB), INTENT(IN), DEVICE :: SATWEIGHTS(NANG_loki_param, NSDSNTH*2+1) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SDSBR + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SSDSC2 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SSDSC3 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SSDSC4 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SSDSC5 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SSDSC6 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ZPI + REAL(KIND=JWRB), INTENT(IN), DEVICE :: ZPIFR(NFRE_loki_param) + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: ICHNK + INTEGER, VALUE, INTENT(IN) :: NCHNK + ! ---------------------------------------------------------------------- + + + ! INITIALISATION + + FOO = NDEPTH ! necessary for Loki ... + EPSR = SQRT(SDSBR) + + TPIINV = 1.0_JWRB / ZPI + TPIINVH = 0.5_JWRB*TPIINV + TMP03 = 1.0_JWRB / (SDSBR*MICHE) + SSDSC6M1 = 1._JWRB - SSDSC6 + + + DO M=1,NFRE + + ! SATURATION TERM + SSDSC2_SIG = SSDSC2*ZPIFR(M) + ZCOEF = SSDSC2_SIG*SSDSC6 + ZCOEFM1 = SSDSC2_SIG*SSDSC6M1 + + ! COMPUTE SATURATION SPECTRUM + BTH0 = 0.0_JWRB + + DO K=1,NANG + BTH = 0.0_JWRB + ! integrates in directional sector + DO K2=1,NSDSNTH*2 + 1 + KK = INDICESSAT(K, K2) + BTH = BTH + SATWEIGHTS(K, K2)*FL1(IJ, KK, M, ICHNK) + END DO + BTH = BTH*WAVNUM(IJ, M, ICHNK)*TPIINV*XK2CG(IJ, M, ICHNK) + BTH0 = MAX(BTH0, BTH) + + D(K) = ZCOEFM1*MAX(0._JWRB, BTH*TMP03 - SSDSC4)**IPSAT + + SCUMUL(K) = MAX(SQRT(ABS(BTH)) - EPSR, 0._JWRB)**2 + END DO + + DO K=1,NANG + ! cumulative term + D(K) = D(K) + ZCOEF*MAX(0._JWRB, BTH0*TMP03 - SSDSC4)**IPSAT + IF (BTH0 <= SDSBR) THEN + SCUMUL(K) = 0._JWRB + END IF + + END DO + + IF (M > NDIKCUMUL) THEN + ! CUMULATIVE TERM + IF (SSDSC3 /= 0.0_JWRB) THEN + + DO K=1,NANG + ! Correction of saturation level for shallow-water kinematics + ! Cumulative effect based on lambda (breaking probability is + ! the expected rate of sweeping by larger breaking waves) + + RENEWALFREQ = 0.0_JWRB + + DO M2=1,M - NDIKCUMUL + DO K2=1,NANG + KK = ABS(K2 - K) + IF (KK > NANG / 2) KK = KK - NANG / 2 + ! Integrates over frequencies M2 and directions K2 to + ! Integration is performed from M2=1 to a frequency lower than M: IK-NDIKCUMUL + RENEWALFREQ = RENEWALFREQ + CUMULW(INDEP(IJ, ICHNK), KK, M2, M)*SCUMUL(K2) + END DO + END DO + + D(K) = D(K) + RENEWALFREQ + END DO + END IF + END IF + + ! WAVE-TURBULENCE INTERACTION TERM + IF (SSDSC5 /= 0.0_JWRB) THEN + TMP01 = 2._JWRB*SSDSC5 / G + FACTURB = TMP01*RAORW(IJ)*UFRIC(IJ, ICHNK)*UFRIC(IJ, ICHNK) + DO K=1,NANG + D(K) = D(K) - ZPIFR(M)*WAVNUM(IJ, M, ICHNK)*FACTURB*COSWDIF(IJ, K) + END DO + END IF + + + ! ADD ALL CONTRIBUTIONS TO SOURCE TERM + DO K=1,NANG + SL(IJ, K, M) = SL(IJ, K, M) + D(K)*FL1(IJ, K, M, ICHNK) + FLD(IJ, K, M) = FLD(IJ, K, M) + D(K) + END DO + END DO + + + + END SUBROUTINE SDISSIP_ARD_CUF_HOIST_NEW +END MODULE SDISSIP_ARD_CUF_HOIST_NEW_MOD diff --git a/src/phys-scc-cuf-hoist/sdissip_jan.cuf_hoist_new.F90 b/src/phys-scc-cuf-hoist/sdissip_jan.cuf_hoist_new.F90 new file mode 100644 index 00000000..c9536de5 --- /dev/null +++ b/src/phys-scc-cuf-hoist/sdissip_jan.cuf_hoist_new.F90 @@ -0,0 +1,145 @@ +! (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. +! +MODULE SDISSIP_JAN_CUF_HOIST_NEW_MOD + CONTAINS + ATTRIBUTES(DEVICE) SUBROUTINE SDISSIP_JAN_CUF_HOIST_NEW (KIJS, KIJL, FL1, FLD, SL, WAVNUM, EMEAN, F1MEAN, XKMEAN, CDIS, & + & CDISVIS, DELTA_SDIS, NANG, NFRE, RNU, ZPI, ICHNK, NCHNK, IJ) + + ! ---------------------------------------------------------------------- + + !**** *SDISSIP_JAN* - COMPUTATION OF DISSIPATION SOURCE FUNCTION. + + ! S.D.HASSELMANN. + ! MODIFIED TO SHALLOW WATER : G. KOMEN , P. JANSSEN + ! OPTIMIZATION : L. ZAMBRESKY + ! J. BIDLOT ECMWF FEBRUARY 1997 ADD SL IN SUBROUTINE CALL + ! J. BIDLOT ECMWF NOVEMBER 2004 REFORMULATION BASED ON XKMEAN + ! AND F1MEAN. + ! AUGUST 2020 Added small viscous dissipation term + + !* PURPOSE. + ! -------- + ! COMPUTE DISSIPATION SOURCE FUNCTION AND STORE ADDITIVELY INTO + ! NET SOURCE FUNCTION ARRAY. ALSO COMPUTE FUNCTIONAL DERIVATIVE + ! OF DISSIPATION SOURCE FUNCTION. + + !** INTERFACE. + ! ---------- + + ! *CALL* *SDISSIP_JAN (KIJS, KIJ, FL1, FLD, SL, + ! WAVNUM, + ! EMEAN,F1MEAN, XKMEAN,)* + ! *FL1* - SPECTRUM. + ! *FLD* - DIAGONAL MATRIX OF FUNCTIONAL DERIVATIVE + ! *SL* - TOTAL SOURCE FUNCTION ARRAY + ! *KIJS* - INDEX OF FIRST GRIDPOINT + ! *KIJL* - INDEX OF LAST GRIDPOINT + ! *WAVNUM* - WAVE NUMBER + ! *EMEAN* - MEAN ENERGY DENSITY + ! *F1MEAN* - MEAN FREQUENCY BASED ON 1st MOMENT. + ! *XKMEAN* - MEAN WAVE NUMBER BASED ON 1st MOMENT. + + + ! METHOD. + ! ------- + + ! SEE REFERENCES. + + ! EXTERNALS. + ! ---------- + + ! NONE. + + ! REFERENCE. + ! ---------- + + ! G.KOMEN, S. HASSELMANN AND K. HASSELMANN, ON THE EXISTENCE + ! OF A FULLY DEVELOPED WINDSEA SPECTRUM, JGR, 1984. + + ! --------------------------------------------------------------------- + + USE cudafor + USE PARKIND_WAVE, ONLY: JWIM, JWRU, JWRB + + USE YOWFRED, ONLY: FR, DFIM, DELTH, FRATIO + USE YOWPCONS, ONLY: ZPI4GM2, G + + + ! ---------------------------------------------------------------------- + + IMPLICIT NONE + + INTEGER(KIND=JWIM), PARAMETER :: NANG_loki_param = 24 + INTEGER(KIND=JWIM), PARAMETER :: NFRE_loki_param = 36 + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJS + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJL + + REAL(KIND=JWRB), INTENT(IN) :: FL1(KIJL, NANG_loki_param, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: FLD(KIJL, NANG_loki_param, NFRE_loki_param) + REAL(KIND=JWRB), INTENT(INOUT) :: SL(KIJL, NANG_loki_param, NFRE_loki_param) + REAL(KIND=JWRB), INTENT(IN) :: WAVNUM(KIJL, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: EMEAN(KIJL) + REAL(KIND=JWRB), INTENT(IN) :: F1MEAN(KIJL) + REAL(KIND=JWRB), INTENT(IN) :: XKMEAN(KIJL) + + + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: IJ + INTEGER(KIND=JWIM) :: K + INTEGER(KIND=JWIM) :: M + + REAL(KIND=JWRB) :: SCDFM + REAL(KIND=JWRB) :: CONSD + REAL(KIND=JWRB) :: CONSS + REAL(KIND=JWRB) :: DELTA_SDISM1 + REAL(KIND=JWRB) :: CVIS + REAL(KIND=JWRB) :: TEMP1 + REAL(KIND=JWRB) :: SDS + REAL(KIND=JWRB) :: X + REAL(KIND=JWRB) :: XK2 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: CDIS + REAL(KIND=JWRB), VALUE, INTENT(IN) :: CDISVIS + REAL(KIND=JWRB), VALUE, INTENT(IN) :: DELTA_SDIS + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NANG + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NFRE + REAL(KIND=JWRB), VALUE, INTENT(IN) :: RNU + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ZPI + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: ICHNK + INTEGER, VALUE, INTENT(IN) :: NCHNK + + ! ---------------------------------------------------------------------- + + + !* 1. ADDING DISSIPATION AND ITS FUNCTIONAL DERIVATIVE TO NET SOURCE + !* FUNCTION AND NET SOURCE FUNCTION DERIVATIVE. + ! -------------------------------------------------------------- + + DELTA_SDISM1 = 1.0_JWRB - DELTA_SDIS + + CONSS = CDIS*ZPI + + SDS = CONSS*F1MEAN(IJ)*EMEAN(IJ)**2*XKMEAN(IJ)**4 + + DO M=1,NFRE + X = WAVNUM(IJ, M, ICHNK) / XKMEAN(IJ) + XK2 = WAVNUM(IJ, M, ICHNK)**2 + + CVIS = RNU*CDISVIS + TEMP1 = SDS*X*(DELTA_SDISM1 + DELTA_SDIS*X) + CVIS*XK2 + + DO K=1,NANG + FLD(IJ, K, M) = FLD(IJ, K, M) + TEMP1 + SL(IJ, K, M) = SL(IJ, K, M) + TEMP1*FL1(IJ, K, M, ICHNK) + END DO + + END DO + + + + END SUBROUTINE SDISSIP_JAN_CUF_HOIST_NEW +END MODULE SDISSIP_JAN_CUF_HOIST_NEW_MOD diff --git a/src/phys-scc-cuf-hoist/sdiwbk.cuf_hoist_new.F90 b/src/phys-scc-cuf-hoist/sdiwbk.cuf_hoist_new.F90 new file mode 100644 index 00000000..304ded3f --- /dev/null +++ b/src/phys-scc-cuf-hoist/sdiwbk.cuf_hoist_new.F90 @@ -0,0 +1,138 @@ +! (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. +! +MODULE SDIWBK_CUF_HOIST_NEW_MOD + CONTAINS + ATTRIBUTES(DEVICE) SUBROUTINE SDIWBK_CUF_HOIST_NEW (KIJS, KIJL, FL1, FLD, SL, DEPTH, EMAXDPT, EMEAN, F1MEAN, LBIWBK, NANG, & + & NFRE_RED, ICHNK, NCHNK, IJ) + + ! ---------------------------------------------------------------------- + + !**** *SDIWBK* - COMPUTATION OF BOTTOM-INDUCED WAVE BREAKING DISSIPATION + + + !* PURPOSE. + ! -------- + ! COMPUTE BOTTOM-INDUCED DISSIPATION SOURCE FUNCTION AND STORE ADDITIVELY INTO + ! NET SOURCE FUNCTION ARRAY. ALSO COMPUTE FUNCTIONAL DERIVATIVE + ! OF DISSIPATION SOURCE FUNCTION. + + !** INTERFACE. + ! ---------- + + ! *CALL* *SDIWBK (KIJS, KIJL, FL1, FLD, SL, DEPTH, EMAXDPT, EMEAN, F1MEAN)* + ! *KIJS* - INDEX OF FIRST GRIDPOINT + ! *KIJL* - INDEX OF LAST GRIDPOINT + ! *FL1* - SPECTRUM. + ! *FLD* - DIAGONAL MATRIX OF FUNCTIONAL DERIVATIVE + ! *SL* - TOTAL SOURCE FUNCTION ARRAY + ! *DEPTH* - WATER DEPTH + ! *EMAXDPT* - MAXIMUM WAVE VARIANCE ALLOWED FOR A GIVEN DEPTH + ! *EMEAN* - MEAN ENERGY DENSITY + ! *F1MEAN* - MEAN FREQUENCY BASED ON 1st MOMENT. + + ! METHOD. + ! ------- + + ! SEE REFERENCES. + + ! EXTERNALS. + ! ---------- + + ! NONE. + + ! REFERENCE. + ! ---------- + + ! ---------------------------------------------------------------------- + + USE cudafor + USE PARKIND_WAVE, ONLY: JWIM, JWRU, JWRB + + USE YOWPARAM, ONLY: NFRE + + + ! ---------------------------------------------------------------------- + + IMPLICIT NONE + + INTEGER(KIND=JWIM), PARAMETER :: NANG_loki_param = 24 + INTEGER(KIND=JWIM), PARAMETER :: NFRE_loki_param = 36 + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJS + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJL + REAL(KIND=JWRB), INTENT(IN) :: FL1(KIJL, NANG_loki_param, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: FLD(KIJL, NANG_loki_param, NFRE_loki_param) + REAL(KIND=JWRB), INTENT(INOUT) :: SL(KIJL, NANG_loki_param, NFRE_loki_param) + REAL(KIND=JWRB), INTENT(IN) :: DEPTH(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: EMAXDPT(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: EMEAN(KIJL) + REAL(KIND=JWRB), INTENT(IN) :: F1MEAN(KIJL) + + + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: IJ + INTEGER(KIND=JWIM) :: K + INTEGER(KIND=JWIM) :: M + INTEGER(KIND=JWIM) :: IC + REAL(KIND=JWRB) :: ALPH + REAL(KIND=JWRB) :: ARG + REAL(KIND=JWRB) :: Q + REAL(KIND=JWRB) :: Q_OLD + REAL(KIND=JWRB) :: REL_ERR + REAL(KIND=JWRB) :: EXPQ + REAL(KIND=JWRB) :: SDS + + REAL, PARAMETER :: ALPH_B_J = 1.0_JWRB + REAL, PARAMETER :: COEF_B_J = 2*ALPH_B_J + REAL, PARAMETER :: DEPTHTRS = 50.0_JWRB + LOGICAL, VALUE, INTENT(IN) :: LBIWBK + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NANG + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NFRE_RED + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: ICHNK + INTEGER, VALUE, INTENT(IN) :: NCHNK + + ! ---------------------------------------------------------------------- + + + !* 1. ADDING DISSIPATION AND ITS FUNCTIONAL DERIVATIVE TO NET SOURCE + !* FUNCTION AND NET SOURCE FUNCTION DERIVATIVE. + ! -------------------------------------------------------------- + + + IF (LBIWBK) THEN + ! (FOLLOWING BATTJES-JANSSEN AND BEJI) + IF (DEPTH(IJ, ICHNK) < DEPTHTRS) THEN + ALPH = 2.0_JWRB*EMAXDPT(IJ, ICHNK) / EMEAN(IJ) + ARG = MIN(ALPH, 50.0_JWRB) + Q_OLD = EXP(-ARG) + ! USE NEWTON-RAPHSON METHOD + DO IC=1,15 + EXPQ = EXP(-ARG*(1.0_JWRB - Q_OLD)) + Q = Q_OLD - (EXPQ - Q_OLD) / (ARG*EXPQ - 1.0_JWRB) + REL_ERR = ABS(Q - Q_OLD) / Q_OLD + IF (REL_ERR < 0.00001_JWRB) EXIT + Q_OLD = Q + END DO + Q = MIN(Q, 1.0_JWRB) + SDS = COEF_B_J*ALPH*Q*F1MEAN(IJ) + END IF + + DO M=1,NFRE_RED + DO K=1,NANG + IF (DEPTH(IJ, ICHNK) < DEPTHTRS) THEN + SL(IJ, K, M) = SL(IJ, K, M) - SDS*FL1(IJ, K, M, ICHNK) + FLD(IJ, K, M) = FLD(IJ, K, M) - SDS + END IF + END DO + END DO + + END IF + + + + END SUBROUTINE SDIWBK_CUF_HOIST_NEW +END MODULE SDIWBK_CUF_HOIST_NEW_MOD diff --git a/src/phys-scc-cuf-hoist/setice.cuf_hoist_new.F90 b/src/phys-scc-cuf-hoist/setice.cuf_hoist_new.F90 new file mode 100644 index 00000000..c3b907c1 --- /dev/null +++ b/src/phys-scc-cuf-hoist/setice.cuf_hoist_new.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. +! + +!----------------------------------------------------------------------- +MODULE SETICE_CUF_HOIST_NEW_MOD + CONTAINS + ATTRIBUTES(DEVICE) SUBROUTINE SETICE_CUF_HOIST_NEW (KIJS, KIJL, FL1, CICOVER, COSWDIF, CITHRSH, EPSMIN, FLMIN, NANG, NFRE, & + & ICHNK, NCHNK, IJ) + + !----------------------------------------------------------------------- + + !**** *SETICE* ROUTINE TO SET SPECTRA ON ICE TO NOISE LEVEL. + + ! R.PORTZ MPI OKT.1992 + ! J. BIDLOT ECMWF JUNE 1996 MESSAGE PASSING + + ! PURPOSE. + ! ------- + + ! *SETICE* SET ICE SPECTRA (FL1) TO NOISE LEVEL + + !** INTERFACE. + ! ---------- + + ! *CALL* *SETICE(KIJS, KIJL, FL1, CICOVER, WSWAVE, COSWDIF)* + ! *KIJS* - LOCAL INDEX OF FIRST GRIDPOINT + ! *KIJL* - LOCAL INDEX OF LAST GRIDPOINT + ! *FL1* - SPECTRA + ! *CICOVER* - SEA ICE COVER + ! *WSWAVE* - WIND SPEED. + ! *COSWDIF* - COS(TH(K)-WDWAVE(IJ)) + + ! ---------------------------------------------------------------------- + + USE cudafor + USE PARKIND_WAVE, ONLY: JWIM, JWRU, JWRB + + + + ! ---------------------------------------------------------------------- + IMPLICIT NONE + + INTEGER(KIND=JWIM), PARAMETER :: NANG_loki_param = 24 + INTEGER(KIND=JWIM), PARAMETER :: NFRE_loki_param = 36 + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJS + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJL + REAL(KIND=JWRB), INTENT(INOUT) :: FL1(KIJL, NANG_loki_param, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: CICOVER(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: COSWDIF(KIJL, NANG_loki_param) + + + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: IJ + INTEGER(KIND=JWIM) :: M + INTEGER(KIND=JWIM) :: K + + REAL(KIND=JWRB) :: CIREDUC + REAL(KIND=JWRB) :: TEMP + REAL(KIND=JWRB) :: ICEFREE + REAL(KIND=JWRB), VALUE, INTENT(IN) :: CITHRSH + REAL(KIND=JWRB), VALUE, INTENT(IN) :: EPSMIN + REAL(KIND=JWRB), VALUE, INTENT(IN) :: FLMIN + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NANG + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NFRE + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: ICHNK + INTEGER, VALUE, INTENT(IN) :: NCHNK + ! ---------------------------------------------------------------------- + + + !* 1. SET SPECTRA TO NOISE LEVEL OVER ICE POINTS. + ! ---------------------------------------------- + + + IF (CICOVER(IJ, ICHNK) > CITHRSH) THEN + CIREDUC = MAX(EPSMIN, (1.0_JWRB - CICOVER(IJ, ICHNK))) + ICEFREE = 0.0_JWRB + ELSE + CIREDUC = 0.0_JWRB + ICEFREE = 1.0_JWRB + END IF + + TEMP = CIREDUC*FLMIN + DO M=1,NFRE + DO K=1,NANG + FL1(IJ, K, M, ICHNK) = FL1(IJ, K, M, ICHNK)*ICEFREE + TEMP*MAX(0.0_JWRB, COSWDIF(IJ, K))**2 + END DO + END DO + + + + END SUBROUTINE SETICE_CUF_HOIST_NEW +END MODULE SETICE_CUF_HOIST_NEW_MOD diff --git a/src/phys-scc-cuf-hoist/sinflx.cuf_hoist_new.F90 b/src/phys-scc-cuf-hoist/sinflx.cuf_hoist_new.F90 new file mode 100644 index 00000000..fb172066 --- /dev/null +++ b/src/phys-scc-cuf-hoist/sinflx.cuf_hoist_new.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. +! +MODULE SINFLX_CUF_HOIST_NEW_MOD + CONTAINS + ATTRIBUTES(DEVICE) SUBROUTINE SINFLX_CUF_HOIST_NEW (ICALL, KIJS, KIJL, LUPDTUS, FL1, WAVNUM, 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, ABMAX, ABMIN, ACD, ACDLIN, ALPHA, ALPHAMAX, ALPHAMIN, ALPHAPMAX, ANG_GC_A, ANG_GC_B, & + & ANG_GC_C, BCD, BCDLIN, BETAMAXOXKAPPA2, BMAXOKAP, C2OSQRTVG_GC, CDMAX, CHNKMIN_U, CITHRSH_TAIL, CM_GC, COSTH, DELKCC_GC_NS, & + & DELKCC_OMXKM3_GC, DELTH, DFIM, DFIMOFR, DTHRN_A, DTHRN_U, EPS1, EPSMIN, EPSUS, FLOGSPRDM1, FR, FR5, FRIC, FRTAIL, G, & + & GAMNCONST, GM1, IAB, ICODE, ICODE_CPL, IDAMPING, IPHYS, JTOT_TAUHF, LLCAPCHNK, LLGCBZ0, LLNORMAGAM, LWCOU, NANG, NFRE, & + & NWAV_GC, OM3GMKM_GC, OMEGA_GC, OMXKM3_GC, RHOWG_DFIM, RN1_RN, RNU, RNUM, SINTH, SQRTGOSURFT, SWELLF, SWELLF2, SWELLF3, & + & SWELLF4, SWELLF5, SWELLF6, SWELLF7, SWELLF7M1, SWELLFT, TAILFACTOR, TAILFACTOR_PM, TAUWSHELTER, TH, WETAIL, WSPMIN, WTAUHF, & + & X0TAUHF, XKAPPA, XKMSQRTVGOC2_GC, XKM_GC, XK_GC, XLOGKRATIOM1_GC, XNLEV, Z0RAT, Z0TUBMAX, ZALP, ZPI, ZPI4GM1, ZPI4GM2, & + & ZPIFR, ICHNK, NCHNK, IJ, RNFAC, TMP_EM, STRESSO_TAUHF, STRESSO_PHIHF, STRESSO_UST) + + ! ---------------------------------------------------------------------- + + !**** *SINFLX* - UPDATE STRESS AND COMPUTE WIND INPUT SOURCE TERM. + + ! ---------------------------------------------------------------------- + + USE STRESSO_CUF_HOIST_NEW_MOD, ONLY: STRESSO_CUF_HOIST_NEW + USE SINPUT_CUF_HOIST_NEW_MOD, ONLY: SINPUT_CUF_HOIST_NEW + USE HALPHAP_CUF_HOIST_NEW_MOD, ONLY: HALPHAP_CUF_HOIST_NEW + USE FRCUTINDEX_CUF_HOIST_NEW_MOD, ONLY: FRCUTINDEX_CUF_HOIST_NEW + USE FEMEANWS_CUF_HOIST_NEW_MOD, ONLY: FEMEANWS_CUF_HOIST_NEW + USE AIRSEA_CUF_HOIST_NEW_MOD, ONLY: AIRSEA_CUF_HOIST_NEW + USE cudafor + USE PARKIND_WAVE, ONLY: JWIM, JWRU, JWRB + + + + ! ---------------------------------------------------------------------- + + IMPLICIT NONE + INTEGER(KIND=JWIM), PARAMETER :: NANG_loki_param = 24 + INTEGER(KIND=JWIM), PARAMETER :: NFRE_loki_param = 36 + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: ICALL !! CALL NUMBER. + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJS !! GRID POINT INDEXES. + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJL !! GRID POINT INDEXES. + + LOGICAL, VALUE, INTENT(IN) :: LUPDTUS !! IF TRUE UFRIC AND Z0M WILL BE UPDATED (CALLING AIRSEA). + + REAL(KIND=JWRB), INTENT(INOUT) :: FL1(KIJL, NANG_loki_param, NFRE_loki_param, NCHNK) !! WAVE SPECTRUM. + REAL(KIND=JWRB), INTENT(IN) :: WAVNUM(KIJL, NFRE_loki_param, NCHNK) !! WAVE NUMBER. + REAL(KIND=JWRB), INTENT(IN) :: CINV(KIJL, NFRE_loki_param, NCHNK) !! INVERSE PHASE VELOCITY. + REAL(KIND=JWRB), INTENT(IN) :: XK2CG(KIJL, NFRE_loki_param, NCHNK) !! (WAVNUM)**2 * GROUP SPPED. + REAL(KIND=JWRB), INTENT(INOUT) :: WSWAVE(KIJL, NCHNK) !! WIND SPEED IN M/S. + REAL(KIND=JWRB), INTENT(IN) :: WDWAVE(KIJL, NCHNK) !! WIND DIRECTION IN RADIANS IN OCEANOGRAPHIC NOTATION. + REAL(KIND=JWRB), INTENT(IN) :: AIRD(KIJL, NCHNK) !! AIR DENSITY (KG/M**3). + REAL(KIND=JWRB), INTENT(IN) :: RAORW(KIJL) !! RATIO AIR DENSITY TO WATER DENSITY. + REAL(KIND=JWRB), INTENT(IN) :: WSTAR(KIJL, NCHNK) !! FREE CONVECTION VELOCITY SCALE (M/S) + REAL(KIND=JWRB), INTENT(IN) :: CICOVER(KIJL, NCHNK) !! SEA ICE COVER. + REAL(KIND=JWRB), INTENT(IN) :: COSWDIF(KIJL, NANG_loki_param) !! COS(TH(K)-WDWAVE(IJ)) + REAL(KIND=JWRB), INTENT(IN) :: SINWDIF2(KIJL, NANG_loki_param) !! SIN(TH(K)-WDWAVE(IJ))**2 + REAL(KIND=JWRB), INTENT(IN) :: FMEAN(KIJL) !! MEAN FREQUENCY. + REAL(KIND=JWRB), INTENT(INOUT) :: HALP(KIJL) !! 1/2 PHILLIPS PARAMETER + REAL(KIND=JWRB), INTENT(OUT) :: FMEANWS(KIJL) !! MEAN FREQUENCY OF THE WINDSEA. + REAL(KIND=JWRB), INTENT(IN) :: FLM(KIJL, NANG_loki_param) !! SPECTAL DENSITY MINIMUM VALUE + REAL(KIND=JWRB), INTENT(INOUT) :: UFRIC(KIJL, NCHNK) !! FRICTION VELOCITY IN M/S. + REAL(KIND=JWRB), INTENT(INOUT) :: TAUW(KIJL, NCHNK) !! WAVE STRESS IN (M/S)**2 + REAL(KIND=JWRB), INTENT(INOUT) :: TAUWDIR(KIJL, NCHNK) !! WAVE STRESS DIRECTION. + REAL(KIND=JWRB), INTENT(INOUT) :: Z0M(KIJL, NCHNK) !! ROUGHNESS LENGTH IN M. + REAL(KIND=JWRB), INTENT(INOUT) :: Z0B(KIJL, NCHNK) !! BACKGROUND ROUGHNESS LENGTH. + REAL(KIND=JWRB), INTENT(INOUT) :: CHRNCK(KIJL, NCHNK) !! CHARNOCK COEFFICIENT. + + REAL(KIND=JWRB), INTENT(OUT) :: PHIWA(KIJL) !! ENERGY FLUX FROM WIND INTO WAVES. + REAL(KIND=JWRB), INTENT(OUT) :: FLD(KIJL, NANG_loki_param, NFRE_loki_param) !! DIAGONAL MATRIX OF FUNCTIONAL DERIVATIVE. + REAL(KIND=JWRB), INTENT(OUT) :: SL(KIJL, NANG_loki_param, NFRE_loki_param) !! TOTAL SOURCE FUNCTION ARRAY. + REAL(KIND=JWRB), INTENT(OUT) :: SPOS(KIJL, NANG_loki_param, NFRE_loki_param) !! POSITIVE SINPUT ONLY. + + INTEGER(KIND=JWIM), INTENT(OUT) :: MIJ(KIJL, NCHNK) !! LAST FREQUENCY INDEX OF THE PROGNOSTIC RANGE. + + REAL(KIND=JWRB), INTENT(OUT) :: RHOWGDFTH(KIJL, NFRE_loki_param) !! WATER DENSITY * G * DF * DTHETA + + REAL(KIND=JWRB), INTENT(OUT) :: XLLWS(KIJL, NANG_loki_param, NFRE_loki_param, NCHNK) !! TOTAL WINDSEA MASK FROM INPUT SOURCE TERM. + + + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: IJ + INTEGER(KIND=JWIM) :: K + INTEGER(KIND=JWIM) :: IUSFG + INTEGER(KIND=JWIM) :: ICODE_WND + INTEGER(KIND=JWIM) :: NGST + + REAL(KIND=JWRB), INTENT(INOUT) :: RNFAC(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: TMP_EM(KIJL, NCHNK) + + LOGICAL :: LLPHIWA + LOGICAL :: LLSNEG + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ABMAX + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ABMIN + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ACD + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ACDLIN + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ALPHA + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ALPHAMAX + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ALPHAMIN + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ALPHAPMAX + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ANG_GC_A + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ANG_GC_B + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ANG_GC_C + REAL(KIND=JWRB), VALUE, INTENT(IN) :: BCD + REAL(KIND=JWRB), VALUE, INTENT(IN) :: BCDLIN + REAL(KIND=JWRB), VALUE, INTENT(IN) :: BETAMAXOXKAPPA2 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: BMAXOKAP + REAL(KIND=JWRB), INTENT(IN), DEVICE :: C2OSQRTVG_GC(NWAV_GC) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: CDMAX + REAL(KIND=JWRB), VALUE, INTENT(IN) :: CHNKMIN_U + REAL(KIND=JWRB), VALUE, INTENT(IN) :: CITHRSH_TAIL + REAL(KIND=JWRB), INTENT(IN), DEVICE :: CM_GC(NWAV_GC) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: COSTH(NFRE_loki_param) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: DELKCC_GC_NS(NWAV_GC) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: DELKCC_OMXKM3_GC(NWAV_GC) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: DELTH + REAL(KIND=JWRB), INTENT(IN), DEVICE :: DFIM(NFRE_loki_param) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: DFIMOFR(NFRE_loki_param) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: DTHRN_A + REAL(KIND=JWRB), VALUE, INTENT(IN) :: DTHRN_U + REAL(KIND=JWRB), VALUE, INTENT(IN) :: EPS1 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: EPSMIN + REAL(KIND=JWRB), VALUE, INTENT(IN) :: EPSUS + REAL(KIND=JWRB), VALUE, INTENT(IN) :: FLOGSPRDM1 + REAL(KIND=JWRB), INTENT(IN), DEVICE :: FR(NFRE_loki_param) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: FR5(NFRE_loki_param) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: FRIC + REAL(KIND=JWRB), VALUE, INTENT(IN) :: FRTAIL + REAL(KIND=JWRB), VALUE, INTENT(IN) :: G + REAL(KIND=JWRB), VALUE, INTENT(IN) :: GAMNCONST + REAL(KIND=JWRB), VALUE, INTENT(IN) :: GM1 + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: IAB + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: ICODE + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: ICODE_CPL + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: IDAMPING + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: IPHYS + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: JTOT_TAUHF + LOGICAL, VALUE, INTENT(IN) :: LLCAPCHNK + LOGICAL, VALUE, INTENT(IN) :: LLGCBZ0 + LOGICAL, VALUE, INTENT(IN) :: LLNORMAGAM + LOGICAL, VALUE, INTENT(IN) :: LWCOU + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NANG + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NFRE + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NWAV_GC + REAL(KIND=JWRB), INTENT(IN), DEVICE :: OM3GMKM_GC(NWAV_GC) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: OMEGA_GC(NWAV_GC) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: OMXKM3_GC(NWAV_GC) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: RHOWG_DFIM(NFRE_loki_param) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: RN1_RN + REAL(KIND=JWRB), VALUE, INTENT(IN) :: RNU + REAL(KIND=JWRB), VALUE, INTENT(IN) :: RNUM + REAL(KIND=JWRB), INTENT(IN), DEVICE :: SINTH(NFRE_loki_param) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SQRTGOSURFT + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SWELLF + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SWELLF2 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SWELLF3 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SWELLF4 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SWELLF5 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SWELLF6 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SWELLF7 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SWELLF7M1 + REAL(KIND=JWRB), INTENT(IN) :: SWELLFT(IAB) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: TAILFACTOR + REAL(KIND=JWRB), VALUE, INTENT(IN) :: TAILFACTOR_PM + REAL(KIND=JWRB), VALUE, INTENT(IN) :: TAUWSHELTER + REAL(KIND=JWRB), INTENT(IN), DEVICE :: TH(NFRE_loki_param) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: WETAIL + REAL(KIND=JWRB), VALUE, INTENT(IN) :: WSPMIN + REAL(KIND=JWRB), INTENT(IN) :: WTAUHF(JTOT_TAUHF) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: X0TAUHF + REAL(KIND=JWRB), VALUE, INTENT(IN) :: XKAPPA + REAL(KIND=JWRB), INTENT(IN), DEVICE :: XKMSQRTVGOC2_GC(NWAV_GC) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: XKM_GC(NWAV_GC) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: XK_GC(NWAV_GC) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: XLOGKRATIOM1_GC + REAL(KIND=JWRB), VALUE, INTENT(IN) :: XNLEV + REAL(KIND=JWRB), VALUE, INTENT(IN) :: Z0RAT + REAL(KIND=JWRB), VALUE, INTENT(IN) :: Z0TUBMAX + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ZALP + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ZPI + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ZPI4GM1 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ZPI4GM2 + REAL(KIND=JWRB), INTENT(IN), DEVICE :: ZPIFR(NFRE_loki_param) + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: ICHNK + INTEGER, VALUE, INTENT(IN) :: NCHNK + REAL(KIND=JWRB), INTENT(INOUT) :: STRESSO_TAUHF(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: STRESSO_PHIHF(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: STRESSO_UST(KIJL, NCHNK) + + ! ---------------------------------------------------------------------- + + + ! UPDATE UFRIC AND Z0M + IF (ICALL == 1) THEN + IUSFG = 0 + IF (LWCOU) THEN + ICODE_WND = ICODE_CPL + ELSE + ICODE_WND = ICODE + END IF + + LLPHIWA = .false. + LLSNEG = .false. + ELSE + IUSFG = 1 + ICODE_WND = 3 + + LLPHIWA = .true. + LLSNEG = .true. + END IF + + + IF (LLNORMAGAM .and. LLCAPCHNK) THEN + RNFAC(IJ, ICHNK) = 1.0_JWRB + DTHRN_A*(1.0_JWRB + TANH(WSWAVE(IJ, ICHNK) - DTHRN_U)) + ELSE + RNFAC(IJ, ICHNK) = 1.0_JWRB + END IF + + + + IF (LUPDTUS) THEN + ! increase noise level in the tail + IF (ICALL == 1) THEN + + DO K=1,NANG + FL1(IJ, K, NFRE, ICHNK) = MAX(FL1(IJ, K, NFRE, ICHNK), FLM(IJ, K)) + END DO + + + IF (LLGCBZ0) THEN + CALL HALPHAP_CUF_HOIST_NEW(KIJS, KIJL, WAVNUM(:, :, :), COSWDIF(:, :), FL1(:, :, :, :), HALP(:), ALPHAPMAX, DELTH, & + & DFIM(:), DFIMOFR(:), EPSMIN, FR(:), FR5(:), FRTAIL, NANG, NFRE, WETAIL, ZPI4GM2, ICHNK, NCHNK, IJ) + ELSE + + HALP(IJ) = 0.0_JWRB + + END IF + + END IF + + CALL AIRSEA_CUF_HOIST_NEW(KIJS, KIJL, HALP(:), WSWAVE(:, :), WDWAVE(:, :), TAUW(:, :), TAUWDIR(:, :), RNFAC(:, ICHNK), & + & UFRIC(:, :), Z0M(:, :), Z0B(:, :), CHRNCK(:, :), ICODE_WND, IUSFG, ACD, ALPHA, ALPHAMAX, ALPHAMIN, ANG_GC_A, ANG_GC_B, & + & ANG_GC_C, BCD, BETAMAXOXKAPPA2, BMAXOKAP, C2OSQRTVG_GC(:), CDMAX, CHNKMIN_U, CM_GC(:), DELKCC_GC_NS(:), & + & DELKCC_OMXKM3_GC(:), EPS1, EPSMIN, EPSUS, G, GM1, LLCAPCHNK, LLGCBZ0, LLNORMAGAM, NWAV_GC, OM3GMKM_GC(:), OMXKM3_GC(:), & + & RN1_RN, RNU, RNUM, SQRTGOSURFT, WSPMIN, XKAPPA, XKMSQRTVGOC2_GC(:), XKM_GC(:), XK_GC(:), XLOGKRATIOM1_GC, XNLEV, ZALP, & + & ICHNK, NCHNK, IJ) + + END IF + + ! COMPUTE WIND INPUT + !! FLD AND SL ARE INITIALISED IN SINPUT + + CALL SINPUT_CUF_HOIST_NEW(ICALL, LLSNEG, KIJS, KIJL, FL1(:, :, :, :), WAVNUM(:, :, :), CINV(:, :, :), XK2CG(:, :, :), & + & WDWAVE(:, :), WSWAVE(:, :), UFRIC(:, :), Z0M(:, :), COSWDIF(:, :), SINWDIF2(:, :), RAORW(:), WSTAR(:, :), RNFAC(:, ICHNK), & + & FLD(:, :, :), SL(:, :, :), SPOS(:, :, :), XLLWS(:, :, :, :), ABMAX, ABMIN, ACDLIN, ALPHAMAX, ALPHAMIN, BCDLIN, & + & BETAMAXOXKAPPA2, COSTH(:), DELTH, DFIM(:), EPSMIN, EPSUS, G, IAB, IDAMPING, IPHYS, LLGCBZ0, LLNORMAGAM, NANG, NFRE, RNU, & + & RNUM, SINTH(:), SWELLF, SWELLF2, SWELLF3, SWELLF4, SWELLF5, SWELLF6, SWELLF7, SWELLF7M1, SWELLFT(:), TAUWSHELTER, TH(:), & + & WSPMIN, XKAPPA, Z0RAT, Z0TUBMAX, ZALP, ZPI, ZPIFR(:), ICHNK, NCHNK, IJ) + + + ! MEAN FREQUENCY CHARACTERISTIC FOR WIND SEA + CALL FEMEANWS_CUF_HOIST_NEW(KIJS, KIJL, FL1(:, :, :, :), XLLWS(:, :, :, :), FMEANWS(:), TMP_EM(:, ICHNK), DELTH, DFIM(:), & + & DFIMOFR(:), EPSMIN, FR(:), FRTAIL, NANG, NFRE, WETAIL, ICHNK, NCHNK, IJ) + + ! COMPUTE LAST FREQUENCY INDEX OF PROGNOSTIC PART OF SPECTRUM. + CALL FRCUTINDEX_CUF_HOIST_NEW(KIJS, KIJL, FMEAN(:), FMEANWS(:), UFRIC(:, :), CICOVER(:, :), MIJ(:, :), RHOWGDFTH(:, :), & + & CITHRSH_TAIL, EPSMIN, FLOGSPRDM1, FR(:), FRIC, G, NFRE, RHOWG_DFIM(:), TAILFACTOR, TAILFACTOR_PM, ZPIFR(:), ICHNK, NCHNK, & + & IJ) + + ! UPDATE TAUW + CALL STRESSO_CUF_HOIST_NEW(KIJS, KIJL, MIJ(:, :), RHOWGDFTH(:, :), FL1(:, :, :, :), SL(:, :, :), SPOS(:, :, :), & + & CINV(:, :, :), WDWAVE(:, :), UFRIC(:, :), Z0M(:, :), AIRD(:, :), RNFAC(:, ICHNK), COSWDIF(:, :), SINWDIF2(:, :), & + & TAUW(:, :), TAUWDIR(:, :), PHIWA(:), LLPHIWA, COSTH(:), DELTH, EPS1, FR5(:), G, GAMNCONST, GM1, IPHYS, JTOT_TAUHF, & + & LLGCBZ0, LLNORMAGAM, NANG, NFRE, NWAV_GC, OMEGA_GC(:), RHOWG_DFIM(:), SINTH(:), SQRTGOSURFT, TAUWSHELTER, WTAUHF(:), & + & X0TAUHF, XKAPPA, XKM_GC(:), XK_GC(:), XLOGKRATIOM1_GC, ZALP, ZPI4GM1, ZPI4GM2, ZPIFR(:), ICHNK, NCHNK, IJ, & + & TAUHF=STRESSO_TAUHF, PHIHF=STRESSO_PHIHF, UST=STRESSO_UST) + + ! ---------------------------------------------------------------------- + + + END SUBROUTINE SINFLX_CUF_HOIST_NEW +END MODULE SINFLX_CUF_HOIST_NEW_MOD diff --git a/src/phys-scc-cuf-hoist/sinput.cuf_hoist_new.F90 b/src/phys-scc-cuf-hoist/sinput.cuf_hoist_new.F90 new file mode 100644 index 00000000..d6daefd7 --- /dev/null +++ b/src/phys-scc-cuf-hoist/sinput.cuf_hoist_new.F90 @@ -0,0 +1,171 @@ +! (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. +! +MODULE SINPUT_CUF_HOIST_NEW_MOD + CONTAINS + ATTRIBUTES(DEVICE) SUBROUTINE SINPUT_CUF_HOIST_NEW (NGST, LLSNEG, KIJS, KIJL, FL1, WAVNUM, CINV, XK2CG, WDWAVE, WSWAVE, UFRIC, & + & Z0M, COSWDIF, SINWDIF2, RAORW, WSTAR, RNFAC, FLD, SL, SPOS, XLLWS, ABMAX, ABMIN, ACDLIN, ALPHAMAX, ALPHAMIN, BCDLIN, & + & BETAMAXOXKAPPA2, COSTH, DELTH, DFIM, EPSMIN, EPSUS, G, IAB, IDAMPING, IPHYS, LLGCBZ0, LLNORMAGAM, NANG, NFRE, RNU, RNUM, & + & SINTH, SWELLF, SWELLF2, SWELLF3, SWELLF4, SWELLF5, SWELLF6, SWELLF7, SWELLF7M1, SWELLFT, TAUWSHELTER, TH, WSPMIN, XKAPPA, & + & Z0RAT, Z0TUBMAX, ZALP, ZPI, ZPIFR, ICHNK, NCHNK, IJ) + ! ---------------------------------------------------------------------- + + !**** *SINPUT* - COMPUTATION OF INPUT SOURCE FUNCTION. + + + !** INTERFACE. + ! ---------- + + ! *CALL* *SINPUT (NGST, LLSNEG, KIJS, KIJL, FL1, + ! & WAVNUM, CINV, XK2CG, + ! & WDWAVE, UFRIC, Z0M, + ! & COSWDIF, SINWDIF2, + ! & RAORW, WSTAR, FLD, SL, SPOS, XLLWS) + ! *NGST* - IF = 1 THEN NO GUSTINESS PARAMETERISATION + ! - IF = 2 THEN GUSTINESS PARAMETERISATION + ! *LLSNEG* - IF TRUE THEN THE NEGATIVE SINPUT WILL BE COMPUTED + ! *KIJS* - INDEX OF FIRST GRIDPOINT. + ! *KIJL* - INDEX OF LAST GRIDPOINT. + ! *FL1* - SPECTRUM. + ! *WAVNUM* - WAVE NUMBER. + ! *CINV* - INVERSE PHASE VELOCITY. + ! *XK2CG* - (WAVE NUMBER)**2 * GROUP SPPED. + ! *WDWAVE* - WIND DIRECTION IN RADIANS IN OCEANOGRAPHIC + ! NOTATION (POINTING ANGLE OF WIND VECTOR, + ! CLOCKWISE FROM NORTH). + ! *UFRIC* - 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. + ! *FLD* - DIAGONAL MATRIX OF FUNCTIONAL DERIVATIVE. + ! *SL* - TOTAL SOURCE FUNCTION ARRAY. + ! *SPOS* - POSITIVE SOURCE FUNCTION ARRAY. + ! *XLLWS* - = 1 WHERE SINPUT IS POSITIVE + + ! METHOD. + ! ------- + + ! DEPENDING ON THE VALUE OF IPHYS, DIFFERENT INPUTE SOURCE TERm WILL BE CALLED + + ! EXTERNALS. + ! ---------- + + ! MODIFICATIONS + ! ------------- + + ! REFERENCE. + ! ---------- + + + ! ---------------------------------------------------------------------- + USE cudafor + USE PARKIND_WAVE, ONLY: JWIM, JWRU, JWRB + + + USE SINPUT_ARD_CUF_HOIST_NEW_MOD, ONLY: SINPUT_JAN_CUF_HOIST_NEW, SINPUT_ARD_CUF_HOIST_NEW + + ! ---------------------------------------------------------------------- + + IMPLICIT NONE + + INTEGER(KIND=JWIM), PARAMETER :: NANG_loki_param = 24 + INTEGER(KIND=JWIM), PARAMETER :: NFRE_loki_param = 36 + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NGST + LOGICAL, VALUE, INTENT(IN) :: LLSNEG + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJS + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJL + + REAL(KIND=JWRB), INTENT(IN) :: FL1(KIJL, NANG_loki_param, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: WAVNUM(KIJL, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: CINV(KIJL, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: XK2CG(KIJL, NFRE_loki_param, NCHNK) + + REAL(KIND=JWRB), INTENT(IN) :: WDWAVE(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: WSWAVE(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: UFRIC(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: Z0M(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: RAORW(KIJL) + REAL(KIND=JWRB), INTENT(IN) :: RNFAC(KIJL) + REAL(KIND=JWRB), INTENT(IN) :: WSTAR(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: COSWDIF(KIJL, NANG_loki_param) + REAL(KIND=JWRB), INTENT(IN) :: SINWDIF2(KIJL, NANG_loki_param) + + REAL(KIND=JWRB), INTENT(OUT) :: FLD(KIJL, NANG_loki_param, NFRE_loki_param) + REAL(KIND=JWRB), INTENT(OUT) :: SL(KIJL, NANG_loki_param, NFRE_loki_param) + REAL(KIND=JWRB), INTENT(OUT) :: SPOS(KIJL, NANG_loki_param, NFRE_loki_param) + REAL(KIND=JWRB), INTENT(OUT) :: XLLWS(KIJL, NANG_loki_param, NFRE_loki_param, NCHNK) + + + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ABMAX + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ABMIN + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ACDLIN + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ALPHAMAX + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ALPHAMIN + REAL(KIND=JWRB), VALUE, INTENT(IN) :: BCDLIN + REAL(KIND=JWRB), VALUE, INTENT(IN) :: BETAMAXOXKAPPA2 + REAL(KIND=JWRB), INTENT(IN), DEVICE :: COSTH(NFRE_loki_param) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: DELTH + REAL(KIND=JWRB), INTENT(IN), DEVICE :: DFIM(NFRE_loki_param) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: EPSMIN + REAL(KIND=JWRB), VALUE, INTENT(IN) :: EPSUS + REAL(KIND=JWRB), VALUE, INTENT(IN) :: G + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: IAB + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: IDAMPING + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: IPHYS + LOGICAL, VALUE, INTENT(IN) :: LLGCBZ0 + LOGICAL, VALUE, INTENT(IN) :: LLNORMAGAM + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NANG + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NFRE + REAL(KIND=JWRB), VALUE, INTENT(IN) :: RNU + REAL(KIND=JWRB), VALUE, INTENT(IN) :: RNUM + REAL(KIND=JWRB), INTENT(IN), DEVICE :: SINTH(NFRE_loki_param) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SWELLF + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SWELLF2 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SWELLF3 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SWELLF4 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SWELLF5 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SWELLF6 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SWELLF7 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SWELLF7M1 + REAL(KIND=JWRB), INTENT(IN) :: SWELLFT(IAB) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: TAUWSHELTER + REAL(KIND=JWRB), INTENT(IN), DEVICE :: TH(NFRE_loki_param) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: WSPMIN + REAL(KIND=JWRB), VALUE, INTENT(IN) :: XKAPPA + REAL(KIND=JWRB), VALUE, INTENT(IN) :: Z0RAT + REAL(KIND=JWRB), VALUE, INTENT(IN) :: Z0TUBMAX + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ZALP + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ZPI + REAL(KIND=JWRB), INTENT(IN), DEVICE :: ZPIFR(NFRE_loki_param) + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: ICHNK + INTEGER, VALUE, INTENT(IN) :: NCHNK + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: IJ + ! ---------------------------------------------------------------------- + + + SELECT CASE (IPHYS) + CASE (0) + CALL SINPUT_JAN_CUF_HOIST_NEW(NGST, LLSNEG, KIJS, KIJL, FL1(:, :, :, :), WAVNUM(:, :, :), CINV(:, :, :), XK2CG(:, :, :), & + & WSWAVE(:, :), UFRIC(:, :), Z0M(:, :), COSWDIF(:, :), SINWDIF2(:, :), RAORW(:), WSTAR(:, :), RNFAC(:), FLD(:, :, :), & + & SL(:, :, :), SPOS(:, :, :), XLLWS(:, :, :, :), ACDLIN, ALPHAMAX, ALPHAMIN, BCDLIN, BETAMAXOXKAPPA2, DELTH, EPSUS, G, & + & IDAMPING, LLGCBZ0, LLNORMAGAM, NANG, NFRE, RNUM, WSPMIN, XKAPPA, ZALP, ZPI, ZPIFR(:), ICHNK, NCHNK, IJ) + CASE (1) + CALL SINPUT_ARD_CUF_HOIST_NEW(NGST, LLSNEG, KIJS, KIJL, FL1(:, :, :, :), WAVNUM(:, :, :), CINV(:, :, :), XK2CG(:, :, :), & + & WDWAVE(:, :), WSWAVE(:, :), UFRIC(:, :), Z0M(:, :), COSWDIF(:, :), SINWDIF2(:, :), RAORW(:), WSTAR(:, :), RNFAC(:), & + & FLD(:, :, :), SL(:, :, :), SPOS(:, :, :), XLLWS(:, :, :, :), ABMAX, ABMIN, ACDLIN, ALPHAMAX, ALPHAMIN, BCDLIN, & + & BETAMAXOXKAPPA2, COSTH(:), DELTH, DFIM(:), EPSMIN, EPSUS, G, IAB, LLGCBZ0, LLNORMAGAM, NANG, NFRE, RNU, RNUM, SINTH(:), & + & SWELLF, SWELLF2, SWELLF3, SWELLF4, SWELLF5, SWELLF6, SWELLF7, SWELLF7M1, SWELLFT(:), TAUWSHELTER, TH(:), WSPMIN, XKAPPA, & + & Z0RAT, Z0TUBMAX, ZALP, ZPI, ZPIFR(:), ICHNK, NCHNK, IJ) + END SELECT + + + END SUBROUTINE SINPUT_CUF_HOIST_NEW +END MODULE SINPUT_CUF_HOIST_NEW_MOD diff --git a/src/phys-scc-cuf-hoist/sinput_ard.cuf_hoist_new.F90 b/src/phys-scc-cuf-hoist/sinput_ard.cuf_hoist_new.F90 new file mode 100644 index 00000000..13ace841 --- /dev/null +++ b/src/phys-scc-cuf-hoist/sinput_ard.cuf_hoist_new.F90 @@ -0,0 +1,1013 @@ +! (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. +! +MODULE SINPUT_ARD_CUF_HOIST_NEW_MOD + !CONTAINED SUBROUTINES: + ! - WSIGSTAR + ! - SINPUT_ARD + ! - SINPUT_JAN + CONTAINS + ATTRIBUTES(DEVICE) SUBROUTINE WSIGSTAR_CUF_HOIST_NEW (WSWAVE, UFRIC, Z0M, WSTAR, SIG_N, ACDLIN, ALPHAMAX, ALPHAMIN, BCDLIN, & + & EPSUS, G, LLGCBZ0, RNUM, WSPMIN, XKAPPA) + ! ---------------------------------------------------------------------- + + !**** *WSIGSTAR* - COMPUTATION OF THE RELATIVE STANDARD DEVIATION OF USTAR. + + !* PURPOSE. + ! --------- + + ! COMPUTES THE STANDARD DEVIATION OF USTAR DUE TO SMALL SCALE GUSTINESS + ! RELATIVE TO USTAR + + !** INTERFACE. + ! ---------- + + ! *CALL* *WSIGSTAR (KIJS, KIJL, WSWAVE, UFRIC, Z0M, WSTAR, SIG_N) + ! *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. + + ! METHOD. + ! ------- + + ! USE PANOFSKY (1991) TO EXPRESS THE STANDARD DEVIATION OF U10 IN TERMS + ! USTAR AND w* THE CONVECTIVE VELOCITY SCALE. + ! (but with the background gustiness set to 0.) + ! and USTAR=SQRT(Cd)*U10 to DERIVE THE STANDARD DEVIATION OF USTAR. + ! WITH CD=A+B*U10 (see below). + + ! REFERENCE. + ! ---------- + + ! SEE SECTION 3.2.1 OF THE WAM DOCUMENTATION. + + ! ---------------------------------------------------------------------- + + USE cudafor + USE PARKIND_WAVE, ONLY: JWIM, JWRU, JWRB + + + + ! ---------------------------------------------------------------------- + + IMPLICIT NONE + + REAL(KIND=JWRB), INTENT(IN) :: WSWAVE, UFRIC, Z0M, WSTAR + REAL(KIND=JWRB), INTENT(OUT) :: SIG_N + + 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 :: LOG10 = LOG(10.0_JWRB) + REAL(KIND=JWRB), PARAMETER :: C1 = 1.03E-3_JWRB + REAL(KIND=JWRB), PARAMETER :: C2 = 0.04E-3_JWRB + REAL(KIND=JWRB), PARAMETER :: P1 = 1.48_JWRB + REAL(KIND=JWRB), PARAMETER :: P2 = -0.21_JWRB + + ! $ loki routine seq + REAL(KIND=JWRB) :: ZCHAR, C_D, DC_DDU, SIG_CONV + REAL(KIND=JWRB) :: XKAPPAD, U10, C2U10P1, U10P2 + REAL(KIND=JWRB) :: BCD, U10M1, ZN, Z0VIS + REAL(KIND=JWRB), INTENT(IN) :: ACDLIN + REAL(KIND=JWRB), INTENT(IN) :: ALPHAMAX + REAL(KIND=JWRB), INTENT(IN) :: ALPHAMIN + REAL(KIND=JWRB), INTENT(IN) :: BCDLIN + REAL(KIND=JWRB), INTENT(IN) :: EPSUS + REAL(KIND=JWRB), INTENT(IN) :: G + LOGICAL, INTENT(IN) :: LLGCBZ0 + REAL(KIND=JWRB), INTENT(IN) :: RNUM + REAL(KIND=JWRB), INTENT(IN) :: WSPMIN + REAL(KIND=JWRB), INTENT(IN) :: XKAPPA +!$acc routine seq + + + ! ---------------------------------------------------------------------- + + + + IF (LLGCBZ0) THEN + ZN = RNUM + + U10M1 = 1.0_JWRB / MAX(WSWAVE, WSPMIN) + ! CHARNOCK: + Z0VIS = ZN / MAX(UFRIC, EPSUS) + ZCHAR = G*(Z0M - Z0VIS) / MAX(UFRIC**2, EPSUS) + ZCHAR = MAX(MIN(ZCHAR, ALPHAMAX), ALPHAMIN) + + BCD = BCDLIN*SQRT(ZCHAR) + C_D = ACDLIN + BCD*WSWAVE + DC_DDU = BCD + SIG_CONV = 1.0_JWRB + 0.5_JWRB*WSWAVE / C_D*DC_DDU + SIG_N = MIN(SIG_NMAX, SIG_CONV*U10M1*(BG_GUST*UFRIC**3 + 0.5_JWRB*XKAPPA*WSTAR**3)**ONETHIRD) + ELSE + ZN = 0.0_JWRB + + !!! for consistency I have kept the old method, even though the new method above could be used, + !!! but until LLGCBZ0 is the default, keep the old scheme whe it is not... + ! + ! IN THE FOLLOWING U10 IS ESTIMATED ASSUMING EVERYTHING IS + ! BASED ON U* + ! + XKAPPAD = 1.0_JWRB / XKAPPA + U10 = UFRIC*XKAPPAD*(LOG10 - LOG(Z0M)) + U10 = MAX(U10, WSPMIN) + U10M1 = 1.0_JWRB / U10 + C2U10P1 = C2*U10**P1 + U10P2 = U10**P2 + C_D = (C1 + C2U10P1)*U10P2 + DC_DDU = (P2*C1 + (P1 + P2)*C2U10P1)*U10P2*U10M1 + SIG_CONV = 1.0_JWRB + 0.5_JWRB*U10 / C_D*DC_DDU + SIG_N = MIN(SIG_NMAX, SIG_CONV*U10M1*(BG_GUST*UFRIC**3 + 0.5_JWRB*XKAPPA*WSTAR**3)**ONETHIRD) + END IF + + + END SUBROUTINE WSIGSTAR_CUF_HOIST_NEW + ATTRIBUTES(DEVICE) SUBROUTINE SINPUT_ARD_CUF_HOIST_NEW (NGST, LLSNEG, KIJS, KIJL, FL1, WAVNUM, CINV, XK2CG, WDWAVE, WSWAVE, & + & UFRIC, Z0M, COSWDIF, SINWDIF2, RAORW, WSTAR, RNFAC, FLD, SL, SPOS, XLLWS, ABMAX, ABMIN, ACDLIN, ALPHAMAX, ALPHAMIN, BCDLIN, & + & BETAMAXOXKAPPA2, COSTH, DELTH, DFIM, EPSMIN, EPSUS, G, IAB, LLGCBZ0, LLNORMAGAM, NANG, NFRE, RNU, RNUM, SINTH, SWELLF, & + & SWELLF2, SWELLF3, SWELLF4, SWELLF5, SWELLF6, SWELLF7, SWELLF7M1, SWELLFT, TAUWSHELTER, TH, WSPMIN, XKAPPA, Z0RAT, Z0TUBMAX, & + & ZALP, ZPI, ZPIFR, ICHNK, NCHNK, IJ) + ! ---------------------------------------------------------------------- + + !**** *SINPUT_ARD* - COMPUTATION OF INPUT SOURCE FUNCTION. + + + !* PURPOSE. + ! --------- + + ! COMPUTE THE WIND INPUT SOURCE TRERM BASED ON ARDHUIN ET AL. 2010. + + ! COMPUTE INPUT SOURCE FUNCTION AND STORE ADDITIVELY INTO NET + ! SOURCE FUNCTION ARRAY, ALSO COMPUTE FUNCTIONAL DERIVATIVE OF + ! INPUT SOURCE FUNCTION. + ! + ! GUSTINESS IS INTRODUCED FOLL0WING THE APPROACH OF JANSSEN(1986), + ! USING A GAUSS-HERMITE APPROXIMATION SUGGESTED BY MILES(1997). + ! IN THE PRESENT VERSION ONLY TWO HERMITE POLYNOMIALS ARE UTILISED + ! IN THE EVALUATION OF THE PROBABILITY INTEGRAL. EXPLICITELY ONE THEN + ! FINDS: + ! + ! = 0.5*( GAMMA(X(1+SIG)) + GAMMA(X(1-SIG)) ) + ! + ! WHERE X IS THE FRICTION VELOCITY AND SIG IS THE RELATIVE GUSTINESS + ! LEVEL. + + !** INTERFACE. + ! ---------- + + ! *CALL* *SINPUT_ARD (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. + ! *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. + + + ! ---------------------------------------------------------------------- + USE cudafor + USE PARKIND_WAVE, ONLY: JWIM, JWRU, JWRB + + USE YOWCOUP, ONLY: LLCAPCHNK + USE YOWFRED, ONLY: FR + USE YOWPARAM, ONLY: NANG_PARAM + USE YOWPCONS, ONLY: GM1 + USE YOWPHYS, ONLY: RN1_RN + USE YOWTEST, ONLY: IU06 + USE YOWSTAT, ONLY: IDAMPING + + + ! ---------------------------------------------------------------------- + + IMPLICIT NONE + + INTEGER(KIND=JWIM), PARAMETER :: NANG_loki_param = 24 + INTEGER(KIND=JWIM), PARAMETER :: NFRE_loki_param = 36 + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NGST + LOGICAL, VALUE, INTENT(IN) :: LLSNEG + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJS + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJL + REAL(KIND=JWRB), INTENT(IN) :: FL1(KIJL, NANG_loki_param, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: WAVNUM(KIJL, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: CINV(KIJL, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: XK2CG(KIJL, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: WDWAVE(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: WSWAVE(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: UFRIC(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: Z0M(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: RAORW(KIJL) + REAL(KIND=JWRB), INTENT(IN) :: RNFAC(KIJL) + REAL(KIND=JWRB), INTENT(IN) :: WSTAR(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: COSWDIF(KIJL, NANG_loki_param) + REAL(KIND=JWRB), INTENT(IN) :: SINWDIF2(KIJL, NANG_loki_param) + REAL(KIND=JWRB), INTENT(OUT) :: FLD(KIJL, NANG_loki_param, NFRE_loki_param) + REAL(KIND=JWRB), INTENT(OUT) :: SL(KIJL, NANG_loki_param, NFRE_loki_param) + REAL(KIND=JWRB), INTENT(OUT) :: SPOS(KIJL, NANG_loki_param, NFRE_loki_param) + REAL(KIND=JWRB), INTENT(OUT) :: XLLWS(KIJL, NANG_loki_param, NFRE_loki_param, NCHNK) + + + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: IJ + INTEGER(KIND=JWIM) :: K + INTEGER(KIND=JWIM) :: M + INTEGER(KIND=JWIM) :: IND + INTEGER(KIND=JWIM) :: IGST + + REAL(KIND=JWRB) :: CONSTN + REAL(KIND=JWRB) :: AVG_GST + REAL(KIND=JWRB) :: ABS_TAUWSHELTER + REAL(KIND=JWRB) :: CONST1 + REAL(KIND=JWRB) :: ZNZ + REAL(KIND=JWRB) :: X1 + REAL(KIND=JWRB) :: X2 + REAL(KIND=JWRB) :: ZLOG + REAL(KIND=JWRB) :: ZLOG1 + REAL(KIND=JWRB) :: ZLOG2 + REAL(KIND=JWRB) :: ZLOG2X + REAL(KIND=JWRB) :: XV1 + REAL(KIND=JWRB) :: XV2 + REAL(KIND=JWRB) :: ZBETA1 + REAL(KIND=JWRB) :: ZBETA2 + REAL(KIND=JWRB) :: XI + REAL(KIND=JWRB) :: X + REAL(KIND=JWRB) :: DELI1 + REAL(KIND=JWRB) :: DELI2 + REAL(KIND=JWRB) :: FU + REAL(KIND=JWRB) :: FUD + REAL(KIND=JWRB) :: NU_AIR + REAL(KIND=JWRB) :: SMOOTH + REAL(KIND=JWRB) :: HFTSWELLF6 + REAL(KIND=JWRB) :: Z0TUB + REAL(KIND=JWRB) :: FAC_NU_AIR + REAL(KIND=JWRB) :: FACM1_NU_AIR + REAL(KIND=JWRB) :: ARG + REAL(KIND=JWRB) :: DELABM1 + REAL(KIND=JWRB) :: TAUPX + REAL(KIND=JWRB) :: TAUPY + REAL(KIND=JWRB) :: DSTAB2 + + REAL(KIND=JWRB) :: SIG2 + REAL(KIND=JWRB) :: COEF + REAL(KIND=JWRB) :: COEF5 + REAL(KIND=JWRB) :: DFIM_SIG2 + REAL(KIND=JWRB) :: COSLP + + REAL(KIND=JWRB) :: XNGAMCONST + REAL(KIND=JWRB) :: CONSTF + REAL(KIND=JWRB) :: CONST11 + REAL(KIND=JWRB) :: CONST22 + REAL(KIND=JWRB) :: Z0VIS + REAL(KIND=JWRB) :: Z0NOZ + REAL(KIND=JWRB) :: FWW + REAL(KIND=JWRB) :: PVISC + REAL(KIND=JWRB) :: PTURB + REAL(KIND=JWRB) :: ZCN + REAL(KIND=JWRB) :: SIG_N + REAL(KIND=JWRB) :: UORBT + REAL(KIND=JWRB) :: AORB + REAL(KIND=JWRB) :: TEMP + REAL(KIND=JWRB) :: RE + REAL(KIND=JWRB) :: RE_C + REAL(KIND=JWRB) :: ZORB + REAL(KIND=JWRB) :: CNSN + REAL(KIND=JWRB) :: SUMF + REAL(KIND=JWRB) :: SUMFSIN2 + REAL(KIND=JWRB) :: CSTRNFAC + REAL(KIND=JWRB) :: FLP_AVG + REAL(KIND=JWRB) :: SLP_AVG + REAL(KIND=JWRB) :: ROGOROAIR + REAL(KIND=JWRB) :: AIRD_PVISC + REAL(KIND=JWRB) :: DSTAB1 + REAL(KIND=JWRB) :: TEMP1 + REAL(KIND=JWRB) :: TEMP2 + + REAL(KIND=JWRB) :: XSTRESS(2) + REAL(KIND=JWRB) :: YSTRESS(2) + REAL(KIND=JWRB) :: FLP(2) + REAL(KIND=JWRB) :: SLP(2) + REAL(KIND=JWRB) :: USG2(2) + REAL(KIND=JWRB) :: TAUX(2) + REAL(KIND=JWRB) :: TAUY(2) + REAL(KIND=JWRB) :: USTP(2) + REAL(KIND=JWRB) :: USTPM1(2) + REAL(KIND=JWRB) :: USDIRP(2) + REAL(KIND=JWRB) :: UCN(2) + REAL(KIND=JWRB) :: UCNZALPD(2) + REAL(KIND=JWRB) :: GAMNORMA(2) ! ! RENORMALISATION FACTOR OF THE GROWTH RATE + REAL(KIND=JWRB) :: GAM0(2, NANG_PARAM) + REAL(KIND=JWRB) :: DSTAB(2, NANG_PARAM) + + LOGICAL :: LTAUWSHELTER + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ABMAX + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ABMIN + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ACDLIN + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ALPHAMAX + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ALPHAMIN + REAL(KIND=JWRB), VALUE, INTENT(IN) :: BCDLIN + REAL(KIND=JWRB), VALUE, INTENT(IN) :: BETAMAXOXKAPPA2 + REAL(KIND=JWRB), INTENT(IN), DEVICE :: COSTH(NFRE_loki_param) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: DELTH + REAL(KIND=JWRB), INTENT(IN), DEVICE :: DFIM(NFRE_loki_param) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: EPSMIN + REAL(KIND=JWRB), VALUE, INTENT(IN) :: EPSUS + REAL(KIND=JWRB), VALUE, INTENT(IN) :: G + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: IAB + LOGICAL, VALUE, INTENT(IN) :: LLGCBZ0 + LOGICAL, VALUE, INTENT(IN) :: LLNORMAGAM + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NANG + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NFRE + REAL(KIND=JWRB), VALUE, INTENT(IN) :: RNU + REAL(KIND=JWRB), VALUE, INTENT(IN) :: RNUM + REAL(KIND=JWRB), INTENT(IN), DEVICE :: SINTH(NFRE_loki_param) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SWELLF + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SWELLF2 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SWELLF3 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SWELLF4 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SWELLF5 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SWELLF6 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SWELLF7 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SWELLF7M1 + REAL(KIND=JWRB), INTENT(IN) :: SWELLFT(IAB) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: TAUWSHELTER + REAL(KIND=JWRB), INTENT(IN), DEVICE :: TH(NFRE_loki_param) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: WSPMIN + REAL(KIND=JWRB), VALUE, INTENT(IN) :: XKAPPA + REAL(KIND=JWRB), VALUE, INTENT(IN) :: Z0RAT + REAL(KIND=JWRB), VALUE, INTENT(IN) :: Z0TUBMAX + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ZALP + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ZPI + REAL(KIND=JWRB), INTENT(IN), DEVICE :: ZPIFR(NFRE_loki_param) + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: ICHNK + INTEGER, VALUE, INTENT(IN) :: NCHNK + ! ---------------------------------------------------------------------- + + + AVG_GST = 1.0_JWRB / NGST + CONST1 = BETAMAXOXKAPPA2 + CONSTN = DELTH / (XKAPPA*ZPI) + + ABS_TAUWSHELTER = ABS(TAUWSHELTER) + IF (ABS_TAUWSHELTER == 0.0_JWRB) THEN + LTAUWSHELTER = .false. + ELSE + LTAUWSHELTER = .true. + END IF + + + IF (NGST > 1) THEN + CALL WSIGSTAR_CUF_HOIST_NEW(WSWAVE(IJ, ICHNK), UFRIC(IJ, ICHNK), Z0M(IJ, ICHNK), WSTAR(IJ, ICHNK), SIG_N, ACDLIN, & + & ALPHAMAX, ALPHAMIN, BCDLIN, EPSUS, G, LLGCBZ0, RNUM, WSPMIN, XKAPPA) + END IF + + + IF (LLNORMAGAM) THEN + CSTRNFAC = CONSTN*RNFAC(IJ) / RAORW(IJ) + END IF + + + ! ESTIMATE THE STANDARD DEVIATION OF GUSTINESS. + + ! ---------------------------------------------------------------------- + IF (LLSNEG) THEN + !!!! only for the negative sinput + NU_AIR = RNU + FACM1_NU_AIR = 4.0_JWRB / NU_AIR + + FAC_NU_AIR = RNUM + + FU = ABS(SWELLF3) + FUD = SWELLF2 + DELABM1 = REAL(IAB) / (ABMAX - ABMIN) + + + ! computation of Uorb and Aorb + UORBT = EPSMIN + AORB = EPSMIN + + DO M=1,NFRE + SIG2 = ZPIFR(M)**2 + DFIM_SIG2 = DFIM(M)*SIG2 + + K = 1 + TEMP = FL1(IJ, K, M, ICHNK) + DO K=2,NANG + TEMP = TEMP + FL1(IJ, K, M, ICHNK) + END DO + + UORBT = UORBT + DFIM_SIG2*TEMP + AORB = AORB + DFIM(M)*TEMP + END DO + + UORBT = 2.0_JWRB*SQRT(UORBT) ! this is the significant orbital amplitude + AORB = 2.0_JWRB*SQRT(AORB) ! this 1/2 Hs + RE = FACM1_NU_AIR*UORBT*AORB ! this is the Reynolds number + Z0VIS = FAC_NU_AIR / MAX(UFRIC(IJ, ICHNK), 0.0001_JWRB) + Z0TUB = Z0RAT*MIN(Z0TUBMAX, Z0M(IJ, ICHNK)) + Z0NOZ = MAX(Z0VIS, Z0TUB) + ZORB = AORB / Z0NOZ + + ! compute fww + XI = (LOG10(MAX(ZORB, 3.0_JWRB)) - ABMIN)*DELABM1 + IND = MIN(IAB - 1, INT(XI)) + DELI1 = MIN(1.0_JWRB, XI - REAL(IND, kind=JWRB)) + DELI2 = 1.0_JWRB - DELI1 + FWW = SWELLFT(IND)*DELI2 + SWELLFT(IND + 1)*DELI1 + TEMP2 = FWW*UORBT + + ! Define the critical Reynolds number + IF (SWELLF6 == 1.0_JWRB) THEN + RE_C = SWELLF4 + ELSE + HFTSWELLF6 = 1.0_JWRB - SWELLF6 + RE_C = SWELLF4*(2.0_JWRB / AORB)**HFTSWELLF6 + END IF + + ! Swell damping weight between viscous and turbulent boundary layer + IF (SWELLF7 > 0.0_JWRB) THEN + SMOOTH = 0.5_JWRB*TANH((RE - RE_C)*SWELLF7M1) + PTURB = 0.5_JWRB + SMOOTH + PVISC = 0.5_JWRB - SMOOTH + ELSE + IF (RE <= RE_C) THEN + PTURB = 0.0_JWRB + PVISC = 0.5_JWRB + ELSE + PTURB = 0.5_JWRB + PVISC = 0.0_JWRB + END IF + END IF + + AIRD_PVISC = PVISC*RAORW(IJ) + + END IF + + + + ! Initialisation + + IF (NGST == 1) THEN + USTP(1) = UFRIC(IJ, ICHNK) + ELSE + USTP(1) = UFRIC(IJ, ICHNK)*(1.0_JWRB + SIG_N) + USTP(2) = UFRIC(IJ, ICHNK)*(1.0_JWRB - SIG_N) + END IF + + DO IGST=1,NGST + USTPM1(IGST) = 1.0_JWRB / MAX(USTP(IGST), EPSUS) + END DO + + IF (LTAUWSHELTER) THEN + DO IGST=1,NGST + XSTRESS(IGST) = 0.0_JWRB + YSTRESS(IGST) = 0.0_JWRB + USG2(IGST) = USTP(IGST)**2 + TAUX(IGST) = USG2(IGST)*SIN(WDWAVE(IJ, ICHNK)) + TAUY(IGST) = USG2(IGST)*COS(WDWAVE(IJ, ICHNK)) + END DO + + ROGOROAIR = G / RAORW(IJ) + END IF + + + !* 2. MAIN LOOP OVER FREQUENCIES. + ! --------------------------- + + IF (.not.LLNORMAGAM) THEN + DO IGST=1,NGST + GAMNORMA(IGST) = 1.0_JWRB + END DO + END IF + + IF (.not.LLSNEG) THEN + DO K=1,NANG + DO IGST=1,NGST + DSTAB(IGST, K) = 0.0_JWRB + END DO + END DO + END IF + + DO M=1,NFRE + + IF (LTAUWSHELTER) THEN + DO IGST=1,NGST + TAUPX = TAUX(IGST) - ABS_TAUWSHELTER*XSTRESS(IGST) + TAUPY = TAUY(IGST) - ABS_TAUWSHELTER*YSTRESS(IGST) + USDIRP(IGST) = ATAN2(TAUPX, TAUPY) + USTP(IGST) = (TAUPX**2 + TAUPY**2)**0.25_JWRB + USTPM1(IGST) = 1.0_JWRB / MAX(USTP(IGST), EPSUS) + END DO + + CONSTF = ROGOROAIR*CINV(IJ, M, ICHNK)*DFIM(M) + END IF + + + !* PRECALCULATE FREQUENCY DEPENDENCE. + ! ---------------------------------- + + DO IGST=1,NGST + UCN(IGST) = USTP(IGST)*CINV(IJ, M, ICHNK) + UCNZALPD(IGST) = XKAPPA / (UCN(IGST) + ZALP) + END DO + ZCN = LOG(WAVNUM(IJ, M, ICHNK)*Z0M(IJ, ICHNK)) + CNSN = ZPIFR(M)*CONST1*RAORW(IJ) + + !* 2.1 LOOP OVER DIRECTIONS. + ! --------------------- + + DO K=1,NANG + XLLWS(IJ, K, M, ICHNK) = 0.0_JWRB + END DO + + IF (LLSNEG) THEN + ! SWELL DAMPING: + + SIG2 = ZPIFR(M)**2 + DFIM_SIG2 = DFIM(M)*SIG2 + + COEF = -SWELLF*16._JWRB*SIG2 / G + COEF5 = -SWELLF5*2._JWRB*SQRT(2._JWRB*NU_AIR*ZPIFR(M)) + + DSTAB1 = COEF5*AIRD_PVISC*WAVNUM(IJ, M, ICHNK) + TEMP1 = COEF*RAORW(IJ) + END IF + + DO K=1,NANG + DO IGST=1,NGST + + SUMF = 0.0_JWRB + SUMFSIN2 = 0.0_JWRB + + IF (LTAUWSHELTER) THEN + COSLP = COS(TH(K) - USDIRP(IGST)) + ELSE + COSLP = COSWDIF(IJ, K) + END IF + + GAM0(IGST, K) = 0._JWRB + IF (COSLP > 0.01_JWRB) THEN + X = COSLP*UCN(IGST) + ZLOG = ZCN + UCNZALPD(IGST) / COSLP + IF (ZLOG < 0.0_JWRB) THEN + ZLOG2X = ZLOG*ZLOG*X + GAM0(IGST, K) = EXP(ZLOG)*ZLOG2X*ZLOG2X*CNSN + XLLWS(IJ, K, M, ICHNK) = 1.0_JWRB + END IF + END IF + + IF (LLSNEG) THEN + DSTAB2 = TEMP1*(TEMP2 + (FU + FUD*COSLP)*USTP(IGST)) + DSTAB(IGST, K) = DSTAB1 + PTURB*DSTAB2 + END IF + + SUMF = SUMF + GAM0(IGST, K)*FL1(IJ, K, M, ICHNK) + SUMFSIN2 = SUMFSIN2 + GAM0(IGST, K)*FL1(IJ, K, M, ICHNK)*SINWDIF2(IJ, K) + END DO + END DO + + IF (LLNORMAGAM) THEN + + XNGAMCONST = CSTRNFAC*XK2CG(IJ, M, ICHNK) + DO IGST=1,NGST + ZNZ = XNGAMCONST*USTPM1(IGST) + GAMNORMA(IGST) = (1.0_JWRB + ZNZ*SUMFSIN2) / (1.0_JWRB + ZNZ*SUMF) + END DO + + END IF + + + + !* 2.2 UPDATE THE SHELTERING STRESS (in any), + ! AND THEN ADDING INPUT SOURCE TERM TO NET SOURCE FUNCTION. + ! --------------------------------------------------------- + + DO K=1,NANG + + DO IGST=1,NGST + ! SLP: only the positive contributions + SLP(IGST) = GAM0(IGST, K)*GAMNORMA(IGST) + FLP(IGST) = SLP(IGST) + DSTAB(IGST, K) + END DO + + DO IGST=1,NGST + SLP(IGST) = SLP(IGST)*FL1(IJ, K, M, ICHNK) + END DO + + IF (LTAUWSHELTER) THEN + CONST11 = CONSTF*SINTH(K) + CONST22 = CONSTF*COSTH(K) + DO IGST=1,NGST + XSTRESS(IGST) = XSTRESS(IGST) + SLP(IGST)*CONST11 + YSTRESS(IGST) = YSTRESS(IGST) + SLP(IGST)*CONST22 + END DO + END IF + + IGST = 1 + SLP_AVG = SLP(IGST) + FLP_AVG = FLP(IGST) + DO IGST=2,NGST + SLP_AVG = SLP_AVG + SLP(IGST) + FLP_AVG = FLP_AVG + FLP(IGST) + END DO + + SPOS(IJ, K, M) = AVG_GST*SLP_AVG + FLD(IJ, K, M) = AVG_GST*FLP_AVG + SL(IJ, K, M) = FLD(IJ, K, M)*FL1(IJ, K, M, ICHNK) + + END DO + + END DO + + ! END LOOP OVER FREQUENCIES + + + END SUBROUTINE SINPUT_ARD_CUF_HOIST_NEW + ATTRIBUTES(DEVICE) SUBROUTINE SINPUT_JAN_CUF_HOIST_NEW (NGST, LLSNEG, KIJS, KIJL, FL1, WAVNUM, CINV, XK2CG, WSWAVE, UFRIC, & + & Z0M, COSWDIF, SINWDIF2, RAORW, WSTAR, RNFAC, FLD, SL, SPOS, XLLWS, ACDLIN, ALPHAMAX, ALPHAMIN, BCDLIN, BETAMAXOXKAPPA2, & + & DELTH, EPSUS, G, IDAMPING, LLGCBZ0, LLNORMAGAM, NANG, NFRE, RNUM, WSPMIN, XKAPPA, ZALP, ZPI, ZPIFR, ICHNK, NCHNK, IJ) + ! ---------------------------------------------------------------------- + + !**** *SINPUT_JAN* - COMPUTATION OF INPUT SOURCE FUNCTION. + + ! P.A.E.M. JANSSEN KNMI AUGUST 1990 + + ! OPTIMIZED BY : H. GUENTHER + + ! MODIFIED BY : + ! J-R BIDLOT NOVEMBER 1995 + ! J-R BIDLOT FEBRUARY 1996-97 + ! J-R BIDLOT FEBRUARY 1999 : INTRODUCE ICALL AND NCALL + ! P.A.E.M. JANSSEN MAY 2000 : INTRODUCE GUSTINESS + ! J-R BIDLOT FEBRUARY 2001 : MAKE IT FULLY IMPLICIT BY ONLY + ! USING NEW STRESS AND ROUGHNESS. + ! S. ABDALLA OCTOBER 2001: INTRODUCTION OF VARIABLE AIR + ! DENSITY AND STABILITY-DEPENDENT + ! WIND GUSTINESS + ! P.A.E.M. JANSSEN OCTOBER 2008: INTRODUCE DAMPING WHEN WAVES ARE + ! RUNNING FASTER THAN THE WIND. + ! J-R BIDLOT JANUARY 2013: SHALLOW WATER FORMULATION. + + !* PURPOSE. + ! --------- + + ! COMPUTE INPUT SOURCE FUNCTION AND STORE ADDITIVELY INTO NET + ! SOURCE FUNCTION ARRAY, ALSO COMPUTE FUNCTIONAL DERIVATIVE OF + ! INPUT SOURCE FUNCTION. + ! + ! GUSTINESS IS INTRODUCED FOLL0WING THE APPROACH OF JANSSEN(1986), + ! USING A GAUSS-HERMITE APPROXIMATION SUGGESTED BY MILES(1997). + ! IN THE PRESENT VERSION ONLY TWO HERMITE POLYNOMIALS ARE UTILISED + ! IN THE EVALUATION OF THE PROBABILITY INTEGRAL. EXPLICITELY ONE THEN + ! FINDS: + ! + ! = 0.5*( GAMMA(X(1+SIG)) + GAMMA(X(1-SIG)) ) + ! + ! WHERE X IS THE FRICTION VELOCITY AND SIG IS THE RELATIVE GUSTINESS + ! LEVEL. + + !** INTERFACE. + ! ---------- + + ! *CALL* *SINPUT_JAN (NGST, LLSNEG, KIJS, KIJL, FL1, + ! & WAVNUM, CINV, XK2CG, + ! & WDWAVE, WSWAVE, 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* - 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 + ! *RNFAC* - WIND DEPENDENT FACTOR USED IN THE GROWTH RENORMALISATION. + ! *WSTAR* - FREE CONVECTION VELOCITY SCALE (M/S). + ! *FLD* - DIAGONAL MATRIX OF FUNCTIONAL DERIVATIVE. + ! *SL* - TOTAL SOURCE FUNCTION ARRAY. + ! *SPOS* - ONLY POSITIVE PART OF INPUT SOURCE FUNCTION ARRAY. + ! *XLLWS* - 1 WHERE SINPUT IS POSITIVE. + + + ! METHOD. + ! ------- + + ! SEE REFERENCE. + + ! EXTERNALS. + ! ---------- + + ! WSIGSTAR. + + ! MODIFICATIONS + ! ------------- + + ! - REMOVAL OF CALL TO CRAY SPECIFIC FUNCTIONS EXPHF AND ALOGHF + ! BY THEIR STANDARD FORTRAN EQUIVALENT EXP and ALOGHF + ! - MODIFIED TO MAKE INTEGRATION SCHEME FULLY IMPLICIT + ! - INTRODUCTION OF VARIABLE AIR DENSITY + ! - INTRODUCTION OF WIND GUSTINESS + + ! REFERENCE. + ! ---------- + + ! P. JANSSEN, J.P.O., 1989. + ! P. JANSSEN, J.P.O., 1991 + + ! ---------------------------------------------------------------------- + + USE cudafor + USE PARKIND_WAVE, ONLY: JWIM, JWRU, JWRB + + USE YOWFRED, ONLY: TH + USE YOWFRED, ONLY: FR, TH + USE YOWPARAM, ONLY: NANG_PARAM + USE YOWPCONS, ONLY: GM1 + USE YOWTEST, ONLY: IU06 + + + ! ---------------------------------------------------------------------- + + IMPLICIT NONE + + INTEGER(KIND=JWIM), PARAMETER :: NANG_loki_param = 24 + INTEGER(KIND=JWIM), PARAMETER :: NFRE_loki_param = 36 + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NGST + LOGICAL, VALUE, INTENT(IN) :: LLSNEG + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJS + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJL + REAL(KIND=JWRB), INTENT(IN) :: FL1(KIJL, NANG_loki_param, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: WAVNUM(KIJL, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: CINV(KIJL, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: XK2CG(KIJL, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: WSWAVE(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: UFRIC(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: Z0M(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: COSWDIF(KIJL, NANG_loki_param) + REAL(KIND=JWRB), INTENT(IN) :: SINWDIF2(KIJL, NANG_loki_param) + REAL(KIND=JWRB), INTENT(IN) :: RAORW(KIJL) + REAL(KIND=JWRB), INTENT(IN) :: RNFAC(KIJL) + REAL(KIND=JWRB), INTENT(IN) :: WSTAR(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(OUT) :: FLD(KIJL, NANG_loki_param, NFRE_loki_param) + REAL(KIND=JWRB), INTENT(OUT) :: SL(KIJL, NANG_loki_param, NFRE_loki_param) + REAL(KIND=JWRB), INTENT(OUT) :: SPOS(KIJL, NANG_loki_param, NFRE_loki_param) + REAL(KIND=JWRB), INTENT(OUT) :: XLLWS(KIJL, NANG_loki_param, NFRE_loki_param, NCHNK) + + + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: IJ + INTEGER(KIND=JWIM) :: IG + INTEGER(KIND=JWIM) :: K + INTEGER(KIND=JWIM) :: M + INTEGER(KIND=JWIM) :: IGST + + REAL(KIND=JWRB) :: CONST1 + REAL(KIND=JWRB) :: CONST3 + REAL(KIND=JWRB) :: XKAPPAD + REAL(KIND=JWRB) :: CONSTN + REAL(KIND=JWRB) :: ZNZ + REAL(KIND=JWRB) :: X + REAL(KIND=JWRB) :: ZLOG + REAL(KIND=JWRB) :: ZLOG2X + REAL(KIND=JWRB) :: ZBETA + REAL(KIND=JWRB) :: TEMPD + + REAL(KIND=JWRB) :: WSIN(2) + REAL(KIND=JWRB) :: ZTANHKD + REAL(KIND=JWRB) :: SIG_N + REAL(KIND=JWRB) :: CNSN + REAL(KIND=JWRB) :: SUMF + REAL(KIND=JWRB) :: SUMFSIN2 + REAL(KIND=JWRB) :: CSTRNFAC + REAL(KIND=JWRB) :: UFAC1 + REAL(KIND=JWRB) :: UFAC2 + REAL(KIND=JWRB) :: GAMNORMA(2) ! ! RENORMALISATION FACTOR OF THE GROWTH RATE + REAL(KIND=JWRB) :: SIGDEV(2) + REAL(KIND=JWRB) :: US(2) + REAL(KIND=JWRB) :: Z0(2) + REAL(KIND=JWRB) :: UCN(2) + REAL(KIND=JWRB) :: ZCN(2) + REAL(KIND=JWRB) :: USTPM1(2) + REAL(KIND=JWRB) :: XVD(2) + REAL(KIND=JWRB) :: UCND(2) + REAL(KIND=JWRB) :: CONST3_UCN2(2) + REAL(KIND=JWRB) :: GAM0(2, NANG_PARAM) + + LOGICAL :: LZ + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ACDLIN + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ALPHAMAX + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ALPHAMIN + REAL(KIND=JWRB), VALUE, INTENT(IN) :: BCDLIN + REAL(KIND=JWRB), VALUE, INTENT(IN) :: BETAMAXOXKAPPA2 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: DELTH + REAL(KIND=JWRB), VALUE, INTENT(IN) :: EPSUS + REAL(KIND=JWRB), VALUE, INTENT(IN) :: G + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: IDAMPING + LOGICAL, VALUE, INTENT(IN) :: LLGCBZ0 + LOGICAL, VALUE, INTENT(IN) :: LLNORMAGAM + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NANG + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NFRE + REAL(KIND=JWRB), VALUE, INTENT(IN) :: RNUM + REAL(KIND=JWRB), VALUE, INTENT(IN) :: WSPMIN + REAL(KIND=JWRB), VALUE, INTENT(IN) :: XKAPPA + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ZALP + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ZPI + REAL(KIND=JWRB), INTENT(IN), DEVICE :: ZPIFR(NFRE_loki_param) + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: ICHNK + INTEGER, VALUE, INTENT(IN) :: NCHNK + + ! ---------------------------------------------------------------------- + + + CONST1 = BETAMAXOXKAPPA2 + CONST3 = 2.0_JWRB*XKAPPA / CONST1 ! SEE IDAMPING + XKAPPAD = 1.E0_JWRB / XKAPPA + + CONST3 = IDAMPING*CONST3 + + CONSTN = DELTH / (XKAPPA*ZPI) + + ! ESTIMATE THE STANDARD DEVIATION OF GUSTINESS. + + IF (NGST > 1) THEN + CALL WSIGSTAR_CUF_HOIST_NEW(WSWAVE(IJ, ICHNK), UFRIC(IJ, ICHNK), Z0M(IJ, ICHNK), WSTAR(IJ, ICHNK), SIG_N, ACDLIN, & + & ALPHAMAX, ALPHAMIN, BCDLIN, EPSUS, G, LLGCBZ0, RNUM, WSPMIN, XKAPPA) + END IF + + ! DEFINE WHERE SINPUT WILL BE EVALUATED IN RELATIVE TERM WRT USTAR + ! DEFINE ALSO THE RELATIVE WEIGHT OF EACH. + + IF (NGST == 1) THEN + WSIN(1) = 1.0_JWRB + SIGDEV(1) = 1.0_JWRB + ELSE + WSIN(1) = 0.5_JWRB + WSIN(2) = 0.5_JWRB + SIGDEV(1) = 1.0_JWRB - SIG_N + SIGDEV(2) = 1.0_JWRB + SIG_N + END IF + + + IF (NGST == 1) THEN + US(1) = UFRIC(IJ, ICHNK) + Z0(1) = Z0M(IJ, ICHNK) + ELSE + DO IGST=1,NGST + US(IGST) = UFRIC(IJ, ICHNK)*SIGDEV(IGST) + Z0(IGST) = Z0M(IJ, ICHNK) + END DO + END IF + + DO IGST=1,NGST + USTPM1(IGST) = 1.0_JWRB / MAX(US(IGST), EPSUS) + END DO + + ! ---------------------------------------------------------------------- + + !* 2. LOOP OVER FREQUENCIES. + ! ---------------------- + + DO M=1,NFRE + + !* PRECALCULATE FREQUENCY DEPENDENCE. + ! ---------------------------------- + + ZTANHKD = ZPIFR(M)**2 / (G*WAVNUM(IJ, M, ICHNK)) + CNSN = CONST1*ZPIFR(M)*ZTANHKD*RAORW(IJ) + + DO IGST=1,NGST + UCN(IGST) = US(IGST)*CINV(IJ, M, ICHNK) + ZALP + CONST3_UCN2(IGST) = CONST3*UCN(IGST)**2 + UCND(IGST) = 1.0_JWRB / UCN(IGST) + ZCN(IGST) = LOG(WAVNUM(IJ, M, ICHNK)*Z0(IGST)) + XVD(IGST) = 1.0_JWRB / (-US(IGST)*XKAPPAD*ZCN(IGST)*CINV(IJ, M, ICHNK)) + END DO + + !* 2.1 LOOP OVER DIRECTIONS. + ! --------------------- + + ! WIND INPUT: + DO K=1,NANG + XLLWS(IJ, K, M, ICHNK) = 0.0_JWRB + + DO IGST=1,NGST + + IF (COSWDIF(IJ, K) > 0.01_JWRB) THEN + LZ = .true. + TEMPD = XKAPPA / COSWDIF(IJ, K) + ELSE + LZ = .false. + TEMPD = XKAPPA + END IF + + GAM0(IGST, K) = 0.0_JWRB + IF (LZ) THEN + ZLOG = ZCN(IGST) + TEMPD*UCND(IGST) + IF (ZLOG < 0.0_JWRB) THEN + X = COSWDIF(IJ, K)*UCN(IGST) + ZLOG2X = ZLOG*ZLOG*X + GAM0(IGST, K) = ZLOG2X*ZLOG2X*EXP(ZLOG)*CNSN + XLLWS(IJ, K, M, ICHNK) = 1.0_JWRB + END IF + END IF + END DO + + END DO + + + IF (LLNORMAGAM) THEN + + SUMF = 0.0_JWRB + SUMFSIN2 = 0.0_JWRB + DO K=1,NANG + DO IGST=1,NGST + SUMF = SUMF + GAM0(IGST, K)*FL1(IJ, K, M, ICHNK) + SUMFSIN2 = SUMFSIN2 + GAM0(IGST, K)*FL1(IJ, K, M, ICHNK)*SINWDIF2(IJ, K) + END DO + + CSTRNFAC = CONSTN*RNFAC(IJ) / RAORW(IJ) + ZNZ = CSTRNFAC*XK2CG(IJ, M, ICHNK)*USTPM1(IGST) + GAMNORMA(IGST) = (1.0_JWRB + ZNZ*SUMFSIN2) / (1.0_JWRB + ZNZ*SUMF) + + END DO + ELSE + DO IGST=1,NGST + GAMNORMA(IGST) = 1.0_JWRB + END DO + END IF + + DO K=1,NANG + UFAC1 = WSIN(1)*GAM0(1, K)*GAMNORMA(1) + DO IGST=2,NGST + UFAC1 = UFAC1 + WSIN(IGST)*GAM0(IGST, K)*GAMNORMA(IGST) + END DO + + UFAC2 = 0.0_JWRB + IF (LLSNEG) THEN + ! SWELL DAMPING: + ZBETA = CONST3_UCN2(1)*(COSWDIF(IJ, K) - XVD(1)) + UFAC2 = WSIN(1)*ZBETA + DO IGST=2,NGST + ZBETA = CONST3_UCN2(IGST)*(COSWDIF(IJ, K) - XVD(IGST)) + UFAC2 = UFAC2 + WSIN(IGST)*ZBETA + END DO + END IF + + FLD(IJ, K, M) = UFAC1 + UFAC2*CNSN + SPOS(IJ, K, M) = UFAC1*FL1(IJ, K, M, ICHNK) + SL(IJ, K, M) = FLD(IJ, K, M)*FL1(IJ, K, M, ICHNK) + END DO + + !* 2.2 ADDING INPUT SOURCE TERM TO NET SOURCE FUNCTION. + ! ------------------------------------------------ + + END DO + + + + END SUBROUTINE SINPUT_JAN_CUF_HOIST_NEW +END MODULE SINPUT_ARD_CUF_HOIST_NEW_MOD diff --git a/src/phys-scc-cuf-hoist/snonlin.cuf_hoist_new.F90 b/src/phys-scc-cuf-hoist/snonlin.cuf_hoist_new.F90 new file mode 100644 index 00000000..c6950de5 --- /dev/null +++ b/src/phys-scc-cuf-hoist/snonlin.cuf_hoist_new.F90 @@ -0,0 +1,465 @@ +! (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. +! +MODULE SNONLIN_CUF_HOIST_NEW_MOD + CONTAINS + ATTRIBUTES(DEVICE) SUBROUTINE SNONLIN_CUF_HOIST_NEW (KIJS, KIJL, FL1, FLD, SL, WAVNUM, DEPTH, AKMEAN, AF11, BATHYMAX, COSTH, & + & DAL1, DAL2, DELTH, DFIM, DFIMFR, DFIMFR2, DKMAX, FKLAM, FKLAM1, FKLAP, FKLAP1, FR, FRATIO, G, GM1, IKM, IKM1, IKP, IKP1, & + & INLCOEF, ISNONLIN, K11W, K1W, K21W, K2W, KFRH, MFRSTLW, MLSTHG, NANG, NFRE, RNLCOEF, SINTH, TH, WETAIL, WP1TAIL, WP2TAIL, & + & XKDMIN, ZPIFR, ICHNK, NCHNK, IJ, XNU, SIG_TH, ENH) + + ! ---------------------------------------------------------------------- + + !**** *SNONLIN* - COMPUTATION OF NONLINEAR TRANSFER RATE AND ITS + !**** FUNCTIONAL DERIVATIVE (DIAGONAL TERMS ONLY) AND + !**** ADDITION TO CORRESPONDING NET EXPRESSIONS. + + ! S.D. HASSELMANN. MPI + + ! G. KOMEN, P. JANSSEN KNMI MODIFIED TO SHALLOW WATER + ! H. GUENTHER, L. ZAMBRESKY OPTIMIZED + ! H. GUENTHER GKSS/ECMWF JUNE 1991 INTERACTIONS BETWEEN DIAG- + ! AND PROGNOSTIC PART. + ! J. BIDLOT ECMWF FEBRUARY 1997 ADD SL IN SUBROUTINE CALL + ! P. JANSSEN ECMWF JUNE 2005 IMPROVED SCALING IN SHALLOW + ! WATER + ! J. BIDLOT ECMWF AUGUST 2006 KEEP THE OLD FORMULATION + ! UNDER A SWITCH (ISNONLIN = 0 for OLD + ! = 1 for NEW + ! BE AWARE THAT THE OLD FORMULATION + ! REQUIRES THE MEAN WAVE NUMBER AKMEAN. + ! J. BIDLOT ECMWF JANUARY 2012 ADD EXTENSION TO LOW FREQUENCIES + ! OPTIMISATION FOR IBM. + + !* PURPOSE. + ! -------- + + ! SEE ABOVE. + + !** INTERFACE. + ! ---------- + + ! *CALL* *SNONLIN (KIJS, KIJL, FL1, FLD, SL, WAVNUM, DEPTH, AKMEAN)* + ! *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. + ! *DEPTH* - WATER DEPTH. + ! *AKMEAN* - MEAN WAVE NUMBER BASED ON sqrt(1/k)*F INTGRATION + + ! METHOD. + ! ------- + + ! NONE. + + ! EXTERNALS. + ! ---------- + + ! NONE. + + ! REFERENCE. + ! ---------- + + ! NONE. + + ! ---------------------------------------------------------------------- + USE TRANSF_SNL_CUF_HOIST_NEW_MOD, ONLY: TRANSF_SNL_CUF_HOIST_NEW + USE TRANSF_CUF_HOIST_NEW_MOD, ONLY: TRANSF_CUF_HOIST_NEW + USE PEAK_ANG_CUF_HOIST_NEW_MOD, ONLY: PEAK_ANG_CUF_HOIST_NEW + USE cudafor + USE PARKIND_WAVE, ONLY: JWIM, JWRU, JWRB + + + + ! ---------------------------------------------------------------------- + + IMPLICIT NONE + INTEGER(KIND=JWIM), PARAMETER :: NANG_loki_param = 24 + INTEGER(KIND=JWIM), PARAMETER :: NFRE_loki_param = 36 + INTEGER(KIND=JWIM), PARAMETER :: NRNL = 25 + INTEGER(KIND=JWIM), PARAMETER :: NINL = 5 + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJS + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJL + REAL(KIND=JWRB), INTENT(IN) :: FL1(KIJL, NANG_loki_param, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: FLD(KIJL, NANG_loki_param, NFRE_loki_param) + REAL(KIND=JWRB), INTENT(INOUT) :: SL(KIJL, NANG_loki_param, NFRE_loki_param) + REAL(KIND=JWRB), INTENT(IN) :: WAVNUM(KIJL, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: DEPTH(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: AKMEAN(KIJL) + + + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: IJ + INTEGER(KIND=JWIM) :: K + INTEGER(KIND=JWIM) :: M + INTEGER(KIND=JWIM) :: MC + INTEGER(KIND=JWIM) :: KH + INTEGER(KIND=JWIM) :: K1 + INTEGER(KIND=JWIM) :: K2 + INTEGER(KIND=JWIM) :: K11 + INTEGER(KIND=JWIM) :: K21 + INTEGER(KIND=JWIM) :: MP + INTEGER(KIND=JWIM) :: MP1 + INTEGER(KIND=JWIM) :: MM + INTEGER(KIND=JWIM) :: MM1 + INTEGER(KIND=JWIM) :: IC + INTEGER(KIND=JWIM) :: IP + INTEGER(KIND=JWIM) :: IP1 + INTEGER(KIND=JWIM) :: IM + INTEGER(KIND=JWIM) :: IM1 + INTEGER(KIND=JWIM) :: MFR1STFR + INTEGER(KIND=JWIM) :: MFRLSTFR + + REAL(KIND=JWRB), PARAMETER :: ENH_MAX = 10.0_JWRB + REAL(KIND=JWRB), PARAMETER :: ENH_MIN = 0.1_JWRB ! to prevent ENH to become too small + REAL(KIND=JWRB) :: XK + ! REAL(KIND=JWRB) :: ENH(MLSTHG) + REAL(KIND=JWRB), INTENT(INOUT), DEVICE, DIMENSION(KIJL, MLSTHG) :: ENH + + REAL(KIND=JWRB) :: FTAIL + REAL(KIND=JWRB) :: FKLAMP + REAL(KIND=JWRB) :: GW1 + REAL(KIND=JWRB) :: GW2 + REAL(KIND=JWRB) :: GW3 + REAL(KIND=JWRB) :: GW4 + REAL(KIND=JWRB) :: FKLAMPA + REAL(KIND=JWRB) :: FKLAMPB + REAL(KIND=JWRB) :: FKLAMP2 + REAL(KIND=JWRB) :: FKLAMP1 + REAL(KIND=JWRB) :: FKLAPA2 + REAL(KIND=JWRB) :: FKLAPB2 + REAL(KIND=JWRB) :: FKLAP12 + REAL(KIND=JWRB) :: FKLAP22 + REAL(KIND=JWRB) :: FKLAMM + REAL(KIND=JWRB) :: FKLAMM1 + REAL(KIND=JWRB) :: GW5 + REAL(KIND=JWRB) :: GW6 + REAL(KIND=JWRB) :: GW7 + REAL(KIND=JWRB) :: GW8 + REAL(KIND=JWRB) :: FKLAMMA + REAL(KIND=JWRB) :: FKLAMMB + REAL(KIND=JWRB) :: FKLAMM2 + REAL(KIND=JWRB) :: FKLAMA2 + REAL(KIND=JWRB) :: FKLAMB2 + REAL(KIND=JWRB) :: FKLAM12 + REAL(KIND=JWRB) :: FKLAM22 + REAL(KIND=JWRB) :: SAP + REAL(KIND=JWRB) :: SAM + REAL(KIND=JWRB) :: FIJ + REAL(KIND=JWRB) :: FAD1 + REAL(KIND=JWRB) :: FAD2 + REAL(KIND=JWRB) :: FCEN + + REAL(KIND=JWRB), INTENT(INOUT) :: XNU(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: SIG_TH(KIJL, NCHNK) + REAL(KIND=JWRB) :: FTEMP + REAL(KIND=JWRB) :: AD + REAL(KIND=JWRB) :: DELAD + REAL(KIND=JWRB) :: DELAP + REAL(KIND=JWRB) :: DELAM + REAL(KIND=JWRB) :: ENHFR + REAL(KIND=JWRB), INTENT(IN), DEVICE :: AF11(MFRSTLW:MLSTHG) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: BATHYMAX + REAL(KIND=JWRB), INTENT(IN), DEVICE :: COSTH(NFRE_loki_param) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: DAL1 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: DAL2 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: DELTH + REAL(KIND=JWRB), INTENT(IN), DEVICE :: DFIM(NFRE_loki_param) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: DFIMFR(NFRE_loki_param) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: DFIMFR2(NFRE_loki_param) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: DKMAX + REAL(KIND=JWRB), INTENT(IN), DEVICE :: FKLAM(MFRSTLW:MLSTHG) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: FKLAM1(MFRSTLW:MLSTHG) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: FKLAP(MFRSTLW:MLSTHG) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: FKLAP1(MFRSTLW:MLSTHG) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: FR(NFRE_loki_param) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: FRATIO + REAL(KIND=JWRB), VALUE, INTENT(IN) :: G + REAL(KIND=JWRB), VALUE, INTENT(IN) :: GM1 + INTEGER(KIND=JWIM), INTENT(IN), DEVICE :: IKM(MFRSTLW:MLSTHG) + INTEGER(KIND=JWIM), INTENT(IN), DEVICE :: IKM1(MFRSTLW:MLSTHG) + INTEGER(KIND=JWIM), INTENT(IN), DEVICE :: IKP(MFRSTLW:MLSTHG) + INTEGER(KIND=JWIM), INTENT(IN), DEVICE :: IKP1(MFRSTLW:MLSTHG) + INTEGER(KIND=JWIM), INTENT(IN), DEVICE :: INLCOEF(NINL, 1:MLSTHG) + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: ISNONLIN + INTEGER(KIND=JWIM), INTENT(IN), DEVICE :: K11W(NANG_loki_param, 2) + INTEGER(KIND=JWIM), INTENT(IN), DEVICE :: K1W(NANG_loki_param, 2) + INTEGER(KIND=JWIM), INTENT(IN), DEVICE :: K21W(NANG_loki_param, 2) + INTEGER(KIND=JWIM), INTENT(IN), DEVICE :: K2W(NANG_loki_param, 2) + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KFRH + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: MFRSTLW + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: MLSTHG + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NANG + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NFRE + REAL(KIND=JWRB), INTENT(IN), DEVICE :: RNLCOEF(NRNL, 1:MLSTHG) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: SINTH(NFRE_loki_param) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: TH(NFRE_loki_param) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: WETAIL + REAL(KIND=JWRB), VALUE, INTENT(IN) :: WP1TAIL + REAL(KIND=JWRB), VALUE, INTENT(IN) :: WP2TAIL + REAL(KIND=JWRB), VALUE, INTENT(IN) :: XKDMIN + REAL(KIND=JWRB), INTENT(IN), DEVICE :: ZPIFR(NFRE_loki_param) + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: ICHNK + INTEGER, VALUE, INTENT(IN) :: NCHNK + + + ! ---------------------------------------------------------------------- + + + + !* 1. SHALLOW WATER SCALING + ! --------------------- + + SELECT CASE (ISNONLIN) + CASE (0) + + ENHFR = MAX(0.75_JWRB*DEPTH(IJ, ICHNK)*AKMEAN(IJ), 0.5_JWRB) + ENHFR = 1.0_JWRB + (5.5_JWRB / ENHFR)*(1.0_JWRB - .833_JWRB*ENHFR)*EXP(-1.25_JWRB*ENHFR) + DO MC=1,MLSTHG + ENH(IJ, MC) = ENHFR + END DO + + + CASE (1) + + DO MC=1,NFRE + ENH(IJ, MC) = MAX(MIN(ENH_MAX, TRANSF_CUF_HOIST_NEW(WAVNUM(IJ, MC, ICHNK), DEPTH(IJ, ICHNK), DKMAX, G)), ENH_MIN) + END DO + DO MC=NFRE + 1,MLSTHG + XK = GM1*(ZPIFR(NFRE)*FRATIO**(MC - NFRE))**2 + ENH(IJ, MC) = MAX(MIN(ENH_MAX, TRANSF_CUF_HOIST_NEW(XK, DEPTH(IJ, ICHNK), DKMAX, G)), ENH_MIN) + END DO + + + CASE (2) + CALL PEAK_ANG_CUF_HOIST_NEW(KIJS, KIJL, FL1(:, :, :, :), XNU(:, ICHNK), SIG_TH(:, ICHNK), COSTH(:), DELTH, DFIM(:), & + & DFIMFR(:), DFIMFR2(:), FR(:), FRATIO, NANG, NFRE, SINTH(:), TH(:), WETAIL, WP1TAIL, WP2TAIL, ICHNK, NCHNK, IJ) + + DO MC=1,NFRE + ENH(IJ, MC) = TRANSF_SNL_CUF_HOIST_NEW(WAVNUM(IJ, MC, ICHNK), DEPTH(IJ, ICHNK), XNU(IJ, ICHNK), SIG_TH(IJ, ICHNK), BATHYMAX, & + & DKMAX, G, XKDMIN) + END DO + DO MC=NFRE + 1,MLSTHG + XK = GM1*(ZPIFR(NFRE)*FRATIO**(MC - NFRE))**2 + ENH(IJ, MC) = TRANSF_SNL_CUF_HOIST_NEW(XK, DEPTH(IJ, ICHNK), XNU(IJ, ICHNK), SIG_TH(IJ, ICHNK), BATHYMAX, DKMAX, G, XKDMIN) + END DO + + END SELECT + + + !* 2. FREQUENCY LOOP. + ! --------------- + + MFR1STFR = -MFRSTLW + 1 + MFRLSTFR = NFRE - KFRH + MFR1STFR + + + DO MC=1,MLSTHG + MP = IKP(MC) + MP1 = IKP1(MC) + MM = IKM(MC) + MM1 = IKM1(MC) + IC = INLCOEF(1, MC) + IP = INLCOEF(2, MC) + IP1 = INLCOEF(3, MC) + IM = INLCOEF(4, MC) + IM1 = INLCOEF(5, MC) + + FTAIL = RNLCOEF(1, MC) + + FKLAMP = FKLAP(MC) + FKLAMP1 = FKLAP1(MC) + GW1 = RNLCOEF(2, MC) + GW2 = RNLCOEF(3, MC) + GW3 = RNLCOEF(4, MC) + GW4 = RNLCOEF(5, MC) + FKLAMPA = RNLCOEF(6, MC) + FKLAMPB = RNLCOEF(7, MC) + FKLAMP2 = RNLCOEF(8, MC) + FKLAMP1 = RNLCOEF(9, MC) + FKLAPA2 = RNLCOEF(10, MC) + FKLAPB2 = RNLCOEF(11, MC) + FKLAP12 = RNLCOEF(12, MC) + FKLAP22 = RNLCOEF(13, MC) + + FKLAMM = FKLAM(MC) + FKLAMM1 = FKLAM1(MC) + GW5 = RNLCOEF(14, MC) + GW6 = RNLCOEF(15, MC) + GW7 = RNLCOEF(16, MC) + GW8 = RNLCOEF(17, MC) + FKLAMMA = RNLCOEF(18, MC) + FKLAMMB = RNLCOEF(19, MC) + FKLAMM2 = RNLCOEF(20, MC) + FKLAMM1 = RNLCOEF(21, MC) + FKLAMA2 = RNLCOEF(22, MC) + FKLAMB2 = RNLCOEF(23, MC) + FKLAM12 = RNLCOEF(24, MC) + FKLAM22 = RNLCOEF(25, MC) + + FTEMP = AF11(MC)*ENH(IJ, MC) + + + IF (MC > MFR1STFR .and. MC < MFRLSTFR) THEN + ! the interactions for MC are all within the fully resolved spectral domain + + DO KH=1,2 + DO K=1,NANG + K1 = K1W(K, KH) + K2 = K2W(K, KH) + K11 = K11W(K, KH) + K21 = K21W(K, KH) + + !* 2.1.1.1 LOOP OVER GRIDPOINTS.. NONLINEAR TRANSFER AND + !* DIAGONAL MATRIX OF FUNCTIONAL DERIVATIVE. + ! ---------------------------------------------- + SAP = GW1*FL1(IJ, K1, IP, ICHNK) + GW2*FL1(IJ, K11, IP, ICHNK) + GW3*FL1(IJ, K1, IP1, ICHNK) + GW4*FL1(IJ, K11, IP1, & + & ICHNK) + SAM = GW5*FL1(IJ, K2, IM, ICHNK) + GW6*FL1(IJ, K21, IM, ICHNK) + GW7*FL1(IJ, K2, IM1, ICHNK) + GW8*FL1(IJ, K21, IM1, & + & ICHNK) + !!!! not needed ftail always=1. FIJ = FL1(IJ,K ,IC )*FTAIL + FIJ = FL1(IJ, K, IC, ICHNK) + FAD1 = FIJ*(SAP + SAM) + FAD2 = FAD1 - 2.0_JWRB*SAP*SAM + FAD1 = FAD1 + FAD2 + FCEN = FTEMP*FIJ + AD = FAD2*FCEN + DELAD = FAD1*FTEMP + DELAP = (FIJ - 2.0_JWRB*SAM)*DAL1*FCEN + DELAM = (FIJ - 2.0_JWRB*SAP)*DAL2*FCEN + + SL(IJ, K, MC) = SL(IJ, K, MC) - 2.0_JWRB*AD + FLD(IJ, K, MC) = FLD(IJ, K, MC) - 2.0_JWRB*DELAD + SL(IJ, K2, MM) = SL(IJ, K2, MM) + AD*FKLAMM1 + FLD(IJ, K2, MM) = FLD(IJ, K2, MM) + DELAM*FKLAM12 + SL(IJ, K21, MM) = SL(IJ, K21, MM) + AD*FKLAMM2 + FLD(IJ, K21, MM) = FLD(IJ, K21, MM) + DELAM*FKLAM22 + SL(IJ, K2, MM1) = SL(IJ, K2, MM1) + AD*FKLAMMA + FLD(IJ, K2, MM1) = FLD(IJ, K2, MM1) + DELAM*FKLAMA2 + SL(IJ, K21, MM1) = SL(IJ, K21, MM1) + AD*FKLAMMB + FLD(IJ, K21, MM1) = FLD(IJ, K21, MM1) + DELAM*FKLAMB2 + SL(IJ, K1, MP) = SL(IJ, K1, MP) + AD*FKLAMP1 + FLD(IJ, K1, MP) = FLD(IJ, K1, MP) + DELAP*FKLAP12 + SL(IJ, K11, MP) = SL(IJ, K11, MP) + AD*FKLAMP2 + FLD(IJ, K11, MP) = FLD(IJ, K11, MP) + DELAP*FKLAP22 + SL(IJ, K1, MP1) = SL(IJ, K1, MP1) + AD*FKLAMPA + FLD(IJ, K1, MP1) = FLD(IJ, K1, MP1) + DELAP*FKLAPA2 + SL(IJ, K11, MP1) = SL(IJ, K11, MP1) + AD*FKLAMPB + FLD(IJ, K11, MP1) = FLD(IJ, K11, MP1) + DELAP*FKLAPB2 + END DO + END DO + + ELSE IF (MC >= MFRLSTFR) THEN + DO KH=1,2 + DO K=1,NANG + K1 = K1W(K, KH) + K2 = K2W(K, KH) + K11 = K11W(K, KH) + K21 = K21W(K, KH) + + SAP = GW1*FL1(IJ, K1, IP, ICHNK) + GW2*FL1(IJ, K11, IP, ICHNK) + GW3*FL1(IJ, K1, IP1, ICHNK) + GW4*FL1(IJ, K11, IP1, & + & ICHNK) + SAM = GW5*FL1(IJ, K2, IM, ICHNK) + GW6*FL1(IJ, K21, IM, ICHNK) + GW7*FL1(IJ, K2, IM1, ICHNK) + GW8*FL1(IJ, K21, IM1, & + & ICHNK) + FIJ = FL1(IJ, K, IC, ICHNK)*FTAIL + FAD1 = FIJ*(SAP + SAM) + FAD2 = FAD1 - 2.0_JWRB*SAP*SAM + FAD1 = FAD1 + FAD2 + FCEN = FTEMP*FIJ + AD = FAD2*FCEN + DELAD = FAD1*FTEMP + DELAP = (FIJ - 2.0_JWRB*SAM)*DAL1*FCEN + DELAM = (FIJ - 2.0_JWRB*SAP)*DAL2*FCEN + + SL(IJ, K2, MM) = SL(IJ, K2, MM) + AD*FKLAMM1 + FLD(IJ, K2, MM) = FLD(IJ, K2, MM) + DELAM*FKLAM12 + SL(IJ, K21, MM) = SL(IJ, K21, MM) + AD*FKLAMM2 + FLD(IJ, K21, MM) = FLD(IJ, K21, MM) + DELAM*FKLAM22 + + IF (MM1 <= NFRE) THEN + SL(IJ, K2, MM1) = SL(IJ, K2, MM1) + AD*FKLAMMA + FLD(IJ, K2, MM1) = FLD(IJ, K2, MM1) + DELAM*FKLAMA2 + SL(IJ, K21, MM1) = SL(IJ, K21, MM1) + AD*FKLAMMB + FLD(IJ, K21, MM1) = FLD(IJ, K21, MM1) + DELAM*FKLAMB2 + + IF (MC <= NFRE) THEN + SL(IJ, K, MC) = SL(IJ, K, MC) - 2.0_JWRB*AD + FLD(IJ, K, MC) = FLD(IJ, K, MC) - 2.0_JWRB*DELAD + + IF (MP <= NFRE) THEN + SL(IJ, K1, MP) = SL(IJ, K1, MP) + AD*FKLAMP1 + FLD(IJ, K1, MP) = FLD(IJ, K1, MP) + DELAP*FKLAP12 + SL(IJ, K11, MP) = SL(IJ, K11, MP) + AD*FKLAMP2 + FLD(IJ, K11, MP) = FLD(IJ, K11, MP) + DELAP*FKLAP22 + + IF (MP1 <= NFRE) THEN + SL(IJ, K1, MP1) = SL(IJ, K1, MP1) + AD*FKLAMPA + FLD(IJ, K1, MP1) = FLD(IJ, K1, MP1) + DELAP*FKLAPA2 + SL(IJ, K11, MP1) = SL(IJ, K11, MP1) + AD*FKLAMPB + FLD(IJ, K11, MP1) = FLD(IJ, K11, MP1) + DELAP*FKLAPB2 + END IF + END IF + END IF + END IF + END DO + END DO + + ELSE + + DO KH=1,2 + DO K=1,NANG + K1 = K1W(K, KH) + K2 = K2W(K, KH) + K11 = K11W(K, KH) + K21 = K21W(K, KH) + + SAP = GW1*FL1(IJ, K1, IP, ICHNK) + GW2*FL1(IJ, K11, IP, ICHNK) + GW3*FL1(IJ, K1, IP1, ICHNK) + GW4*FL1(IJ, K11, IP1, & + & ICHNK) + SAM = GW5*FL1(IJ, K2, IM, ICHNK) + GW6*FL1(IJ, K21, IM, ICHNK) + GW7*FL1(IJ, K2, IM1, ICHNK) + GW8*FL1(IJ, K21, IM1, & + & ICHNK) + FIJ = FL1(IJ, K, IC, ICHNK)*FTAIL + FAD1 = FIJ*(SAP + SAM) + FAD2 = FAD1 - 2.0_JWRB*SAP*SAM + FAD1 = FAD1 + FAD2 + FCEN = FTEMP*FIJ + AD = FAD2*FCEN + DELAD = FAD1*FTEMP + DELAP = (FIJ - 2.0_JWRB*SAM)*DAL1*FCEN + DELAM = (FIJ - 2.0_JWRB*SAP)*DAL2*FCEN + + IF (MM1 >= 1) THEN + SL(IJ, K2, MM1) = SL(IJ, K2, MM1) + AD*FKLAMMA + FLD(IJ, K2, MM1) = FLD(IJ, K2, MM1) + DELAM*FKLAMA2 + SL(IJ, K21, MM1) = SL(IJ, K21, MM1) + AD*FKLAMMB + FLD(IJ, K21, MM1) = FLD(IJ, K21, MM1) + DELAM*FKLAMB2 + END IF + + SL(IJ, K, MC) = SL(IJ, K, MC) - 2.0_JWRB*AD + FLD(IJ, K, MC) = FLD(IJ, K, MC) - 2.0_JWRB*DELAD + SL(IJ, K1, MP) = SL(IJ, K1, MP) + AD*FKLAMP1 + FLD(IJ, K1, MP) = FLD(IJ, K1, MP) + DELAP*FKLAP12 + SL(IJ, K11, MP) = SL(IJ, K11, MP) + AD*FKLAMP2 + FLD(IJ, K11, MP) = FLD(IJ, K11, MP) + DELAP*FKLAP22 + SL(IJ, K1, MP1) = SL(IJ, K1, MP1) + AD*FKLAMPA + FLD(IJ, K1, MP1) = FLD(IJ, K1, MP1) + DELAP*FKLAPA2 + SL(IJ, K11, MP1) = SL(IJ, K11, MP1) + AD*FKLAMPB + FLD(IJ, K11, MP1) = FLD(IJ, K11, MP1) + DELAP*FKLAPB2 + END DO + END DO + + END IF + + !* BRANCH BACK TO 2. FOR NEXT FREQUENCY. + + END DO + + + + END SUBROUTINE SNONLIN_CUF_HOIST_NEW +END MODULE SNONLIN_CUF_HOIST_NEW_MOD diff --git a/src/phys-scc-cuf-hoist/stokesdrift.cuf_hoist_new.F90 b/src/phys-scc-cuf-hoist/stokesdrift.cuf_hoist_new.F90 new file mode 100644 index 00000000..f08f9678 --- /dev/null +++ b/src/phys-scc-cuf-hoist/stokesdrift.cuf_hoist_new.F90 @@ -0,0 +1,159 @@ +! (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. +! +MODULE STOKESDRIFT_CUF_HOIST_NEW_MOD + CONTAINS + ATTRIBUTES(DEVICE) SUBROUTINE STOKESDRIFT_CUF_HOIST_NEW (KIJS, KIJL, FL1, STOKFAC, WSWAVE, WDWAVE, CICOVER, USTOKES, VSTOKES, & + & CITHRSH, COSTH, DELTH, DFIM_SIM, FR, G, LICERUN, LWAMRSETCI, NANG, NFRE_ODD, SINTH, ZPI, ICHNK, NCHNK, IJ) + + ! + !*** *STOKESDRIFT* DETERMINES THE STOKES DRIFT + ! + ! PETER JANSSEN MARCH 2009 + ! + ! PURPOSE. + ! -------- + ! + ! DETERMINATION OF STOKES DRIFT VECTOR + ! + ! INTERFACE. + ! ---------- + ! *CALL* *STOKESDRIFT(KIJS, KIJL, FL1, STOKFAC, WSWAVE,WDWAVE,CICOVER,USTOKES,VSTOKES)* + ! + ! INPUT: + ! *KIJS* - FIRST GRIDPOINT + ! *KIJL* - LAST GRIDPOINT + ! *FL1* - 2-D SPECTRUM + ! *STOKFAC*- FACTOR TO COMPUTE THE STOKES DRIFT + ! Auxilliary fields to specify Stokes when model sea ice cover the blocking threshold + ! as 0.016*WSWAVE, aligned in the wind direction + ! *WSWAVE* - WIND SPEED IN M/S. + ! *WDWAVE* - WIND DIRECTION IN RADIANS. + ! *CICOVER*- SEA ICE COVER. + ! + ! OUTPUT: + ! *USTOKES* - U-COMPONENT STOKES DRIFT + ! *VSTOKES* - V-COMPONENT STOKES DRIFT + ! + ! METHOD. + ! ------- + ! DETERMINE U- AND V-COMPONENT OF STOKES DRIFT FOLLOWING + ! K.E. KENYON, J.G.R., 74, 6991-6994 + ! + ! EXTERNALS. + ! ---------- + ! NONE + ! + ! + !----------------------------------------------------------------------- + + USE cudafor + USE PARKIND_WAVE, ONLY: JWIM, JWRU, JWRB + + USE YOWFRED, ONLY: TH, DFIM, FRATIO + USE YOWPARAM, ONLY: NFRE + + + ! ---------------------------------------------------------------------- + IMPLICIT NONE + + INTEGER(KIND=JWIM), PARAMETER :: NANG_loki_param = 24 + INTEGER(KIND=JWIM), PARAMETER :: NFRE_loki_param = 36 + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJS + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJL + + REAL(KIND=JWRB), INTENT(IN) :: FL1(KIJL, NANG_loki_param, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: STOKFAC(KIJL, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: WSWAVE(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: WDWAVE(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: CICOVER(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(OUT) :: USTOKES(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(OUT) :: VSTOKES(KIJL, NCHNK) + + + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: IJ + INTEGER(KIND=JWIM) :: M + INTEGER(KIND=JWIM) :: K + + REAL(KIND=JWRB), PARAMETER :: STMAX = 1.5_JWRB ! maximum magnitude (this is for safety when coupled) + REAL(KIND=JWRB) :: CONST + REAL(KIND=JWRB) :: FAC + REAL(KIND=JWRB) :: FAC1 + REAL(KIND=JWRB) :: FAC2 + REAL(KIND=JWRB) :: FAC3 + REAL(KIND=JWRB) :: STFAC + REAL(KIND=JWRB), VALUE, INTENT(IN) :: CITHRSH + REAL(KIND=JWRB), INTENT(IN), DEVICE :: COSTH(NFRE_loki_param) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: DELTH + REAL(KIND=JWRB), INTENT(IN), DEVICE :: DFIM_SIM(NFRE_loki_param) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: FR(NFRE_loki_param) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: G + LOGICAL, VALUE, INTENT(IN) :: LICERUN + LOGICAL, VALUE, INTENT(IN) :: LWAMRSETCI + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NANG + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NFRE_ODD + REAL(KIND=JWRB), INTENT(IN), DEVICE :: SINTH(NFRE_loki_param) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ZPI + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: ICHNK + INTEGER, VALUE, INTENT(IN) :: NCHNK + + ! ---------------------------------------------------------------------- + + + + !*** 1. DETERMINE STOKE DRIFT VECTOR. + ! -------------------------------- + + CONST = 2.0_JWRB*DELTH*ZPI**3 / G*FR(NFRE_ODD)**4 + + !*** 1.1 PERFORM INTEGRATION. + ! ------------------------ + + + USTOKES(IJ, ICHNK) = 0.0_JWRB + VSTOKES(IJ, ICHNK) = 0.0_JWRB + + DO M=1,NFRE_ODD + STFAC = STOKFAC(IJ, M, ICHNK)*DFIM_SIM(M) + DO K=1,NANG + FAC3 = STFAC*FL1(IJ, K, M, ICHNK) + USTOKES(IJ, ICHNK) = USTOKES(IJ, ICHNK) + FAC3*SINTH(K) + VSTOKES(IJ, ICHNK) = VSTOKES(IJ, ICHNK) + FAC3*COSTH(K) + END DO + END DO + + !*** 1.2 ADD CONTRIBUTION OF UNRESOLVED WAVES. + ! ----------------------------------------- + + DO K=1,NANG + FAC1 = CONST*SINTH(K) + FAC2 = CONST*COSTH(K) + USTOKES(IJ, ICHNK) = USTOKES(IJ, ICHNK) + FAC1*FL1(IJ, K, NFRE_ODD, ICHNK) + VSTOKES(IJ, ICHNK) = VSTOKES(IJ, ICHNK) + FAC2*FL1(IJ, K, NFRE_ODD, ICHNK) + END DO + + + !*** 1.3 Sea Ice exception + ! --------------------- + IF (LICERUN .and. LWAMRSETCI) THEN + IF (CICOVER(IJ, ICHNK) > CITHRSH) THEN + USTOKES(IJ, ICHNK) = 0.016_JWRB*WSWAVE(IJ, ICHNK)*SIN(WDWAVE(IJ, ICHNK))*(1.0_JWRB - CICOVER(IJ, ICHNK)) + VSTOKES(IJ, ICHNK) = 0.016_JWRB*WSWAVE(IJ, ICHNK)*COS(WDWAVE(IJ, ICHNK))*(1.0_JWRB - CICOVER(IJ, ICHNK)) + END IF + END IF + + !*** 1.4 Protection + ! -------------- + + USTOKES(IJ, ICHNK) = MIN(MAX(USTOKES(IJ, ICHNK), -STMAX), STMAX) + VSTOKES(IJ, ICHNK) = MIN(MAX(VSTOKES(IJ, ICHNK), -STMAX), STMAX) + + + + END SUBROUTINE STOKESDRIFT_CUF_HOIST_NEW +END MODULE STOKESDRIFT_CUF_HOIST_NEW_MOD diff --git a/src/phys-scc-cuf-hoist/stokestrn.cuf_hoist_new.F90 b/src/phys-scc-cuf-hoist/stokestrn.cuf_hoist_new.F90 new file mode 100644 index 00000000..8e9e1a3c --- /dev/null +++ b/src/phys-scc-cuf-hoist/stokestrn.cuf_hoist_new.F90 @@ -0,0 +1,126 @@ +! (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. +! +MODULE STOKESTRN_CUF_HOIST_NEW_MOD + CONTAINS + ATTRIBUTES(DEVICE) SUBROUTINE STOKESTRN_CUF_HOIST_NEW (KIJS, KIJL, FL1, WAVNUM, STOKFAC, DEPTH, WSWAVE, WDWAVE, CICOVER, & + & CITHICK, USTOKES, VSTOKES, STRNMS, NEMOUSTOKES, NEMOVSTOKES, NEMOSTRN, CITHRSH, COSTH, DELTH, DFIM, DFIM_SIM, FLMIN, FR, G, & + & LICERUN, LWAMRSETCI, LWCOU, LWNEMOCOU, LWNEMOCOUSEND, LWNEMOCOUSTK, LWNEMOCOUSTRN, NANG, NFRE, NFRE_ODD, ROWATER, SINTH, & + & ZPI, ICHNK, NCHNK, IJ) + + ! ---------------------------------------------------------------------- + + !**** *STOKESTRN* - WRAPPER TO CALL STOKESDRIFT and CIMSSTRN + + !* PURPOSE. + ! -------- + + !** INTERFACE. + ! ---------- + + ! *CALL* *STOKESTRN (KIJS, KIJL, FL1, WAVNUM, STOKFAC, DEPTH, FF_NOW, INTFLDS, WAM2NEMO) + + ! *KIJS* - INDEX OF FIRST GRIDPOINT. + ! *KIJL* - INDEX OF LAST GRIDPOINT. + ! *FL1* - SPECTRUM(INPUT). + ! *WAVNUM* - WAVE NUMBER. + ! *STOKFAC* - STOKES DRIFT FACTOR. + ! *DEPTH* - WATER DEPTH. + ! *FF_NOW* - FORCING FIELDS AT CURRENT TIME. + ! *INTFLDS* - INTEGRATED/DERIVED PARAMETERS + ! *WAM2NEMO*- WAVE FIELDS PASSED TO NEMO + + ! ---------------------------------------------------------------------- + + USE STOKESDRIFT_CUF_HOIST_NEW_MOD, ONLY: STOKESDRIFT_CUF_HOIST_NEW + USE CIMSSTRN_CUF_HOIST_NEW_MOD, ONLY: CIMSSTRN_CUF_HOIST_NEW + USE cudafor + USE PARKIND_WAVE, ONLY: JWIM, JWRU, JWRO, JWRB + USE YOWDRVTYPE, ONLY: INTGT_PARAM_FIELDS, FORCING_FIELDS, WAVE2OCEAN + + + + ! ---------------------------------------------------------------------- + + IMPLICIT NONE + INTEGER(KIND=JWIM), PARAMETER :: NANG_loki_param = 24 + INTEGER(KIND=JWIM), PARAMETER :: NFRE_loki_param = 36 + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJS + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJL + + REAL(KIND=JWRB), INTENT(IN) :: FL1(KIJL, NANG_loki_param, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: WAVNUM(KIJL, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: STOKFAC(KIJL, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: DEPTH(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: WSWAVE(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: WDWAVE(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: CICOVER(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: CITHICK(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: USTOKES(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: VSTOKES(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: STRNMS(KIJL, NCHNK) + REAL(KIND=JWRO), INTENT(INOUT) :: NEMOUSTOKES(KIJL, NCHNK) + REAL(KIND=JWRO), INTENT(INOUT) :: NEMOVSTOKES(KIJL, NCHNK) + REAL(KIND=JWRO), INTENT(INOUT) :: NEMOSTRN(KIJL, NCHNK) + + + REAL(KIND=JWRB), VALUE, INTENT(IN) :: CITHRSH + REAL(KIND=JWRB), INTENT(IN), DEVICE :: COSTH(NFRE_loki_param) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: DELTH + REAL(KIND=JWRB), INTENT(IN), DEVICE :: DFIM(NFRE_loki_param) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: DFIM_SIM(NFRE_loki_param) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: FLMIN + REAL(KIND=JWRB), INTENT(IN), DEVICE :: FR(NFRE_loki_param) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: G + LOGICAL, VALUE, INTENT(IN) :: LICERUN + LOGICAL, VALUE, INTENT(IN) :: LWAMRSETCI + LOGICAL, VALUE, INTENT(IN) :: LWCOU + LOGICAL, VALUE, INTENT(IN) :: LWNEMOCOU + LOGICAL, VALUE, INTENT(IN) :: LWNEMOCOUSEND + LOGICAL, VALUE, INTENT(IN) :: LWNEMOCOUSTK + LOGICAL, VALUE, INTENT(IN) :: LWNEMOCOUSTRN + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NANG + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NFRE + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NFRE_ODD + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ROWATER + REAL(KIND=JWRB), INTENT(IN), DEVICE :: SINTH(NFRE_loki_param) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ZPI + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: IJ + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: ICHNK + INTEGER, VALUE, INTENT(IN) :: NCHNK + + ! ---------------------------------------------------------------------- + + + CALL STOKESDRIFT_CUF_HOIST_NEW(KIJS, KIJL, FL1(:, :, :, :), STOKFAC(:, :, :), WSWAVE(:, :), WDWAVE(:, :), CICOVER(:, :), & + & USTOKES(:, :), VSTOKES(:, :), CITHRSH, COSTH(:), DELTH, DFIM_SIM(:), FR(:), G, LICERUN, LWAMRSETCI, NANG, NFRE_ODD, & + & SINTH(:), ZPI, ICHNK, NCHNK, IJ) + + IF (LWNEMOCOUSTRN) CALL CIMSSTRN_CUF_HOIST_NEW(KIJS, KIJL, FL1(:, :, :, :), WAVNUM(:, :, :), DEPTH(:, :), CITHICK(:, :), STRNMS(:, :), DELTH, & + & DFIM(:), FLMIN, G, NANG, NFRE, ROWATER, ICHNK, NCHNK, IJ) + + + + IF (LWNEMOCOU .and. (LWNEMOCOUSEND .and. LWCOU .or. .not.LWCOU)) THEN + IF (LWNEMOCOUSTK) THEN + NEMOUSTOKES(IJ, ICHNK) = USTOKES(IJ, ICHNK) + NEMOVSTOKES(IJ, ICHNK) = VSTOKES(IJ, ICHNK) + ELSE + NEMOUSTOKES(IJ, ICHNK) = 0.0_JWRO + NEMOVSTOKES(IJ, ICHNK) = 0.0_JWRO + END IF + + IF (LWNEMOCOUSTRN) NEMOSTRN(IJ, ICHNK) = STRNMS(IJ, ICHNK) + END IF + + + + ! ---------------------------------------------------------------------- + + END SUBROUTINE STOKESTRN_CUF_HOIST_NEW +END MODULE STOKESTRN_CUF_HOIST_NEW_MOD diff --git a/src/phys-scc-cuf-hoist/stress_gc.cuf_hoist_new.F90 b/src/phys-scc-cuf-hoist/stress_gc.cuf_hoist_new.F90 new file mode 100644 index 00000000..375b1c19 --- /dev/null +++ b/src/phys-scc-cuf-hoist/stress_gc.cuf_hoist_new.F90 @@ -0,0 +1,142 @@ +! (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. +! +MODULE STRESS_GC_CUF_HOIST_NEW_MOD + CONTAINS + ATTRIBUTES(DEVICE) FUNCTION STRESS_GC_CUF_HOIST_NEW (ANG_GC, USTAR, Z0, Z0MIN, HALP, RNFAC, BETAMAXOXKAPPA2, BMAXOKAP, & + & C2OSQRTVG_GC, CM_GC, DELKCC_GC_NS, DELKCC_OMXKM3_GC, EPSUS, LLNORMAGAM, NWAV_GC, OM3GMKM_GC, OMXKM3_GC, RN1_RN, SQRTGOSURFT, & + & XKAPPA, XKMSQRTVGOC2_GC, XKM_GC, XK_GC, XLOGKRATIOM1_GC, ZALP) + + !*** DETERMINE WAVE INDUCED STRESS FOR GRAV-CAP WAVES + + ! AUTHOR: PETER JANSSEN + ! ------ + + ! REFERENCES: + ! ---------- + + ! VIERS PAPER EQ.(29) + ! FOR QUASILINEAR EFFECT SEE PETER A.E.M. JANSSEN,1990. + + !---------------------------------------------------------------------- + + USE NS_GC_CUF_HOIST_NEW_MOD, ONLY: NS_GC_CUF_HOIST_NEW + USE cudafor + USE PARKIND_WAVE, ONLY: JWIM, JWRU, JWRB + + USE YOWFRED, ONLY: OMEGA_GC + USE YOWPCONS, ONLY: SURFT, G + + + + !---------------------------------------------------------------------- + + IMPLICIT NONE + + REAL(KIND=JWRB) :: STRESS_GC_CUF_HOIST_NEW + REAL(KIND=JWRB), INTENT(IN) :: ANG_GC ! factor to account for angular spreading of the input. + REAL(KIND=JWRB), INTENT(IN) :: USTAR ! friction velocity + REAL(KIND=JWRB), INTENT(IN) :: Z0 ! surface roughness + REAL(KIND=JWRB), INTENT(IN) :: Z0MIN ! minimum surface roughness + REAL(KIND=JWRB), INTENT(IN) :: HALP ! 1/2 Phillips parameter + REAL(KIND=JWRB), INTENT(IN) :: RNFAC ! wind dependent factor used in the growth renormalisation + + + INTEGER(KIND=JWIM) :: NS + INTEGER(KIND=JWIM) :: I + + REAL(KIND=JWRB) :: XLAMBDA ! Correction factor in the wave growth for gravity-capillary waves + ! XLAMBDA = 1.0_JWRB + XLAMA * TANH(XLAMB * USTAR**NLAM) + REAL(KIND=JWRB), PARAMETER :: XLAMA = 0.25_JWRB + REAL(KIND=JWRB), PARAMETER :: XLAMB = 4.0_JWRB + INTEGER(KIND=JWIM), PARAMETER :: NLAM = 4 + + REAL(KIND=JWRB) :: TAUWCG_MIN + REAL(KIND=JWRB) :: TAUWCG + REAL(KIND=JWRB) :: ZABHRC + REAL(KIND=JWRB) :: X, XLOG, ZLOG, ZLOG2X + REAL(KIND=JWRB) :: CONST, ZN + REAL(KIND=JWRB) :: GAMNORMA ! RENORMALISATION FACTOR OF THE GROWTH RATE + REAL(KIND=JWRB) :: GAM_W + REAL(KIND=JWRB), INTENT(IN) :: BETAMAXOXKAPPA2 + REAL(KIND=JWRB), INTENT(IN) :: BMAXOKAP + REAL(KIND=JWRB), INTENT(IN), DEVICE :: C2OSQRTVG_GC(NWAV_GC) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: CM_GC(NWAV_GC) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: DELKCC_GC_NS(NWAV_GC) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: DELKCC_OMXKM3_GC(NWAV_GC) + REAL(KIND=JWRB), INTENT(IN) :: EPSUS + LOGICAL, INTENT(IN) :: LLNORMAGAM + INTEGER(KIND=JWIM), INTENT(IN) :: NWAV_GC + REAL(KIND=JWRB), INTENT(IN), DEVICE :: OM3GMKM_GC(NWAV_GC) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: OMXKM3_GC(NWAV_GC) + REAL(KIND=JWRB), INTENT(IN) :: RN1_RN + REAL(KIND=JWRB), INTENT(IN) :: SQRTGOSURFT + REAL(KIND=JWRB), INTENT(IN) :: XKAPPA + REAL(KIND=JWRB), INTENT(IN), DEVICE :: XKMSQRTVGOC2_GC(NWAV_GC) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: XKM_GC(NWAV_GC) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: XK_GC(NWAV_GC) + REAL(KIND=JWRB), INTENT(IN) :: XLOGKRATIOM1_GC + REAL(KIND=JWRB), INTENT(IN) :: ZALP +!$acc routine seq + + ! INCLUDE FUNCTIONS FROM GRAVITY-CAPILLARY DISPERSION REALTIONS + + ! ---------------------------------------------------------------------- + + + !* 1.0 DETERMINE GRAV_CAP SPECTRUM, TAUWHF. + ! ------------------------------------ + + ! FIND NS: + NS = NS_GC_CUF_HOIST_NEW(USTAR, NWAV_GC, SQRTGOSURFT, XKM_GC, XLOGKRATIOM1_GC) + + TAUWCG_MIN = (USTAR*(Z0MIN / Z0))**2 + + XLAMBDA = 1.0_JWRB + XLAMA*TANH(XLAMB*USTAR**NLAM) + + ZABHRC = ANG_GC*BETAMAXOXKAPPA2*HALP*C2OSQRTVG_GC(NS) + IF (LLNORMAGAM) THEN + CONST = RNFAC*BMAXOKAP*HALP*C2OSQRTVG_GC(NS) / MAX(USTAR, EPSUS) + ELSE + CONST = 0.0_JWRB + END IF + + DO I=NS,NWAV_GC + ! GROWTHRATE BY WIND WITHOUT the multiplicative factor representing the ratio of air density to water density (eps) + ! and BETAMAXOXKAPPA2 + X = USTAR*CM_GC(I) + XLOG = LOG(XK_GC(I)*Z0) + XKAPPA / (X + ZALP) + ZLOG = XLOG - LOG(XLAMBDA) + ZLOG = MIN(ZLOG, 0.0_JWRB) + ZLOG2X = ZLOG*ZLOG*X + END DO + + GAM_W = ZLOG2X*ZLOG2X*EXP(XLOG)*OM3GMKM_GC(NS) + ZN = CONST*XKMSQRTVGOC2_GC(NS)*GAM_W + GAMNORMA = (1.0_JWRB + RN1_RN*ZN) / (1.0_JWRB + ZN) + TAUWCG = GAM_W*DELKCC_GC_NS(NS)*OMXKM3_GC(NS)*GAMNORMA + DO I=NS + 1,NWAV_GC + ! ANALYTICAL FORM INERTIAL SUB RANGE F(k) = k**(-4)*BB + ! BB = HALP * C2OSQRTVG_GC(NS)*SQRT(VG_GC(I))/C_GC(I)**2 + ! Tauwcg : (rhow * g /rhoa) * integral of (1/c) * gammma * F(k) k dk + ! with omega=g*k and omega=k*c, then + ! Tauwcg : (rhow /rhoa) * integral of omega * gammma * F(k) k dk + ! but gamma is computed wihtout the rhoa/rhow factor so + ! Tauwcg : integral of omega * gammma_wam * F(k) k dk + ! It should be done in vector form with actual directional spreading information + ! It simplified here by using the ANG_GC factor. + GAM_W = ZLOG2X*ZLOG2X*EXP(XLOG)*OM3GMKM_GC(I) + ZN = CONST*XKMSQRTVGOC2_GC(I)*GAM_W + GAMNORMA = (1.0_JWRB + RN1_RN*ZN) / (1.0_JWRB + ZN) + TAUWCG = TAUWCG + GAM_W*DELKCC_OMXKM3_GC(I)*GAMNORMA + END DO + STRESS_GC_CUF_HOIST_NEW = MAX(ZABHRC*TAUWCG, TAUWCG_MIN) + + + END FUNCTION STRESS_GC_CUF_HOIST_NEW +END MODULE STRESS_GC_CUF_HOIST_NEW_MOD diff --git a/src/phys-scc-cuf-hoist/stresso.cuf_hoist_new.F90 b/src/phys-scc-cuf-hoist/stresso.cuf_hoist_new.F90 new file mode 100644 index 00000000..f453c38b --- /dev/null +++ b/src/phys-scc-cuf-hoist/stresso.cuf_hoist_new.F90 @@ -0,0 +1,266 @@ +! (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. +! +MODULE STRESSO_CUF_HOIST_NEW_MOD + CONTAINS + ATTRIBUTES(DEVICE) SUBROUTINE STRESSO_CUF_HOIST_NEW (KIJS, KIJL, MIJ, RHOWGDFTH, FL1, SL, SPOS, CINV, WDWAVE, UFRIC, Z0M, & + & AIRD, RNFAC, COSWDIF, SINWDIF2, TAUW, TAUWDIR, PHIWA, LLPHIWA, COSTH, DELTH, EPS1, FR5, G, GAMNCONST, GM1, IPHYS, & + & JTOT_TAUHF, LLGCBZ0, LLNORMAGAM, NANG, NFRE, NWAV_GC, OMEGA_GC, RHOWG_DFIM, SINTH, SQRTGOSURFT, TAUWSHELTER, WTAUHF, & + & X0TAUHF, XKAPPA, XKM_GC, XK_GC, XLOGKRATIOM1_GC, ZALP, ZPI4GM1, ZPI4GM2, ZPIFR, ICHNK, NCHNK, IJ, TAUHF, PHIHF, UST) + + ! ---------------------------------------------------------------------- + + !**** *STRESSO* - COMPUTATION OF WAVE STRESS. + + ! H. GUNTHER GKSS/ECMWF NOVEMBER 1989 CODE MOVED FROM SINPUT. + ! P.A.E.M. JANSSEN KNMI AUGUST 1990 + ! J. BIDLOT ECMWF FEBRUARY 1996-97 + ! S. ABDALLA ECMWF OCTOBER 2001 INTRODUCTION OF VARIABLE + ! AIR DENSITY + ! P.A.E.M. JANSSEN ECMWF 2011 ADD FLUX CALULATIONS + + !* PURPOSE. + ! -------- + + ! COMPUTE NORMALIZED WAVE STRESS FROM INPUT SOURCE FUNCTION + + !** INTERFACE. + ! ---------- + + ! *CALL* *STRESSO (KIJS, KIJL, MIJ, RHOWGDFTH, + ! FL1, SL, SPOS, + ! & CINV, + ! & WDWAVE, UFRIC, Z0M, AIRD, RNFAC, + ! & COSWDIF, SINWDIF2, + ! & TAUW, TAUWDIR, PHIWA)* + ! *KIJS* - INDEX OF FIRST GRIDPOINT. + ! *KIJL* - INDEX OF LAST GRIDPOINT. + ! *MIJ* - LAST FREQUENCY INDEX OF THE PROGNOSTIC RANGE. + ! *RHOWGDFTH - WATER DENSITY * G * DF * DTHETA + ! *FL1* - WAVE SPECTRUM. + ! *SL* - WIND INPUT SOURCE FUNCTION ARRAY (positive and negative contributions). + ! *SPOS* - POSITIVE WIND INPUT SOURCE FUNCTION ARRAY. + ! *CINV* - INVERSE PHASE VELOCITY. + ! *WDWAVE* - WIND DIRECTION IN RADIANS IN OCEANOGRAPHIC + ! NOTATION (POINTING ANGLE OF WIND VECTOR, + ! CLOCKWISE FROM NORTH). + ! *UFRIC* - FRICTION VELOCITY IN M/S. + ! *Z0M* - ROUGHNESS LENGTH IN M. + ! *AIRD* - AIR DENSITY IN KG/M**3. + ! *RNFAC* - WIND DEPENDENT FACTOR USED IN THE GROWTH RENORMALISATION. + ! *COSWDIF* - COS(TH(K)-WDWAVE(IJ)) + ! *SINWDIF2* - SIN(TH(K)-WDWAVE(IJ))**2 + ! *TAUW* - KINEMATIC WAVE STRESS IN (M/S)**2 + ! *TAUWDIR* - KINEMATIC WAVE STRESS DIRECTION + ! *PHIWA* - ENERGY FLUX FROM WIND INTO WAVES INTEGRATED + ! OVER THE FULL FREQUENCY RANGE. + ! *LLPHIWA* - TRUE IF PHIWA NEEDS TO BE COMPUTED + + ! METHOD. + ! ------- + + ! THE INPUT SOURCE FUNCTION IS INTEGRATED OVER FREQUENCY + ! AND DIRECTIONS. + ! BECAUSE ARRAY *SPOS* IS USED, ONLY THE INPUT SOURCE + ! HAS TO BE STORED IN *SPOS* (CALL FIRST SINPUT, THEN + ! STRESSO, AND THEN THE REST OF THE SOURCE FUNCTIONS) + + ! REFERENCE. + ! ---------- + ! P. JANSSEN, + + ! ---------------------------------------------------------------------- + USE cudafor + USE PARKIND_WAVE, ONLY: JWIM, JWRU, JWRB + + USE YOWFRED, ONLY: FR, TH + + USE TAU_PHI_HF_CUF_HOIST_NEW_MOD, ONLY: TAU_PHI_HF_CUF_HOIST_NEW + + ! ---------------------------------------------------------------------- + + IMPLICIT NONE + + INTEGER(KIND=JWIM), PARAMETER :: NFRE_loki_param = 36 + INTEGER(KIND=JWIM), PARAMETER :: NANG_loki_param = 24 + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJS + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJL + INTEGER(KIND=JWIM), INTENT(IN) :: MIJ(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: RHOWGDFTH(KIJL, NFRE_loki_param) + REAL(KIND=JWRB), INTENT(IN) :: FL1(KIJL, NANG_loki_param, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: SL(KIJL, NANG_loki_param, NFRE_loki_param) + REAL(KIND=JWRB), INTENT(IN) :: SPOS(KIJL, NANG_loki_param, NFRE_loki_param) + REAL(KIND=JWRB), INTENT(IN) :: CINV(KIJL, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: WDWAVE(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: UFRIC(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: Z0M(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: AIRD(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: RNFAC(KIJL) + REAL(KIND=JWRB), INTENT(IN) :: COSWDIF(KIJL, NANG_loki_param) + REAL(KIND=JWRB), INTENT(IN) :: SINWDIF2(KIJL, NANG_loki_param) + REAL(KIND=JWRB), INTENT(OUT) :: TAUW(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(OUT) :: TAUWDIR(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(OUT) :: PHIWA(KIJL) + LOGICAL, VALUE, INTENT(IN) :: LLPHIWA + + + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: IJ + INTEGER(KIND=JWIM) :: M + INTEGER(KIND=JWIM) :: K + INTEGER(KIND=JWIM) :: I + INTEGER(KIND=JWIM) :: J + INTEGER(KIND=JWIM) :: II + + REAL(KIND=JWRB) :: TAUTOUS2 + REAL(KIND=JWRB) :: COSW + REAL(KIND=JWRB) :: FCOSW2 + REAL(KIND=JWRB) :: XSTRESS + REAL(KIND=JWRB) :: YSTRESS + REAL(KIND=JWRB), INTENT(INOUT) :: TAUHF(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: PHIHF(KIJL, NCHNK) + REAL(KIND=JWRB) :: USDIRP + REAL(KIND=JWRB), INTENT(INOUT) :: UST(KIJL, NCHNK) + + REAL(KIND=JWRB) :: CMRHOWGDFTH + REAL(KIND=JWRB) :: TAUX + REAL(KIND=JWRB) :: TAUY + REAL(KIND=JWRB) :: TAUPX + REAL(KIND=JWRB) :: TAUPY + REAL(KIND=JWRB) :: SUMT + REAL(KIND=JWRB) :: SUMX + REAL(KIND=JWRB) :: SUMY + + LOGICAL :: LTAUWSHELTER + REAL(KIND=JWRB), INTENT(IN), DEVICE :: COSTH(NFRE_loki_param) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: DELTH + REAL(KIND=JWRB), VALUE, INTENT(IN) :: EPS1 + REAL(KIND=JWRB), INTENT(IN), DEVICE :: FR5(NFRE_loki_param) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: G + REAL(KIND=JWRB), VALUE, INTENT(IN) :: GAMNCONST + REAL(KIND=JWRB), VALUE, INTENT(IN) :: GM1 + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: IPHYS + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: JTOT_TAUHF + LOGICAL, VALUE, INTENT(IN) :: LLGCBZ0 + LOGICAL, VALUE, INTENT(IN) :: LLNORMAGAM + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NANG + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NFRE + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NWAV_GC + REAL(KIND=JWRB), INTENT(IN), DEVICE :: OMEGA_GC(NWAV_GC) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: RHOWG_DFIM(NFRE_loki_param) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: SINTH(NFRE_loki_param) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SQRTGOSURFT + REAL(KIND=JWRB), VALUE, INTENT(IN) :: TAUWSHELTER + REAL(KIND=JWRB), INTENT(IN) :: WTAUHF(JTOT_TAUHF) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: X0TAUHF + REAL(KIND=JWRB), VALUE, INTENT(IN) :: XKAPPA + REAL(KIND=JWRB), INTENT(IN), DEVICE :: XKM_GC(NWAV_GC) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: XK_GC(NWAV_GC) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: XLOGKRATIOM1_GC + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ZALP + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ZPI4GM1 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ZPI4GM2 + REAL(KIND=JWRB), INTENT(IN), DEVICE :: ZPIFR(NFRE_loki_param) + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: ICHNK + INTEGER, VALUE, INTENT(IN) :: NCHNK + + ! ---------------------------------------------------------------------- + + + + PHIWA(IJ) = 0.0_JWRB + XSTRESS = 0.0_JWRB + YSTRESS = 0.0_JWRB + + !* CONTRIBUTION TO THE WAVE STRESS FROM THE NEGATIVE PART OF THE WIND INPUT + ! ------------------------------------------------------------------------ + + IF (LLPHIWA) THEN + ! full energy flux due to negative Sinput (SL-SPOS) + ! we assume that above NFRE, the contibutions can be neglected + DO M=1,NFRE + DO K=1,NANG + PHIWA(IJ) = PHIWA(IJ) + (SL(IJ, K, M) - SPOS(IJ, K, M))*RHOWG_DFIM(M) + END DO + END DO + END IF + + !* CALCULATE LOW-FREQUENCY CONTRIBUTION TO STRESS AND ENERGY FLUX (positive sinput). + ! --------------------------------------------------------------------------------- + DO M=1,NFRE + ! THE INTEGRATION ONLY UP TO FR=MIJ SINCE RHOWGDFTH=0 FOR FR>MIJ + K = 1 + SUMX = SPOS(IJ, K, M)*SINTH(K) + SUMY = SPOS(IJ, K, M)*COSTH(K) + DO K=2,NANG + SUMX = SUMX + SPOS(IJ, K, M)*SINTH(K) + SUMY = SUMY + SPOS(IJ, K, M)*COSTH(K) + END DO + CMRHOWGDFTH = RHOWGDFTH(IJ, M)*CINV(IJ, M, ICHNK) + XSTRESS = XSTRESS + CMRHOWGDFTH*SUMX + YSTRESS = YSTRESS + CMRHOWGDFTH*SUMY + END DO + + ! TAUW is the kinematic wave stress ! + XSTRESS = XSTRESS / MAX(AIRD(IJ, ICHNK), 1.0_JWRB) + YSTRESS = YSTRESS / MAX(AIRD(IJ, ICHNK), 1.0_JWRB) + + IF (LLPHIWA) THEN + DO M=1,NFRE + ! THE INTEGRATION ONLY UP TO FR=MIJ SINCE RHOWGDFTH=0 FOR FR>MIJ + K = 1 + SUMT = SPOS(IJ, K, M) + DO K=2,NANG + SUMT = SUMT + SPOS(IJ, K, M) + END DO + PHIWA(IJ) = PHIWA(IJ) + RHOWGDFTH(IJ, M)*SUMT + END DO + END IF + + !* CALCULATE HIGH-FREQUENCY CONTRIBUTION TO STRESS and energy flux (positive sinput). + ! ---------------------------------------------------------------------------------- + + IF (IPHYS == 0 .or. TAUWSHELTER == 0.0_JWRB) THEN + LTAUWSHELTER = .false. + USDIRP = WDWAVE(IJ, ICHNK) + UST(IJ, ICHNK) = UFRIC(IJ, ICHNK) + ELSE + LTAUWSHELTER = .true. + TAUX = UFRIC(IJ, ICHNK)**2*SIN(WDWAVE(IJ, ICHNK)) + TAUY = UFRIC(IJ, ICHNK)**2*COS(WDWAVE(IJ, ICHNK)) + TAUPX = TAUX - TAUWSHELTER*XSTRESS + TAUPY = TAUY - TAUWSHELTER*YSTRESS + USDIRP = ATAN2(TAUPX, TAUPY) + UST(IJ, ICHNK) = (TAUPX**2 + TAUPY**2)**0.25_JWRB + END IF + + + CALL TAU_PHI_HF_CUF_HOIST_NEW(KIJS, KIJL, MIJ(:, :), LTAUWSHELTER, UFRIC(:, :), Z0M(:, :), FL1(:, :, :, :), AIRD(:, :), & + & RNFAC(:), COSWDIF(:, :), SINWDIF2(:, :), UST(:, ICHNK), TAUHF(:, ICHNK), PHIHF(:, ICHNK), LLPHIWA, DELTH, FR5(:), G, & + & GAMNCONST, GM1, JTOT_TAUHF, LLGCBZ0, LLNORMAGAM, NANG, NWAV_GC, OMEGA_GC(:), SQRTGOSURFT, TAUWSHELTER, WTAUHF(:), X0TAUHF, & + & XKAPPA, XKM_GC(:), XK_GC(:), XLOGKRATIOM1_GC, ZALP, ZPI4GM1, ZPI4GM2, ZPIFR(:), ICHNK, NCHNK, IJ) + + + XSTRESS = XSTRESS + TAUHF(IJ, ICHNK)*SIN(USDIRP) + YSTRESS = YSTRESS + TAUHF(IJ, ICHNK)*COS(USDIRP) + TAUW(IJ, ICHNK) = SQRT(XSTRESS**2 + YSTRESS**2) + TAUW(IJ, ICHNK) = MAX(TAUW(IJ, ICHNK), 0.0_JWRB) + TAUWDIR(IJ, ICHNK) = ATAN2(XSTRESS, YSTRESS) + + IF (.not.LLGCBZ0) THEN + TAUTOUS2 = 1.0_JWRB / (1.0_JWRB + EPS1) + TAUW(IJ, ICHNK) = MIN(TAUW(IJ, ICHNK), UFRIC(IJ, ICHNK)**2*TAUTOUS2) + END IF + + IF (LLPHIWA) THEN + PHIWA(IJ) = PHIWA(IJ) + PHIHF(IJ, ICHNK) + END IF + + + + END SUBROUTINE STRESSO_CUF_HOIST_NEW +END MODULE STRESSO_CUF_HOIST_NEW_MOD diff --git a/src/phys-scc-cuf-hoist/tau_phi_hf.cuf_hoist_new.F90 b/src/phys-scc-cuf-hoist/tau_phi_hf.cuf_hoist_new.F90 new file mode 100644 index 00000000..df5ca64a --- /dev/null +++ b/src/phys-scc-cuf-hoist/tau_phi_hf.cuf_hoist_new.F90 @@ -0,0 +1,459 @@ +! (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. +! +MODULE TAU_PHI_HF_CUF_HOIST_NEW_MOD + !CONTAINED SUBROUTINES: + ! - OMEGAGC + ! - TAU_PHI_HF + CONTAINS + ATTRIBUTES(DEVICE) SUBROUTINE OMEGAGC_CUF_HOIST_NEW (UST, NS, XKS, OMS, NWAV_GC, OMEGA_GC, SQRTGOSURFT, XKM_GC, XK_GC, & + & XLOGKRATIOM1_GC) + + !*** DETERMINE THE CUT-OFF ANGULAR FREQUENCY FOR THE GRAV-CAPILLARY WAVES + ! !!!! rounded to the closest index of XK_GC !!!!! + + ! AUTHOR: PETER JANSSEN + ! ------ + + ! REFERENCES: + ! ---------- + + ! VIERS PAPER EQ.(29) + + !---------------------------------------------------------------------- + + USE NS_GC_CUF_HOIST_NEW_MOD, ONLY: NS_GC_CUF_HOIST_NEW + USE cudafor + USE PARKIND_WAVE, ONLY: JWIM, JWRU, JWRB + + + + !---------------------------------------------------------------------- + + IMPLICIT NONE + REAL(KIND=JWRB), INTENT(IN) :: UST + INTEGER(KIND=JWIM), INTENT(OUT) :: NS ! index in array XK_GC corresponding to XKS and OMS + REAL(KIND=JWRB), INTENT(OUT) :: XKS ! cut-off wave number + REAL(KIND=JWRB), INTENT(OUT) :: OMS ! cut-off angular frequency + + INTEGER(KIND=JWIM), INTENT(IN) :: NWAV_GC + REAL(KIND=JWRB), INTENT(IN), DEVICE :: OMEGA_GC(NWAV_GC) + REAL(KIND=JWRB), INTENT(IN) :: SQRTGOSURFT + REAL(KIND=JWRB), INTENT(IN), DEVICE :: XKM_GC(NWAV_GC) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: XK_GC(NWAV_GC) + REAL(KIND=JWRB), INTENT(IN) :: XLOGKRATIOM1_GC +!$acc routine seq + + + ! ---------------------------------------------------------------------- + + + NS = NS_GC_CUF_HOIST_NEW(UST, NWAV_GC, SQRTGOSURFT, XKM_GC, XLOGKRATIOM1_GC) + XKS = XK_GC(NS) + OMS = OMEGA_GC(NS) + + + END SUBROUTINE OMEGAGC_CUF_HOIST_NEW + + ATTRIBUTES(DEVICE) SUBROUTINE TAU_PHI_HF_CUF_HOIST_NEW (KIJS, KIJL, MIJ, LTAUWSHELTER, UFRIC, Z0M, FL1, AIRD, RNFAC, COSWDIF, & + & SINWDIF2, UST, TAUHF, PHIHF, LLPHIHF, DELTH, FR5, G, GAMNCONST, GM1, JTOT_TAUHF, LLGCBZ0, LLNORMAGAM, NANG, NWAV_GC, & + & OMEGA_GC, SQRTGOSURFT, TAUWSHELTER, WTAUHF, X0TAUHF, XKAPPA, XKM_GC, XK_GC, XLOGKRATIOM1_GC, ZALP, ZPI4GM1, ZPI4GM2, ZPIFR, & + & ICHNK, NCHNK, IJ) + + ! ---------------------------------------------------------------------- + + !**** *TAU_PHI_HF* - COMPUTATION OF HIGH-FREQUENCY STRESS. + ! HIGH-FREQUENCY ENERGY FLUX. + + ! PETER A.E.M. JANSSEN KNMI OCTOBER 90 + ! JEAN BIDLOT ECMWF JANUARY 2017 + + !* PURPOSE. + ! --------- + + ! COMPUTE HIGH-FREQUENCY WAVE STRESS AND ENERGY FLUX + + !** INTERFACE. + ! --------- + + ! *CALL* *TAU_PHI_HF(KIJS, KIJL, MIJ, LTAUWSHELTER, UFRIC, UST, Z0M, + ! FL1, AIRD, RNFAC, + ! COSWDIF, SINWDIF2, + ! UST, TAUHF, PHIHF, LLPHIHF) + ! *KIJS* - INDEX OF FIRST GRIDPOINT + ! *KIJL* - INDEX OF LAST GRIDPOINT + ! *MIJ* - LAST FREQUENCY INDEX OF THE PROGNOSTIC RANGE. + ! *LTAUWSHELTER* - if true then TAUWSHELTER + ! *FL1* - WAVE SPECTRUM. + ! *AIRD* - AIR DENSITY IN KG/M**3. + ! *RNFAC* - WIND DEPENDENT FACTOR USED IN THE GROWTH RENORMALISATION. + ! *UFRIC* - FRICTION VELOCITY + ! *COSWDIF* - COS(TH(K)-WDWAVE(IJ)) + ! *SINWDIF2* - SIN(TH(K)-WDWAVE(IJ))**2 + ! *UST* - REDUCED FRICTION VELOCITY DUE TO SHELTERING + ! *Z0M* - ROUGHNESS LENGTH + ! *TAUHF* - HIGH-FREQUENCY STRESS + ! *PHIHF* - HIGH-FREQUENCY ENERGY FLUX INTO OCEAN + ! *LLPHIHF* - TRUE IF PHIHF NEEDS TO COMPUTED + + + ! METHOD. + ! ------- + + ! IT NEEDS A CALL TO INIT_X0TAUHF TO INITIALISE + ! SEE REFERENCE FOR WAVE STRESS CALCULATION. + + ! EXTERNALS. + ! ---------- + + ! NONE. + + ! REFERENCE. + ! ---------- + + ! FOR QUASILINEAR EFFECT SEE PETER A.E.M. JANSSEN,1990. + + ! ---------------------------------------------------------------------- + + USE cudafor + USE PARKIND_WAVE, ONLY: JWIM, JWRU, JWRB + + USE YOWFRED, ONLY: TH + USE YOWPARAM, ONLY: NFRE + USE YOWPCONS, ONLY: ZPI + USE YOWTEST, ONLY: IU06 + + + ! ---------------------------------------------------------------------- + + IMPLICIT NONE + + INTEGER(KIND=JWIM), PARAMETER :: NANG_loki_param = 24 + INTEGER(KIND=JWIM), PARAMETER :: NFRE_loki_param = 36 + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJS + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJL + INTEGER(KIND=JWIM), INTENT(IN) :: MIJ(KIJL, NCHNK) + LOGICAL, VALUE, INTENT(IN) :: LTAUWSHELTER + REAL(KIND=JWRB), INTENT(IN) :: UFRIC(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: Z0M(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: FL1(KIJL, NANG_loki_param, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: AIRD(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: RNFAC(KIJL) + REAL(KIND=JWRB), INTENT(IN) :: COSWDIF(KIJL, NANG_loki_param) + REAL(KIND=JWRB), INTENT(IN) :: SINWDIF2(KIJL, NANG_loki_param) + REAL(KIND=JWRB), INTENT(INOUT) :: UST(KIJL) + REAL(KIND=JWRB), INTENT(OUT) :: TAUHF(KIJL) + REAL(KIND=JWRB), INTENT(OUT) :: PHIHF(KIJL) + LOGICAL, VALUE, INTENT(IN) :: LLPHIHF + + + INTEGER(KIND=JWIM) :: J + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: IJ + INTEGER(KIND=JWIM) :: K + INTEGER(KIND=JWIM) :: NS + + REAL(KIND=JWRB), PARAMETER :: ZSUPMAX = 0.0_JWRB ! LOG(1.) + REAL(KIND=JWRB) :: OMEGA + REAL(KIND=JWRB) :: OMEGACC + REAL(KIND=JWRB) :: X0G + REAL(KIND=JWRB) :: YC + REAL(KIND=JWRB) :: Y + REAL(KIND=JWRB) :: CM1 + REAL(KIND=JWRB) :: ZX + REAL(KIND=JWRB) :: ZARG + REAL(KIND=JWRB) :: ZLOG + REAL(KIND=JWRB) :: ZBETA + REAL(KIND=JWRB) :: FNC + REAL(KIND=JWRB) :: FNC2 + REAL(KIND=JWRB) :: GAMNORMA ! RENORMALISATION FACTOR OF THE GROWTH RATE + REAL(KIND=JWRB) :: ZNZ + REAL(KIND=JWRB) :: CONFG + REAL(KIND=JWRB) :: COSW + REAL(KIND=JWRB) :: FCOSW2 + + REAL(KIND=JWRB) :: XKS + REAL(KIND=JWRB) :: OMS + REAL(KIND=JWRB) :: SQRTZ0OG + REAL(KIND=JWRB) :: ZSUP + REAL(KIND=JWRB) :: ZINF + REAL(KIND=JWRB) :: DELZ + REAL(KIND=JWRB) :: TAUL + REAL(KIND=JWRB) :: XLOGGZ0 + REAL(KIND=JWRB) :: SQRTGZ0 + REAL(KIND=JWRB) :: USTPH + REAL(KIND=JWRB) :: CONST1 + REAL(KIND=JWRB) :: CONST2 + REAL(KIND=JWRB) :: CONSTTAU + REAL(KIND=JWRB) :: CONSTPHI + REAL(KIND=JWRB) :: F1DCOS2 + REAL(KIND=JWRB) :: F1DCOS3 + REAL(KIND=JWRB) :: F1D + REAL(KIND=JWRB) :: F1DSIN2 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: DELTH + REAL(KIND=JWRB), INTENT(IN), DEVICE :: FR5(NFRE_loki_param) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: G + REAL(KIND=JWRB), VALUE, INTENT(IN) :: GAMNCONST + REAL(KIND=JWRB), VALUE, INTENT(IN) :: GM1 + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: JTOT_TAUHF + LOGICAL, VALUE, INTENT(IN) :: LLGCBZ0 + LOGICAL, VALUE, INTENT(IN) :: LLNORMAGAM + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NANG + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NWAV_GC + REAL(KIND=JWRB), INTENT(IN), DEVICE :: OMEGA_GC(NWAV_GC) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SQRTGOSURFT + REAL(KIND=JWRB), VALUE, INTENT(IN) :: TAUWSHELTER + REAL(KIND=JWRB), INTENT(IN) :: WTAUHF(JTOT_TAUHF) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: X0TAUHF + REAL(KIND=JWRB), VALUE, INTENT(IN) :: XKAPPA + REAL(KIND=JWRB), INTENT(IN), DEVICE :: XKM_GC(NWAV_GC) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: XK_GC(NWAV_GC) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: XLOGKRATIOM1_GC + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ZALP + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ZPI4GM1 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ZPI4GM2 + REAL(KIND=JWRB), INTENT(IN), DEVICE :: ZPIFR(NFRE_loki_param) + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: ICHNK + INTEGER, VALUE, INTENT(IN) :: NCHNK + + ! ---------------------------------------------------------------------- + + + + IF (LLGCBZ0) THEN + CALL OMEGAGC_CUF_HOIST_NEW(UFRIC(IJ, ICHNK), NS, XKS, OMS, NWAV_GC, OMEGA_GC(:), SQRTGOSURFT, XKM_GC(:), XK_GC(:), & + & XLOGKRATIOM1_GC) + END IF + + ! See INIT_X0TAUHF + X0G = X0TAUHF*G + + IF (LLPHIHF) USTPH = UST(IJ) + + !* COMPUTE THE INTEGRALS + ! --------------------- + + XLOGGZ0 = LOG(G*Z0M(IJ, ICHNK)) + OMEGACC = MAX(ZPIFR(MIJ(IJ, ICHNK)), X0G / UST(IJ)) + SQRTZ0OG = SQRT(Z0M(IJ, ICHNK)*GM1) + SQRTGZ0 = 1.0_JWRB / SQRTZ0OG + YC = OMEGACC*SQRTZ0OG + ZINF = LOG(YC) + + CONSTTAU = ZPI4GM2*FR5(MIJ(IJ, ICHNK)) + + K = 1 + COSW = MAX(COSWDIF(IJ, K), 0.0_JWRB) + FCOSW2 = FL1(IJ, K, MIJ(IJ, ICHNK), ICHNK)*COSW**2 + F1DCOS3 = FCOSW2*COSW + F1DCOS2 = FCOSW2 + F1DSIN2 = FL1(IJ, K, MIJ(IJ, ICHNK), ICHNK)*SINWDIF2(IJ, K) + F1D = FL1(IJ, K, MIJ(IJ, ICHNK), ICHNK) + DO K=2,NANG + COSW = MAX(COSWDIF(IJ, K), 0.0_JWRB) + FCOSW2 = FL1(IJ, K, MIJ(IJ, ICHNK), ICHNK)*COSW**2 + F1DCOS3 = F1DCOS3 + FCOSW2*COSW + F1DCOS2 = F1DCOS2 + FCOSW2 + F1DSIN2 = F1DSIN2 + FL1(IJ, K, MIJ(IJ, ICHNK), ICHNK)*SINWDIF2(IJ, K) + F1D = F1D + FL1(IJ, K, MIJ(IJ, ICHNK), ICHNK) + END DO + F1DCOS3 = DELTH*F1DCOS3 + F1DCOS2 = DELTH*F1DCOS2 + F1DSIN2 = DELTH*F1DSIN2 + F1D = DELTH*F1D + + IF (LLNORMAGAM) THEN + CONFG = GAMNCONST*FR5(MIJ(IJ, ICHNK))*RNFAC(IJ)*SQRTGZ0 + CONST1 = CONFG*F1DSIN2 + CONST2 = CONFG*F1D + ELSE + CONST1 = 0.0_JWRB + CONST2 = 0.0_JWRB + END IF + + + ! TAUHF : + IF (LLGCBZ0) THEN + ZSUP = MIN(LOG(OMS*SQRTZ0OG), ZSUPMAX) + ELSE + ZSUP = ZSUPMAX + END IF + + TAUL = UST(IJ)**2 + DELZ = MAX((ZSUP - ZINF) / REAL(JTOT_TAUHF - 1, kind=JWRB), 0.0_JWRB) + TAUHF(IJ) = 0.0_JWRB + + ! Intergrals are integrated following a change of variable : Z=LOG(Y) + IF (LTAUWSHELTER) THEN + DO J=1,JTOT_TAUHF + Y = EXP(ZINF + REAL(J - 1, kind=JWRB)*DELZ) + OMEGA = Y*SQRTGZ0 + CM1 = OMEGA*GM1 + ZX = UST(IJ)*CM1 + ZALP + ZARG = XKAPPA / ZX + ZLOG = XLOGGZ0 + 2.0_JWRB*LOG(CM1) + ZARG + ZLOG = MIN(ZLOG, 0.0_JWRB) + ZBETA = ZLOG**4*EXP(ZLOG) + ZNZ = ZBETA*UST(IJ)*Y + GAMNORMA = (1.0_JWRB + CONST1*ZNZ) / (1.0_JWRB + CONST2*ZNZ) + FNC2 = F1DCOS3*CONSTTAU*ZBETA*TAUL*WTAUHF(J)*DELZ*GAMNORMA + TAUL = MAX(TAUL - TAUWSHELTER*FNC2, 0.0_JWRB) + + UST(IJ) = SQRT(TAUL) + TAUHF(IJ) = TAUHF(IJ) + FNC2 + END DO + ELSE + DO J=1,JTOT_TAUHF + Y = EXP(ZINF + REAL(J - 1, kind=JWRB)*DELZ) + OMEGA = Y*SQRTGZ0 + CM1 = OMEGA*GM1 + ZX = UST(IJ)*CM1 + ZALP + ZARG = XKAPPA / ZX + ZLOG = XLOGGZ0 + 2.0_JWRB*LOG(CM1) + ZARG + ZLOG = MIN(ZLOG, 0.0_JWRB) + ZBETA = ZLOG**4*EXP(ZLOG) + FNC2 = ZBETA*WTAUHF(J) + ZNZ = ZBETA*UST(IJ)*Y + GAMNORMA = (1.0_JWRB + CONST1*ZNZ) / (1.0_JWRB + CONST2*ZNZ) + TAUHF(IJ) = TAUHF(IJ) + FNC2*GAMNORMA + END DO + TAUHF(IJ) = F1DCOS3*CONSTTAU*TAUL*TAUHF(IJ)*DELZ + END IF + + + PHIHF(IJ) = 0.0_JWRB + IF (LLPHIHF) THEN + ! PHIHF: + ! We are neglecting the gravity-capillary contribution + ! Recompute DELZ over the full interval + TAUL = USTPH**2 + ZSUP = ZSUPMAX + DELZ = MAX((ZSUP - ZINF) / REAL(JTOT_TAUHF - 1, kind=JWRB), 0.0_JWRB) + + CONSTPHI = AIRD(IJ, ICHNK)*ZPI4GM1*FR5(MIJ(IJ, ICHNK)) + + ! Intergrals are integrated following a change of variable : Z=LOG(Y) + IF (LTAUWSHELTER) THEN + DO J=1,JTOT_TAUHF + Y = EXP(ZINF + REAL(J - 1, kind=JWRB)*DELZ) + OMEGA = Y*SQRTGZ0 + CM1 = OMEGA*GM1 + ZX = USTPH*CM1 + ZALP + ZARG = XKAPPA / ZX + ZLOG = XLOGGZ0 + 2.0_JWRB*LOG(CM1) + ZARG + ZLOG = MIN(ZLOG, 0.0_JWRB) + ZBETA = ZLOG**4*EXP(ZLOG) + ZNZ = ZBETA*UST(IJ)*Y + GAMNORMA = (1.0_JWRB + CONST1*ZNZ) / (1.0_JWRB + CONST2*ZNZ) + FNC2 = ZBETA*TAUL*WTAUHF(J)*DELZ*GAMNORMA + TAUL = MAX(TAUL - TAUWSHELTER*F1DCOS3*CONSTTAU*FNC2, 0.0_JWRB) + USTPH = SQRT(TAUL) + PHIHF(IJ) = PHIHF(IJ) + FNC2 / Y + END DO + PHIHF(IJ) = F1DCOS2*CONSTPHI*SQRTZ0OG*PHIHF(IJ) + ELSE + DO J=1,JTOT_TAUHF + Y = EXP(ZINF + REAL(J - 1, kind=JWRB)*DELZ) + OMEGA = Y*SQRTGZ0 + CM1 = OMEGA*GM1 + ZX = USTPH*CM1 + ZALP + ZARG = XKAPPA / ZX + ZLOG = XLOGGZ0 + 2.0_JWRB*LOG(CM1) + ZARG + ZLOG = MIN(ZLOG, 0.0_JWRB) + ZBETA = ZLOG**4*EXP(ZLOG) + ZNZ = ZBETA*UST(IJ)*Y + GAMNORMA = (1.0_JWRB + CONST1*ZNZ) / (1.0_JWRB + CONST2*ZNZ) + FNC2 = ZBETA*WTAUHF(J)*GAMNORMA + PHIHF(IJ) = PHIHF(IJ) + FNC2 / Y + END DO + PHIHF(IJ) = F1DCOS2*CONSTPHI*SQRTZ0OG*TAUL*PHIHF(IJ)*DELZ + END IF + END IF + + + + END SUBROUTINE TAU_PHI_HF_CUF_HOIST_NEW +END MODULE TAU_PHI_HF_CUF_HOIST_NEW_MOD +MODULE MEANSQS_GC_CUF_HOIST_NEW_MOD + !CONTAINED SUBROUTINES: + ! - MEANSQS_GC + CONTAINS + SUBROUTINE MEANSQS_GC (XKMSS, KIJS, KIJL, HALP, USTAR, XMSSCG, FRGC) + + !*** DETERMINE MSS FOR GRAV-CAP WAVES UP TO WAVE NUMBER XKMSS + + ! AUTHOR: PETER JANSSEN + ! ------ + + ! REFERENCES: + ! ---------- + + ! VIERS PAPER EQ.(29) + + !---------------------------------------------------------------------- + + USE PARKIND_WAVE, ONLY: JWIM, JWRB, JWRU + + USE YOWFRED, ONLY: NWAV_GC, XLOGKRATIOM1_GC, XKM_GC, VG_GC, C2OSQRTVG_GC, DELKCC_GC, DELKCC_GC_NS + USE YOWPCONS, ONLY: G, ZPI, SURFT + + USE YOMHOOK, ONLY: LHOOK, DR_HOOK, JPHOOK + USE TAU_PHI_HF_MOD, ONLY: OMEGAGC + + !---------------------------------------------------------------------- + + IMPLICIT NONE + + INTEGER(KIND=JWIM), INTENT(IN) :: KIJS, KIJL + + REAL(KIND=JWRB), INTENT(IN) :: XKMSS ! WAVE NUMBER CUT-OFF + REAL(KIND=JWRB), INTENT(IN), DIMENSION(KIJL) :: HALP ! 1/2 Phillips parameter + REAL(KIND=JWRB), INTENT(IN), DIMENSION(KIJL) :: USTAR ! friction velocity + REAL(KIND=JWRB), INTENT(OUT), DIMENSION(KIJL) :: XMSSCG ! mean square slope for gravity-capillary waves + REAL(KIND=JWRB), INTENT(OUT), DIMENSION(KIJL) :: FRGC ! Frequency from which the gravity-capillary spectrum is approximated + + + INTEGER(KIND=JWIM) :: IJ, I, NE + INTEGER(KIND=JWIM), DIMENSION(KIJL) :: NS + REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + REAL(KIND=JWRB), DIMENSION(KIJL) :: XKS, OMS, COEF + + ! INCLUDE FUNCTIONS FROM GRAVITY-CAPILLARY DISPERSION REALTIONS +#include "gc_dispersion.h" + + ! ---------------------------------------------------------------------- + + IF (LHOOK) CALL DR_HOOK('MEANSQS_GC', 0, ZHOOK_HANDLE) + + NE = MIN(MAX(NINT(LOG(XKMSS*XKM_GC(1))*XLOGKRATIOM1_GC), 1), NWAV_GC) + + DO IJ=KIJS,KIJL + CALL OMEGAGC(USTAR(IJ), NS(IJ), XKS(IJ), OMS(IJ)) + FRGC(IJ) = OMS(IJ) / ZPI + IF (XKS(IJ) > XKMSS) THEN + NS(IJ) = NE + XMSSCG(IJ) = 0.0_JWRB + ELSE + XMSSCG(IJ) = DELKCC_GC_NS(NS(IJ))*XKM_GC(NS(IJ)) + END IF + END DO + + DO IJ=KIJS,KIJL + DO I=NS(IJ) + 1,NE + ! ANALYTICAL FORM INERTIAL SUB RANGE F(k) = k**(-4)*BB + ! BB = COEF(IJ)*SQRT(VG_GC(I))/C_GC(I)**2 + ! mss : integral of k**2 F(k) k dk + XMSSCG(IJ) = XMSSCG(IJ) + DELKCC_GC(I)*XKM_GC(I) + END DO + COEF(IJ) = C2OSQRTVG_GC(NS(IJ))*HALP(IJ) + XMSSCG(IJ) = XMSSCG(IJ)*COEF(IJ) + END DO + + IF (LHOOK) CALL DR_HOOK('MEANSQS_GC', 1, ZHOOK_HANDLE) + + END SUBROUTINE MEANSQS_GC +END MODULE MEANSQS_GC_CUF_HOIST_NEW_MOD diff --git a/src/phys-scc-cuf-hoist/taut_z0.cuf_hoist_new.F90 b/src/phys-scc-cuf-hoist/taut_z0.cuf_hoist_new.F90 new file mode 100644 index 00000000..61576d43 --- /dev/null +++ b/src/phys-scc-cuf-hoist/taut_z0.cuf_hoist_new.F90 @@ -0,0 +1,396 @@ +! (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. +! +MODULE TAUT_Z0_CUF_HOIST_NEW_MOD + CONTAINS + ATTRIBUTES(DEVICE) SUBROUTINE TAUT_Z0_CUF_HOIST_NEW (KIJS, KIJL, IUSFG, HALP, UTOP, UDIR, TAUW, TAUWDIR, RNFAC, USTAR, Z0, & + & Z0B, CHRNCK, ACD, ALPHA, ALPHAMAX, ALPHAMIN, ANG_GC_A, ANG_GC_B, ANG_GC_C, BCD, BETAMAXOXKAPPA2, BMAXOKAP, C2OSQRTVG_GC, & + & CDMAX, CHNKMIN_U, CM_GC, DELKCC_GC_NS, DELKCC_OMXKM3_GC, EPS1, EPSMIN, EPSUS, G, GM1, LLCAPCHNK, LLGCBZ0, LLNORMAGAM, & + & NWAV_GC, OM3GMKM_GC, OMXKM3_GC, RN1_RN, RNU, RNUM, SQRTGOSURFT, XKAPPA, XKMSQRTVGOC2_GC, XKM_GC, XK_GC, XLOGKRATIOM1_GC, & + & XNLEV, ZALP, ICHNK, NCHNK, IJ) + + ! ---------------------------------------------------------------------- + + !**** *TAUT_Z0* - COMPUTATION OF TOTAL STRESS AND ROUGHNESS LENGTH SCALE. + + + !** INTERFACE. + ! ---------- + + ! *CALL* *TAUT_Z0(KIJS, KIJL, IUSFG, FL1, WAVNUM, + ! UTOP, UDIR, TAUW, TAUWDIR, RNFAC, + ! USTAR, Z0, Z0B, CHRNCK) + ! *KIJS* - INDEX OF FIRST GRIDPOINT + ! *KIJL* - INDEX OF LAST GRIDPOINT + ! *IUSFG* - IF = 1 THEN USE THE FRICTION VELOCITY (US) AS FIRST GUESS in TAUT_Z0 + ! 0 DO NOT USE THE FIELD USTAR + ! *FL1* - 2D-SPECTRA + ! *WAVNUM* - WAVE NUMBER + ! *HALP* - 1/2 PHILLIPS PARAMETER + ! *UTOP* - WIND SPEED AT REFERENCE LEVEL XNLEV + ! *UDIR* - WIND SPEED DIRECTION AT REFERENCE LEVEL XNLEV + ! *TAUW* - WAVE STRESS. + ! *TAUWDIR* - WAVE STRESS DIRECTION. + ! *RNFAC* - WIND DEPENDENT FACTOR USED IN THE GROWTH RENORMALISATION. + ! *USTAR* - FRICTION VELOCITY + ! *Z0* - ROUGHNESS LENGTH + ! *Z0B* - BACKGROUND ROUGHNESS LENGTH + ! *CHRNCK* - CHARNOCK COEFFICIENT + + ! METHOD. + ! ------- + + ! A STEADY STATE WIND PROFILE IS ASSUMED. + ! THE WIND STRESS IS COMPUTED USING THE ROUGHNESS LENGTH + + ! Z1=Z0/SQRT(1-TAUW/TAU) + + ! WHERE Z0 IS THE CHARNOCK RELATION , TAUW IS THE WAVE- + ! INDUCED STRESS AND TAU IS THE TOTAL STRESS. + ! WE SEARCH FOR STEADY-STATE SOLUTIONS FOR WHICH TAUW/TAU < 1. + + ! IT WAS EXTENDED TO INCLUDE THE GRAVITY-CAPILLARY MODEL FOR THE CALCULATION + ! OF THE BACKGROUND ROUGHNESS. + + ! EXTERNALS. + ! ---------- + + ! NONE. + + ! REFERENCE. + ! ---------- + + ! FOR QUASILINEAR EFFECT SEE PETER A.E.M. JANSSEN,1990. + + ! ---------------------------------------------------------------------- + + USE STRESS_GC_CUF_HOIST_NEW_MOD, ONLY: STRESS_GC_CUF_HOIST_NEW + USE CHNKMIN_CUF_HOIST_NEW_MOD, ONLY: CHNKMIN_CUF_HOIST_NEW + USE cudafor + USE PARKIND_WAVE, ONLY: JWIM, JWRU, JWRB + + USE YOWPARAM, ONLY: NFRE, NANG + + + ! ---------------------------------------------------------------------- + + IMPLICIT NONE + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJS + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJL + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: IUSFG + REAL(KIND=JWRB), INTENT(IN) :: HALP(KIJL) + REAL(KIND=JWRB), INTENT(IN) :: RNFAC(KIJL) + REAL(KIND=JWRB), INTENT(IN) :: UTOP(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: UDIR(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: TAUW(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: TAUWDIR(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: USTAR(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(OUT) :: Z0(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(OUT) :: Z0B(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(OUT) :: CHRNCK(KIJL, NCHNK) + + + INTEGER(KIND=JWIM), PARAMETER :: NITER = 17 + + REAL(KIND=JWRB), PARAMETER :: TWOXMP1 = 3.0_JWRB + + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: IJ + INTEGER(KIND=JWIM) :: ITER + INTEGER(KIND=JWIM) :: IFRPH + + ! Cd and Z0 from Hersbach 2010, ECMWF Tech Memo (without the viscous part) + ! 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) :: ALPHAGM1 + + REAL(KIND=JWRB), PARAMETER :: Z0MIN = 0.000001_JWRB + REAL(KIND=JWRB) :: PCE_GC + REAL(KIND=JWRB) :: Z0MINRST + REAL(KIND=JWRB) :: CHARNOCK_MIN + REAL(KIND=JWRB) :: COSDIFF + REAL(KIND=JWRB) :: ZCHAR + REAL(KIND=JWRB) :: US2TOTAUW + REAL(KIND=JWRB) :: USMAX + REAL(KIND=JWRB) :: XLOGXL + REAL(KIND=JWRB) :: XKUTOP + REAL(KIND=JWRB) :: XOLOGZ0 + REAL(KIND=JWRB) :: USTOLD + REAL(KIND=JWRB) :: USTNEW + REAL(KIND=JWRB) :: TAUOLD + REAL(KIND=JWRB) :: TAUNEW + REAL(KIND=JWRB) :: X + REAL(KIND=JWRB) :: F + REAL(KIND=JWRB) :: DELF + REAL(KIND=JWRB) :: CDFG + REAL(KIND=JWRB) :: USTM1 + REAL(KIND=JWRB) :: Z0TOT + REAL(KIND=JWRB) :: Z0CH + REAL(KIND=JWRB) :: Z0VIS + REAL(KIND=JWRB) :: HZ0VISO1MX + REAL(KIND=JWRB) :: ZZ + REAL(KIND=JWRB) :: CONST + REAL(KIND=JWRB) :: TAUV + REAL(KIND=JWRB) :: DEL + REAL(KIND=JWRB) :: RNUEFF + REAL(KIND=JWRB) :: RNUKAPPAM1 + REAL(KIND=JWRB) :: ALPHAOG + REAL(KIND=JWRB) :: XMIN + REAL(KIND=JWRB) :: W1 + REAL(KIND=JWRB) :: TAUWACT + REAL(KIND=JWRB) :: TAUWEFF + REAL(KIND=JWRB) :: ANG_GC + REAL(KIND=JWRB) :: TAUUNR + + LOGICAL :: LLCOSDIFF + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ACD + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ALPHA + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ALPHAMAX + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ALPHAMIN + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ANG_GC_A + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ANG_GC_B + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ANG_GC_C + REAL(KIND=JWRB), VALUE, INTENT(IN) :: BCD + REAL(KIND=JWRB), VALUE, INTENT(IN) :: BETAMAXOXKAPPA2 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: BMAXOKAP + REAL(KIND=JWRB), INTENT(IN), DEVICE :: C2OSQRTVG_GC(NWAV_GC) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: CDMAX + REAL(KIND=JWRB), VALUE, INTENT(IN) :: CHNKMIN_U + REAL(KIND=JWRB), INTENT(IN), DEVICE :: CM_GC(NWAV_GC) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: DELKCC_GC_NS(NWAV_GC) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: DELKCC_OMXKM3_GC(NWAV_GC) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: EPS1 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: EPSMIN + REAL(KIND=JWRB), VALUE, INTENT(IN) :: EPSUS + REAL(KIND=JWRB), VALUE, INTENT(IN) :: G + REAL(KIND=JWRB), VALUE, INTENT(IN) :: GM1 + LOGICAL, VALUE, INTENT(IN) :: LLCAPCHNK + LOGICAL, VALUE, INTENT(IN) :: LLGCBZ0 + LOGICAL, VALUE, INTENT(IN) :: LLNORMAGAM + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NWAV_GC + REAL(KIND=JWRB), INTENT(IN), DEVICE :: OM3GMKM_GC(NWAV_GC) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: OMXKM3_GC(NWAV_GC) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: RN1_RN + REAL(KIND=JWRB), VALUE, INTENT(IN) :: RNU + REAL(KIND=JWRB), VALUE, INTENT(IN) :: RNUM + REAL(KIND=JWRB), VALUE, INTENT(IN) :: SQRTGOSURFT + REAL(KIND=JWRB), VALUE, INTENT(IN) :: XKAPPA + REAL(KIND=JWRB), INTENT(IN), DEVICE :: XKMSQRTVGOC2_GC(NWAV_GC) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: XKM_GC(NWAV_GC) + REAL(KIND=JWRB), INTENT(IN), DEVICE :: XK_GC(NWAV_GC) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: XLOGKRATIOM1_GC + REAL(KIND=JWRB), VALUE, INTENT(IN) :: XNLEV + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ZALP + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: ICHNK + INTEGER, VALUE, INTENT(IN) :: NCHNK + + ! ---------------------------------------------------------------------- + + + XLOGXL = LOG(XNLEV) + US2TOTAUW = 1.0_JWRB + EPS1 + + ! ONLY take the contribution of TAUW that is in the wind direction + + COSDIFF = COS(UDIR(IJ, ICHNK) - TAUWDIR(IJ, ICHNK)) + TAUWACT = MAX(TAUW(IJ, ICHNK)*COSDIFF, EPSMIN) + LLCOSDIFF = COSDIFF > 0.9_JWRB + + ! USING THE CG MODEL: + IF (LLGCBZ0) THEN + + IF (LLCAPCHNK) THEN + CHARNOCK_MIN = CHNKMIN_CUF_HOIST_NEW(UTOP(IJ, ICHNK), ALPHA, ALPHAMIN, CHNKMIN_U) + ALPHAOG = CHARNOCK_MIN*GM1 + ELSE + ALPHAOG = 0.0_JWRB + END IF + + USMAX = MAX(-0.21339_JWRB + 0.093698_JWRB*UTOP(IJ, ICHNK) - 0.0020944_JWRB*UTOP(IJ, ICHNK)**2 + 5.5091E-5_JWRB*UTOP(IJ, & + & ICHNK)**3, 0.03_JWRB) + TAUWEFF = MIN(TAUWACT*US2TOTAUW, USMAX**2) + + RNUEFF = 0.04_JWRB*RNU + + RNUKAPPAM1 = RNUEFF / XKAPPA + + PCE_GC = 0.001_JWRB*IUSFG + (1 - IUSFG)*0.005_JWRB + + IF (IUSFG == 0) THEN + ALPHAGM1 = ALPHA*GM1 + IF (UTOP(IJ, ICHNK) < 1.0_JWRB) THEN + CDFG = 0.002_JWRB + ELSE IF (LLCOSDIFF) THEN + X = MIN(TAUWACT / MAX(USTAR(IJ, ICHNK), EPSUS)**2, 0.99_JWRB) + ZCHAR = MIN(ALPHAGM1*USTAR(IJ, ICHNK)**2 / SQRT(1.0_JWRB - X), 0.05_JWRB*EXP(-0.05_JWRB*(UTOP(IJ, ICHNK) - 35._JWRB))) + ZCHAR = MIN(ZCHAR, ALPHAMAX) + CDFG = ACDLIN + BCDLIN*SQRT(ZCHAR)*UTOP(IJ, ICHNK) + ELSE + ! CDFG = CDM(UTOP(IJ)) ! TODO: revert and automate + CDFG = MAX(MIN(0.0006_JWRB + 0.00008_JWRB*UTOP(IJ, ICHNK), 0.001_JWRB + 0.0018_JWRB*EXP(-0.05_JWRB*(UTOP(IJ, ICHNK) - & + & 33._JWRB))), 0.001_JWRB) + END IF + USTAR(IJ, ICHNK) = UTOP(IJ, ICHNK)*SQRT(CDFG) + END IF + + W1 = 0.85_JWRB - 0.05_JWRB*(TANH(10.0_JWRB*(UTOP(IJ, ICHNK) - 5.0_JWRB)) + 1.0_JWRB) + + XKUTOP = XKAPPA*UTOP(IJ, ICHNK) + + USTOLD = USTAR(IJ, ICHNK) + TAUOLD = USTOLD**2 + + DO ITER=1,NITER + ! Z0 IS DERIVED FROM THE NEUTRAL LOG PROFILE: UTOP = (USTAR/XKAPPA)*LOG((XNLEV+Z0)/Z0) + Z0(IJ, ICHNK) = MAX(XNLEV / (EXP(MIN(XKUTOP / USTOLD, 50.0_JWRB)) - 1.0_JWRB), Z0MIN) + ! Viscous kinematic stress nu_air * dU/dz at z=0 of the neutral log profile reduced by factor 25 (0.04) + TAUV = RNUKAPPAM1*USTOLD / Z0(IJ, ICHNK) + + ANG_GC = ANG_GC_A + ANG_GC_B*TANH(ANG_GC_C*TAUOLD) + + TAUUNR = STRESS_GC_CUF_HOIST_NEW(ANG_GC, USTAR(IJ, ICHNK), Z0(IJ, ICHNK), Z0MIN, HALP(IJ), RNFAC(IJ), BETAMAXOXKAPPA2, & + & BMAXOKAP, C2OSQRTVG_GC, CM_GC, DELKCC_GC_NS, DELKCC_OMXKM3_GC, EPSUS, LLNORMAGAM, NWAV_GC, OM3GMKM_GC, OMXKM3_GC, & + & RN1_RN, SQRTGOSURFT, XKAPPA, XKMSQRTVGOC2_GC, XKM_GC, XK_GC, XLOGKRATIOM1_GC, ZALP) + + ! TOTAL kinematic STRESS: + TAUNEW = TAUWEFF + TAUV + TAUUNR + USTNEW = SQRT(TAUNEW) + USTAR(IJ, ICHNK) = W1*USTOLD + (1.0_JWRB - W1)*USTNEW + + ! CONVERGENCE ? + DEL = USTAR(IJ, ICHNK) - USTOLD + IF (ABS(DEL) < PCE_GC*USTAR(IJ, ICHNK)) EXIT + TAUOLD = USTAR(IJ, ICHNK)**2 + USTOLD = USTAR(IJ, ICHNK) + END DO + ! protection just in case there is no convergence + IF (ITER > NITER) THEN + ! CDFG = CDM(UTOP(IJ)) + CDFG = MAX(MIN(0.0006_JWRB + 0.00008_JWRB*UTOP(IJ, ICHNK), 0.001_JWRB + 0.0018_JWRB*EXP(-0.05_JWRB*(UTOP(IJ, ICHNK) - & + & 33._JWRB))), 0.001_JWRB) + USTAR(IJ, ICHNK) = UTOP(IJ, ICHNK)*SQRT(CDFG) + Z0MINRST = USTAR(IJ, ICHNK)**2*ALPHA*GM1 + Z0(IJ, ICHNK) = MAX(XNLEV / (EXP(XKUTOP / USTAR(IJ, ICHNK)) - 1.0_JWRB), Z0MINRST) + Z0B(IJ, ICHNK) = Z0MINRST + ELSE + Z0(IJ, ICHNK) = MAX(XNLEV / (EXP(XKUTOP / USTAR(IJ, ICHNK)) - 1.0_JWRB), Z0MIN) + Z0B(IJ, ICHNK) = Z0(IJ, ICHNK)*SQRT(TAUUNR / TAUOLD) + END IF + + ! Refine solution + X = TAUWEFF / TAUOLD + + IF (X < 0.99_JWRB) THEN + USTOLD = USTAR(IJ, ICHNK) + TAUOLD = MAX(USTOLD**2, TAUWEFF) + + DO ITER=1,NITER + X = MIN(TAUWEFF / TAUOLD, 0.99_JWRB) + USTM1 = 1.0_JWRB / MAX(USTOLD, EPSUS) + !!!! Limit how small z0 could become + !!!! This is a bit of a compromise to limit very low Charnock for intermediate high winds (15 -25 m/s) + !!!! It is not ideal !!! + Z0(IJ, ICHNK) = MAX(XNLEV / (EXP(MIN(XKUTOP / USTOLD, 50.0_JWRB)) - 1.0_JWRB), Z0MIN) + + TAUUNR = STRESS_GC_CUF_HOIST_NEW(ANG_GC, USTOLD, Z0(IJ, ICHNK), Z0MIN, HALP(IJ), RNFAC(IJ), BETAMAXOXKAPPA2, BMAXOKAP, & + & C2OSQRTVG_GC, CM_GC, DELKCC_GC_NS, DELKCC_OMXKM3_GC, EPSUS, LLNORMAGAM, NWAV_GC, OM3GMKM_GC, OMXKM3_GC, RN1_RN, & + & SQRTGOSURFT, XKAPPA, XKMSQRTVGOC2_GC, XKM_GC, XK_GC, XLOGKRATIOM1_GC, ZALP) + + Z0B(IJ, ICHNK) = MAX(Z0(IJ, ICHNK)*SQRT(TAUUNR / TAUOLD), ALPHAOG*TAUOLD) + Z0VIS = RNUM*USTM1 + HZ0VISO1MX = 0.5_JWRB*Z0VIS / (1.0_JWRB - X) + Z0(IJ, ICHNK) = HZ0VISO1MX + SQRT(HZ0VISO1MX**2 + Z0B(IJ, ICHNK)**2 / (1.0_JWRB - X)) + + XOLOGZ0 = 1.0_JWRB / (XLOGXL - LOG(Z0(IJ, ICHNK))) + F = USTOLD - XKUTOP*XOLOGZ0 + ZZ = 2.0_JWRB*USTM1*(3.0_JWRB*Z0B(IJ, ICHNK)**2 + 0.5_JWRB*Z0VIS*Z0(IJ, ICHNK) - Z0(IJ, ICHNK)**2) / (2.0_JWRB*Z0(IJ, & + & ICHNK)**2*(1.0_JWRB - X) - Z0VIS*Z0(IJ, ICHNK)) + + DELF = 1.0_JWRB - XKUTOP*XOLOGZ0**2*ZZ + IF (DELF /= 0.0_JWRB) USTAR(IJ, ICHNK) = USTOLD - F / DELF + + ! CONVERGENCE ? + DEL = USTAR(IJ, ICHNK) - USTOLD + + IF (ABS(DEL) < PCE_GC*USTAR(IJ, ICHNK)) EXIT + USTOLD = USTAR(IJ, ICHNK) + TAUOLD = MAX(USTOLD**2, TAUWEFF) + END DO + ! protection just in case there is no convergence + IF (ITER > NITER) THEN + ! CDFG = CDM(UTOP(IJ)) + CDFG = MAX(MIN(0.0006_JWRB + 0.00008_JWRB*UTOP(IJ, ICHNK), 0.001_JWRB + 0.0018_JWRB*EXP(-0.05_JWRB*(UTOP(IJ, ICHNK) - & + & 33._JWRB))), 0.001_JWRB) + USTAR(IJ, ICHNK) = UTOP(IJ, ICHNK)*SQRT(CDFG) + Z0MINRST = USTAR(IJ, ICHNK)**2*ALPHA*GM1 + Z0(IJ, ICHNK) = MAX(XNLEV / (EXP(XKUTOP / USTAR(IJ, ICHNK)) - 1.0_JWRB), Z0MINRST) + Z0B(IJ, ICHNK) = Z0MINRST + CHRNCK(IJ, ICHNK) = MAX(G*Z0(IJ, ICHNK) / USTAR(IJ, ICHNK)**2, ALPHAMIN) + ELSE + CHRNCK(IJ, ICHNK) = MAX(G*(Z0B(IJ, ICHNK) / SQRT(1.0_JWRB - X)) / MAX(USTAR(IJ, ICHNK), EPSUS)**2, ALPHAMIN) + END IF + + ELSE + USTM1 = 1.0_JWRB / MAX(USTAR(IJ, ICHNK), EPSUS) + Z0VIS = RNUM*USTM1 + CHRNCK(IJ, ICHNK) = MAX(G*(Z0(IJ, ICHNK) - Z0VIS)*USTM1**2, ALPHAMIN) + END IF + + + + ELSE + + TAUWEFF = TAUWACT*US2TOTAUW + + IF (LLCAPCHNK) THEN + CHARNOCK_MIN = CHNKMIN_CUF_HOIST_NEW(UTOP(IJ, ICHNK), ALPHA, ALPHAMIN, CHNKMIN_U) + XMIN = 0.15_JWRB*(ALPHA - CHARNOCK_MIN) + ALPHAOG = CHARNOCK_MIN*GM1 + ELSE + XMIN = 0.0_JWRB + ALPHAOG = ALPHA*GM1 + END IF + + XKUTOP = XKAPPA*UTOP(IJ, ICHNK) + + USTOLD = (1 - IUSFG)*UTOP(IJ, ICHNK)*SQRT(MIN(ACD + BCD*UTOP(IJ, ICHNK), CDMAX)) + IUSFG*USTAR(IJ, ICHNK) + TAUOLD = MAX(USTOLD**2, TAUWEFF) + USTAR(IJ, ICHNK) = SQRT(TAUOLD) + USTM1 = 1.0_JWRB / MAX(USTAR(IJ, ICHNK), EPSUS) + + DO ITER=1,NITER + X = MAX(TAUWACT / TAUOLD, XMIN) + Z0CH = ALPHAOG*TAUOLD / SQRT(1.0_JWRB - X) + Z0VIS = RNUM*USTM1 + Z0TOT = Z0CH + Z0VIS + + XOLOGZ0 = 1.0_JWRB / (XLOGXL - LOG(Z0TOT)) + F = USTAR(IJ, ICHNK) - XKUTOP*XOLOGZ0 + ZZ = USTM1*(Z0CH*(2.0_JWRB - TWOXMP1*X) / (1.0_JWRB - X) - Z0VIS) / Z0TOT + DELF = 1.0_JWRB - XKUTOP*XOLOGZ0**2*ZZ + + IF (DELF /= 0.0_JWRB) USTAR(IJ, ICHNK) = USTAR(IJ, ICHNK) - F / DELF + TAUNEW = MAX(USTAR(IJ, ICHNK)**2, TAUWEFF) + USTAR(IJ, ICHNK) = SQRT(TAUNEW) + IF (TAUNEW == TAUOLD) EXIT + USTM1 = 1.0_JWRB / MAX(USTAR(IJ, ICHNK), EPSUS) + TAUOLD = TAUNEW + END DO + + Z0(IJ, ICHNK) = Z0CH + Z0B(IJ, ICHNK) = ALPHAOG*TAUOLD + CHRNCK(IJ, ICHNK) = MAX(G*Z0(IJ, ICHNK)*USTM1**2, ALPHAMIN) + + + END IF + + + + + END SUBROUTINE TAUT_Z0_CUF_HOIST_NEW +END MODULE TAUT_Z0_CUF_HOIST_NEW_MOD diff --git a/src/phys-scc-cuf-hoist/transf.cuf_hoist_new.F90 b/src/phys-scc-cuf-hoist/transf.cuf_hoist_new.F90 new file mode 100644 index 00000000..c7638b94 --- /dev/null +++ b/src/phys-scc-cuf-hoist/transf.cuf_hoist_new.F90 @@ -0,0 +1,75 @@ +! (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. +! +MODULE TRANSF_CUF_HOIST_NEW_MOD + CONTAINS + ATTRIBUTES(DEVICE) FUNCTION TRANSF_CUF_HOIST_NEW (XK, D, DKMAX, G) + ! + !*** DETERMINE NARROW BAND LIMIT NONLINEAR TRANSFER FUNCTION + ! BASED ON TECH MEMO 464 BY P. JANSSEN AND M. ONORATO + ! + ! + ! AUTHOR: P.A.E.M. JANSSEN ECMWF JUNE 2005 + ! ------ + ! + ! VARIABLE TYPE PURPOSE + ! -------- ---- ------- + ! + ! XK REAL WAVE NUMBER + ! D REAL DEPTH + ! + !---------------------------------------------------------------------- + + USE cudafor + USE PARKIND_WAVE, ONLY: JWIM, JWRU, JWRB + + + !---------------------------------------------------------------------- + + IMPLICIT NONE + + REAL(KIND=JWRB) :: TRANSF_CUF_HOIST_NEW + REAL(KIND=JWRB), INTENT(IN) :: XK, D + REAL(KIND=JWRB) :: EPS, X, T_0, OM, C_0, V_G, DV_G, XNL_1, XNL_2, XNL + REAL(KIND=JWRB), INTENT(IN) :: DKMAX + REAL(KIND=JWRB), INTENT(IN) :: G +!$acc routine seq + + EPS = 0.0001_JWRB + ! + !* 1. DETERMINE TRANSFER FUNCTION. + ! ------------------------------ + ! + IF (D < 999.0_JWRB .and. D > 0.0_JWRB) THEN + X = XK*D + IF (X > DKMAX) THEN + TRANSF_CUF_HOIST_NEW = 1.0_JWRB + ELSE + T_0 = TANH(X) + OM = SQRT(G*XK*T_0) + C_0 = OM / XK + IF (X < EPS) THEN + V_G = 0.5_JWRB*C_0 + V_G = C_0 + ELSE + V_G = 0.5_JWRB*C_0*(1.0_JWRB + 2.0_JWRB*X / SINH(2.0_JWRB*X)) + END IF + DV_G = (T_0 - X*(1.0_JWRB - T_0**2))**2 + 4.0_JWRB*X**2*T_0**2*(1.0_JWRB - T_0**2) + + XNL_1 = (9.0_JWRB*T_0**4 - 10.0_JWRB*T_0**2 + 9.0_JWRB) / (8.0_JWRB*T_0**3) + XNL_2 = ((2.0_JWRB*V_G - 0.5_JWRB*C_0)**2 / (G*D - V_G**2) + 1.0_JWRB) / X + + XNL = XNL_1 - XNL_2 + TRANSF_CUF_HOIST_NEW = XNL**2 / (DV_G*T_0**8) + END IF + ELSE + TRANSF_CUF_HOIST_NEW = 1.0_JWRB + END IF + ! + END FUNCTION TRANSF_CUF_HOIST_NEW +END MODULE TRANSF_CUF_HOIST_NEW_MOD diff --git a/src/phys-scc-cuf-hoist/transf_snl.cuf_hoist_new.F90 b/src/phys-scc-cuf-hoist/transf_snl.cuf_hoist_new.F90 new file mode 100644 index 00000000..5edbf7f0 --- /dev/null +++ b/src/phys-scc-cuf-hoist/transf_snl.cuf_hoist_new.F90 @@ -0,0 +1,94 @@ +! (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. +! +MODULE TRANSF_SNL_CUF_HOIST_NEW_MOD + CONTAINS + ATTRIBUTES(DEVICE) FUNCTION TRANSF_SNL_CUF_HOIST_NEW (XK0, D, XNU, SIG_TH, BATHYMAX, DKMAX, G, XKDMIN) + + !*** DETERMINE NARROW BAND LIMIT NONLINEAR TRANSFER FUNCTION + + ! VARIABLE TYPE PURPOSE + ! -------- ---- ------- + + ! XK0 REAL WAVE NUMBER + ! D REAL DEPTH + ! XNU REAL RELATIVE SPECTRAL WIDTH + ! SIG_TH REAL RELATIVE WIDTH in DIRECTION + + !---------------------------------------------------------------------- + + USE cudafor + USE PARKIND_WAVE, ONLY: JWIM, JWRU, JWRB + + + + !---------------------------------------------------------------------- + + IMPLICIT NONE + + REAL(KIND=JWRB) :: TRANSF_SNL_CUF_HOIST_NEW + REAL(KIND=JWRB), INTENT(IN) :: XK0, D, XNU, SIG_TH + + REAL(KIND=JWRB), PARAMETER :: EPS = 0.0001_JWRB + REAL(KIND=JWRB), PARAMETER :: TRANSF_SNL_MIN = 0.1_JWRB + REAL(KIND=JWRB), PARAMETER :: TRANSF_SNL_MAX = 10._JWRB + + REAL(KIND=JWRB) :: X, XK, T_0, T_0_SQ, OM, C_0, V_G, V_G_SQ, DV_G + REAL(KIND=JWRB) :: XNL_1, XNL_2, XNL_3, XNL_4, XNL + REAL(KIND=JWRB) :: C_S_SQ, ALP, ZFAC + REAL(KIND=JWRB), INTENT(IN) :: BATHYMAX + REAL(KIND=JWRB), INTENT(IN) :: DKMAX + REAL(KIND=JWRB), INTENT(IN) :: G + REAL(KIND=JWRB), INTENT(IN) :: XKDMIN +!$acc routine seq + + !---------------------------------------------------------------------- + + + !* 1. DETERMINE TRANSFER FUNCTION. + ! ------------------------------ + + IF (D < BATHYMAX .and. D > 0._JWRB) THEN + X = XK0*D + IF (X > DKMAX) THEN + TRANSF_SNL_CUF_HOIST_NEW = 1._JWRB + ELSE + XK = MAX(XK0, XKDMIN / D) + X = XK*D + T_0 = TANH(X) + T_0_SQ = T_0**2 + OM = SQRT(G*XK*T_0) + C_0 = OM / XK + C_S_SQ = G*D + IF (X < EPS) THEN + V_G = C_0 + ELSE + V_G = 0.5_JWRB*C_0*(1._JWRB + 2._JWRB*X / SINH(2._JWRB*X)) + END IF + V_G_SQ = V_G**2 + DV_G = (T_0 - X*(1. - T_0_SQ))**2 + 4._JWRB*X**2*T_0_SQ*(1._JWRB - T_0_SQ) + + XNL_1 = (9._JWRB*T_0_SQ**2 - 10._JWRB*T_0_SQ + 9._JWRB) / (8._JWRB*T_0_SQ*T_0) + XNL_2 = ((2._JWRB*V_G - 0.5_JWRB*C_0)**2 / (G*D - V_G_SQ) + 1._JWRB) / X + XNL_4 = 1. / (4._JWRB*T_0)*(2._JWRB*C_0 + V_G*(1._JWRB - T_0_SQ))**2 / (C_S_SQ - V_G_SQ) + ALP = (1. - V_G_SQ / C_S_SQ)*C_0**2 / V_G_SQ + ZFAC = SIG_TH**2 / (SIG_TH**2 + ALP*XNU**2) + XNL_3 = ZFAC*XNL_4 + + XNL = XNL_1 - XNL_2 + XNL_3 + TRANSF_SNL_CUF_HOIST_NEW = XNL**2 / (DV_G*T_0_SQ**4) + TRANSF_SNL_CUF_HOIST_NEW = MAX(MIN(TRANSF_SNL_MAX, TRANSF_SNL_CUF_HOIST_NEW), TRANSF_SNL_MIN) + END IF + ELSE + TRANSF_SNL_CUF_HOIST_NEW = 1._JWRB + END IF + + + + END FUNCTION TRANSF_SNL_CUF_HOIST_NEW +END MODULE TRANSF_SNL_CUF_HOIST_NEW_MOD diff --git a/src/phys-scc-cuf-hoist/wamintgr_loki_gpu.cuf_hoist_new.F90 b/src/phys-scc-cuf-hoist/wamintgr_loki_gpu.cuf_hoist_new.F90 new file mode 100644 index 00000000..6ec95ebb --- /dev/null +++ b/src/phys-scc-cuf-hoist/wamintgr_loki_gpu.cuf_hoist_new.F90 @@ -0,0 +1,694 @@ +! (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 WAMINTGR_LOKI_GPU (CDTPRA, CDATE, CDATEWH, CDTIMP, CDTIMPNEXT, BLK2GLO, WVENVI, WVPRPT, FF_NOW, FF_NEXT, INTFLDS, & +& WAM2NEMO, MIJ, FL1, XLLWS, TIME1) + + + ! ---------------------------------------------------------------------- + + !**** *WAMINTGR* - 3-G WAM MODEL - TIME INTEGRATION OF WAVE FIELDS. + + !* PURPOSE. + ! -------- + + ! COMPUTATION OF THE 2-D FREQUENCY-DIRECTION WAVE SPECTRUM AT ALL + ! GRID POINTS FOR A GIVEN INITIAL SPECTRUM AND FORCING SURFACE + ! STRESS FIELD. + + ! REFERENCE. + ! ---------- + + ! IFS DOCUMENTATION, part VII + + ! ------------------------------------------------------------------- + + USE IMPLSCH_CUF_HOIST_NEW_MOD, ONLY: IMPLSCH_CUF_HOIST_NEW + USE cudafor + ![Loki::GlobalVarHoistTransformation] -------- Added global variable imports for offload directives ----------- + USE yowwndg, ONLY: ICODE_CPL, ICODE + USE yowwind, ONLY: WSPMIN + USE yowparam, ONLY: NFRE_ODD, NFRE_RED, LLUNSTR + USE yowtabl, ONLY: SWELLFT, EPS1, IAB + USE yowcout, ONLY: LWFLUXOUT + USE yowindn, ONLY: AF11, FKLAM, IKP, FKLAP, IKP1, INLCOEF, IKM, KFRH, K1W, DAL1, K2W, RNLCOEF, FKLAP1, DAL2, FKLAM1, MLSTHG, & + & K21W, MFRSTLW, IKM1, K11W + USE yowstat, ONLY: ISNONLIN, LBIWBK, IPHYS, IDAMPING + USE yowshal, ONLY: BATHYMAX, NDEPTH, XKDMIN + USE yowaltas, ONLY: AFCRV, EGRCRV, BFCRV + USE yowpcons, ONLY: TAUOCMIN, ZPI, ZPI4GM1, EPSUS, PHIEPSMIN, G, ZPI4GM2, BCD, EPSU10, WSEMEAN_MIN, ACDLIN, PHIEPSMAX, & + & ROWATER, CDMAX, BCDLIN, ROWATERM1, GM1, ACD, DKMAX, SQRTGOSURFT, TAUOCMAX + USE yowcoup, ONLY: JTOT_TAUHF, LWVFLX_SNL, LWCOU, LWNEMOCOUSTK, LWFLUX, LLNORMAGAM, X0TAUHF, LLGCBZ0, LLCAPCHNK, & + & LWNEMOCOUSEND, WTAUHF, LWNEMOTAUOC, LWNEMOCOUSTRN + USE yowfred, ONLY: FR, FLOGSPRDM1, DELKCC_OMXKM3_GC, XKM_GC, WP2TAIL, SINTH, DFIMFR2, XK_GC, FLMAX, OM3GMKM_GC, DELTH, & + & OMEGA_GC, OMXKM3_GC, CM_GC, XKMSQRTVGOC2_GC, RHOWG_DFIM, COFRM4, DFIM, TH, FRTAIL, C2OSQRTVG_GC, COSTH, FR5, DFIMOFR, & + & XLOGKRATIOM1_GC, NWAV_GC, WP1TAIL, DELKCC_GC_NS, FRATIO, WETAIL, ZPIFR, DFIMFR, DFIM_SIM, FRIC + USE yowice, ONLY: LICERUN, LMASKICE, CIBLOCK, FLMIN, CITHRSH, CITHRSH_TAIL, LWAMRSETCI, LCIWABR, CDICWA + USE yowphys, ONLY: SSDSC4, BETAMAXOXKAPPA2, SSDSC2, SWELLF5, SSDSC6, Z0TUBMAX, DELTA_SDIS, RNUM, DTHRN_A, ANG_GC_A, SSDSC5, & + & XNLEV, SWELLF7, CDIS, TAILFACTOR_PM, SSDSC3, ALPHA, SWELLF, ABMIN, GAMNCONST, SDSBR, SATWEIGHTS, XKAPPA, DTHRN_U, ALPHAMIN, & + & ALPHAPMAX, ZALP, TAUWSHELTER, TAILFACTOR, ABMAX, SWELLF4, ANG_GC_C, INDICESSAT, CUMULW, RN1_RN, SWELLF2, IPSAT, MICHE, & + & Z0RAT, NSDSNTH, ALPHAMAX, CDISVIS, SWELLF3, RNU, SWELLF6, NDIKCUMUL, SWELLF7M1, CHNKMIN_U, BMAXOKAP, ANG_GC_B + ![Loki::GlobalVarHoistTransformation] --------------------------------------- + USE PARKIND_WAVE, ONLY: JWIM, JWRB, JWRU + USE YOWDRVTYPE, ONLY: WVGRIDGLO, ENVIRONMENT, FREQUENCY, FORCING_FIELDS, INTGT_PARAM_FIELDS, WAVE2OCEAN + + USE YOWCOUP, ONLY: LWNEMOCOU, NEMONTAU + USE YOWGRID, ONLY: NPROMA_WAM, NCHNK + USE YOWPARAM, ONLY: NIBLO, NANG, NFRE + USE YOWPCONS, ONLY: EPSMIN + USE YOWSTAT, ONLY: CDTPRO, IDELPRO, IDELT, IDELWI, LLSOURCE + USE YOWWIND, ONLY: CDAWIFL, CDATEWO, CDATEFL + USE YOWFIELD_MOD, ONLY: FREQUENCY_FIELD, ENVIRONMENT_FIELD, FORCING_FIELDS_FIELD, WAVE2OCEAN_FIELD, INTGT_PARAM_FIELDS_FIELD, & + & SOURCE_CONTRIBS_FIELD + + USE YOMHOOK, ONLY: LHOOK, DR_HOOK, JPHOOK + + ! ---------------------------------------------------------------------- + + IMPLICIT NONE + INTERFACE + SUBROUTINE INCDATE (CDATE, ISHIFT) + USE parkind_wave, ONLY: jwim + INTEGER(KIND=JWIM), INTENT(IN) :: ISHIFT + CHARACTER(LEN=*), INTENT(INOUT) :: CDATE + END SUBROUTINE INCDATE + END INTERFACE + INTERFACE + SUBROUTINE NEWWIND (CDATE, CDATEWH, LLNEWFILE, WVPRPT, FF_NOW, FF_NEXT) + USE YOWDRVTYPE, ONLY: FREQUENCY, FORCING_FIELDS + CHARACTER(LEN=14), INTENT(IN) :: CDATE + CHARACTER(LEN=14), INTENT(INOUT) :: CDATEWH + LOGICAL, INTENT(INOUT) :: LLNEWFILE + TYPE(FREQUENCY), INTENT(INOUT) :: WVPRPT + TYPE(FORCING_FIELDS), INTENT(INOUT) :: FF_NOW + TYPE(FORCING_FIELDS), INTENT(IN) :: FF_NEXT + END SUBROUTINE NEWWIND + END INTERFACE + INTERFACE + SUBROUTINE PROPAG_WAM (BLK2GLO, WAVNUM, CGROUP, OMOSNH2KD, FL1, DEPTH, DELLAM1, COSPHM1, UCUR, VCUR) + USE parkind_wave, ONLY: jwrb + USE yowdrvtype, ONLY: wvgridglo + USE yowgrid, ONLY: nproma_wam, nchnk + USE yowparam, ONLY: nang, nfre + TYPE(WVGRIDGLO), INTENT(IN) :: BLK2GLO + REAL(KIND=JWRB), INTENT(INOUT), DIMENSION(NPROMA_WAM, NANG, NFRE, NCHNK) :: FL1 + REAL(KIND=JWRB), INTENT(IN), DIMENSION(NPROMA_WAM, NFRE, NCHNK) :: WAVNUM, CGROUP, OMOSNH2KD + REAL(KIND=JWRB), INTENT(IN), DIMENSION(NPROMA_WAM, NCHNK) :: DEPTH, DELLAM1, COSPHM1, UCUR, VCUR + END SUBROUTINE PROPAG_WAM + END INTERFACE + INTERFACE + FUNCTION WAM_USER_CLOCK () + USE parkind_wave, ONLY: jwru + REAL(KIND=JWRU) :: WAM_USER_CLOCK + END FUNCTION WAM_USER_CLOCK + END INTERFACE + INTEGER(KIND=JWIM), PARAMETER :: NANG_loki_param = 24 + INTEGER(KIND=JWIM), PARAMETER :: NFRE_loki_param = 36 + CHARACTER(LEN=14), INTENT(IN) :: CDTPRA ! DATE FOR CALL PROPAGATION + CHARACTER(LEN=14), INTENT(INOUT) :: CDATE ! CURRENT DATE + CHARACTER(LEN=14), INTENT(INOUT) :: CDATEWH ! DATE OF THE NEXT FORCING FIELDS + CHARACTER(LEN=14), INTENT(INOUT) :: CDTIMP ! START DATE OF SOURCE FUNCTION INTEGRATION + CHARACTER(LEN=14), INTENT(INOUT) :: CDTIMPNEXT ! NEXT START DATE OF SOURCE FUNCTION INTEGRATION + TYPE(WVGRIDGLO), INTENT(IN) :: BLK2GLO ! BLOCK TO GRID TRANSFORMATION + TYPE(ENVIRONMENT), INTENT(INOUT) :: WVENVI ! WAVE ENVIRONMENT FIELDS + TYPE(FREQUENCY), INTENT(INOUT) :: WVPRPT ! WAVE PROPERTIES FIELDS + TYPE(FORCING_FIELDS), INTENT(INOUT) :: FF_NOW ! FORCING FIELDS AT CURRENT TIME + TYPE(FORCING_FIELDS), INTENT(IN) :: FF_NEXT ! DATA STRUCTURE WITH THE NEXT FORCING FIELDS + TYPE(INTGT_PARAM_FIELDS), INTENT(INOUT) :: INTFLDS ! INTEGRATED/DERIVED PARAMETERS + TYPE(WAVE2OCEAN), INTENT(INOUT) :: WAM2NEMO ! WAVE FIELDS PASSED TO NEMO + INTEGER(KIND=JWIM), INTENT(INOUT) :: MIJ(NPROMA_WAM, NCHNK) ! LAST FREQUENCY INDEX OF THE PROGNOSTIC RANGE + REAL(KIND=JWRB), INTENT(INOUT) :: FL1(NPROMA_WAM, NANG_loki_param, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: XLLWS(NPROMA_WAM, NANG_loki_param, NFRE_loki_param, NCHNK) ! TOTAL WINDSEA MASK FROM INPUT SOURCE TERM + + REAL(KIND=JWRB), INTENT(INOUT) :: TIME1(3) + REAL(KIND=JWRB) :: TIME0, TIME2 + + + INTEGER(KIND=JWIM) :: IJ, K, M + INTEGER(KIND=JWIM) :: ICHNK + INTEGER(KIND=JWIM) :: IDELWH + + ! Objects to store fields + TYPE(FREQUENCY_FIELD) :: WVPRPT_FIELD + TYPE(ENVIRONMENT_FIELD) :: WVENVI_FIELD + TYPE(FORCING_FIELDS_FIELD) :: FF_NOW_FIELD + TYPE(WAVE2OCEAN_FIELD) :: WAM2NEMO_FIELD + TYPE(INTGT_PARAM_FIELDS_FIELD) :: INTFLDS_FIELD + TYPE(SOURCE_CONTRIBS_FIELD) :: SRC_CONTRIBS + + ! DEVICE POINTERS + REAL(KIND=JWRB), POINTER, CONTIGUOUS :: FL1_DPTR(:, :, :, :) => NULL() + REAL(KIND=JWRB), POINTER, CONTIGUOUS :: XLLWS_DPTR(:, :, :, :) => NULL() + INTEGER(KIND=JWIM), POINTER, CONTIGUOUS :: MIJ_DPTR(:, :) => NULL() + REAL(KIND=JWRB), POINTER, CONTIGUOUS :: WAVNUM_DPTR(:, :, :) => NULL() + REAL(KIND=JWRB), POINTER, CONTIGUOUS :: CGROUP_DPTR(:, :, :) => NULL() + REAL(KIND=JWRB), POINTER, CONTIGUOUS :: OMOSNH2KD_DPTR(:, :, :) => NULL() + REAL(KIND=JWRB), POINTER, CONTIGUOUS :: CIWA_DPTR(:, :, :) => NULL() + REAL(KIND=JWRB), POINTER, CONTIGUOUS :: CINV_DPTR(:, :, :) => NULL() + REAL(KIND=JWRB), POINTER, CONTIGUOUS :: XK2CG_DPTR(:, :, :) => NULL() + REAL(KIND=JWRB), POINTER, CONTIGUOUS :: STOKFAC_DPTR(:, :, :) => NULL() + REAL(KIND=JWRB), POINTER, CONTIGUOUS :: EMAXDPT_DPTR(:, :) => NULL() + INTEGER(KIND=JWIM), POINTER, CONTIGUOUS :: INDEP_DPTR(:, :) => NULL() + REAL(KIND=JWRB), POINTER, CONTIGUOUS :: DEPTH_DPTR(:, :) => NULL() + REAL(KIND=JWRB), POINTER, CONTIGUOUS :: DELLAM1_DPTR(:, :) => NULL() + REAL(KIND=JWRB), POINTER, CONTIGUOUS :: COSPHM1_DPTR(:, :) => NULL() + REAL(KIND=JWRB), POINTER, CONTIGUOUS :: UCUR_DPTR(:, :) => NULL() + REAL(KIND=JWRB), POINTER, CONTIGUOUS :: VCUR_DPTR(:, :) => NULL() + INTEGER(KIND=JWIM), POINTER, CONTIGUOUS :: IOBND_DPTR(:, :) => NULL() + INTEGER(KIND=JWIM), POINTER, CONTIGUOUS :: IODP_DPTR(:, :) => NULL() + REAL(KIND=JWRB), POINTER, CONTIGUOUS :: CICOVER_DPTR(:, :) => NULL() + REAL(KIND=JWRB), POINTER, CONTIGUOUS :: WSWAVE_DPTR(:, :) => NULL() + REAL(KIND=JWRB), POINTER, CONTIGUOUS :: WDWAVE_DPTR(:, :) => NULL() + REAL(KIND=JWRB), POINTER, CONTIGUOUS :: AIRD_DPTR(:, :) => NULL() + REAL(KIND=JWRB), POINTER, CONTIGUOUS :: WSTAR_DPTR(:, :) => NULL() + REAL(KIND=JWRB), POINTER, CONTIGUOUS :: UFRIC_DPTR(:, :) => NULL() + REAL(KIND=JWRB), POINTER, CONTIGUOUS :: TAUW_DPTR(:, :) => NULL() + REAL(KIND=JWRB), POINTER, CONTIGUOUS :: TAUWDIR_DPTR(:, :) => NULL() + REAL(KIND=JWRB), POINTER, CONTIGUOUS :: Z0M_DPTR(:, :) => NULL() + REAL(KIND=JWRB), POINTER, CONTIGUOUS :: Z0B_DPTR(:, :) => NULL() + REAL(KIND=JWRB), POINTER, CONTIGUOUS :: CHRNCK_DPTR(:, :) => NULL() + REAL(KIND=JWRB), POINTER, CONTIGUOUS :: CITHICK_DPTR(:, :) => NULL() + REAL(KIND=JWRB), POINTER, CONTIGUOUS :: NEMOUSTOKES_DPTR(:, :) => NULL() + REAL(KIND=JWRB), POINTER, CONTIGUOUS :: NEMOVSTOKES_DPTR(:, :) => NULL() + REAL(KIND=JWRB), POINTER, CONTIGUOUS :: NEMOSTRN_DPTR(:, :) => NULL() + REAL(KIND=JWRB), POINTER, CONTIGUOUS :: NPHIEPS_DPTR(:, :) => NULL() + REAL(KIND=JWRB), POINTER, CONTIGUOUS :: NTAUOC_DPTR(:, :) => NULL() + REAL(KIND=JWRB), POINTER, CONTIGUOUS :: NSWH_DPTR(:, :) => NULL() + REAL(KIND=JWRB), POINTER, CONTIGUOUS :: NMWP_DPTR(:, :) => NULL() + REAL(KIND=JWRB), POINTER, CONTIGUOUS :: NEMOTAUX_DPTR(:, :) => NULL() + REAL(KIND=JWRB), POINTER, CONTIGUOUS :: NEMOTAUY_DPTR(:, :) => NULL() + REAL(KIND=JWRB), POINTER, CONTIGUOUS :: NEMOWSWAVE_DPTR(:, :) => NULL() + REAL(KIND=JWRB), POINTER, CONTIGUOUS :: NEMOPHIF_DPTR(:, :) => NULL() + REAL(KIND=JWRB), POINTER, CONTIGUOUS :: WSEMEAN_DPTR(:, :) => NULL() + REAL(KIND=JWRB), POINTER, CONTIGUOUS :: WSFMEAN_DPTR(:, :) => NULL() + REAL(KIND=JWRB), POINTER, CONTIGUOUS :: USTOKES_DPTR(:, :) => NULL() + REAL(KIND=JWRB), POINTER, CONTIGUOUS :: VSTOKES_DPTR(:, :) => NULL() + REAL(KIND=JWRB), POINTER, CONTIGUOUS :: STRNMS_DPTR(:, :) => NULL() + REAL(KIND=JWRB), POINTER, CONTIGUOUS :: TAUXD_DPTR(:, :) => NULL() + REAL(KIND=JWRB), POINTER, CONTIGUOUS :: TAUYD_DPTR(:, :) => NULL() + REAL(KIND=JWRB), POINTER, CONTIGUOUS :: TAUOCXD_DPTR(:, :) => NULL() + REAL(KIND=JWRB), POINTER, CONTIGUOUS :: TAUOCYD_DPTR(:, :) => NULL() + REAL(KIND=JWRB), POINTER, CONTIGUOUS :: TAUOC_DPTR(:, :) => NULL() + REAL(KIND=JWRB), POINTER, CONTIGUOUS :: PHIOCD_DPTR(:, :) => NULL() + REAL(KIND=JWRB), POINTER, CONTIGUOUS :: PHIEPS_DPTR(:, :) => NULL() + REAL(KIND=JWRB), POINTER, CONTIGUOUS :: PHIAW_DPTR(:, :) => NULL() + + REAL(KIND=JPHOOK) :: ZHOOK_HANDLE + + + LOGICAL, SAVE :: LLNEWFILE + + DATA LLNEWFILE / .false. / + INTEGER :: istat + + ! Device arrays + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: AF11_d(:) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: C2OSQRTVG_GC_d(:) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: CM_GC_d(:) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: COFRM4_d(:) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: COSTH_d(:) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: CUMULW_d(:, :, :, :) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: DELKCC_GC_NS_d(:) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: DELKCC_OMXKM3_GC_d(:) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: DFIM_d(:) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: DFIMFR_d(:) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: DFIMFR2_d(:) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: DFIMOFR_d(:) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: DFIM_SIM_d(:) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: FKLAM_d(:) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: FKLAM1_d(:) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: FKLAP_d(:) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: FKLAP1_d(:) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: FLMAX_d(:) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: FR_d(:) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: FR5_d(:) + INTEGER(KIND=JWIM), ALLOCATABLE, DEVICE :: IKM_d(:) + INTEGER(KIND=JWIM), ALLOCATABLE, DEVICE :: IKM1_d(:) + INTEGER(KIND=JWIM), ALLOCATABLE, DEVICE :: IKP_d(:) + INTEGER(KIND=JWIM), ALLOCATABLE, DEVICE :: IKP1_d(:) + INTEGER(KIND=JWIM), ALLOCATABLE, DEVICE :: INDICESSAT_d(:, :) + INTEGER(KIND=JWIM), ALLOCATABLE, DEVICE :: INLCOEF_d(:, :) + INTEGER(KIND=JWIM), ALLOCATABLE, DEVICE :: K11W_d(:, :) + INTEGER(KIND=JWIM), ALLOCATABLE, DEVICE :: K1W_d(:, :) + INTEGER(KIND=JWIM), ALLOCATABLE, DEVICE :: K21W_d(:, :) + INTEGER(KIND=JWIM), ALLOCATABLE, DEVICE :: K2W_d(:, :) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: OM3GMKM_GC_d(:) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: OMEGA_GC_d(:) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: OMXKM3_GC_d(:) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: RHOWG_DFIM_d(:) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: RNLCOEF_d(:, :) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: SATWEIGHTS_d(:, :) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: SINTH_d(:) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: SWELLFT_d(:) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: TH_d(:) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: WTAUHF_d(:) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: XKMSQRTVGOC2_GC_d(:) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: XKM_GC_d(:) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: XK_GC_d(:) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: ZPIFR_d(:) + TYPE(dim3) :: GRIDDIM, BLOCKDIM + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: IMPLSCH_RAORW(:, :) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: IMPLSCH_EMEAN(:, :) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: IMPLSCH_FMEAN(:, :) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: IMPLSCH_HALP(:, :) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: IMPLSCH_EMEANWS(:, :) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: IMPLSCH_FMEANWS(:, :) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: IMPLSCH_F1MEAN(:, :) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: IMPLSCH_AKMEAN(:, :) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: IMPLSCH_XKMEAN(:, :) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: IMPLSCH_PHIWA(:, :) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: IMPLSCH_FLM(:, :, :) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: IMPLSCH_COSWDIF(:, :, :) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: IMPLSCH_SINWDIF2(:, :, :) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: IMPLSCH_RHOWGDFTH(:, :, :) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: IMPLSCH_FLD(:, :, :, :) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: IMPLSCH_SL(:, :, :, :) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: IMPLSCH_SPOS(:, :, :, :) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: IMPLSCH_CIREDUC(:, :, :, :) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: IMPLSCH_SSOURCE(:, :, :, :) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: SINFLX_RNFAC(:, :) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: SINFLX_TMP_EM(:, :) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: STRESSO_TAUHF(:, :) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: STRESSO_PHIHF(:, :) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: STRESSO_UST(:, :) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: SNONLIN_XNU(:, :) + REAL(KIND=JWRB), ALLOCATABLE, DEVICE :: SNONLIN_SIG_TH(:, :) + REAL(KIND=JWRB), DEVICE, ALLOCATABLE :: ENH(:,:,:) + + ! @! cuf print *, 'executing SCC-CUF type: hoist - host side hoisted local arrays' + + ALLOCATE(ENH(NPROMA_WAM, MLSTHG, NCHNK)) + ! Device array allocation + ALLOCATE (AF11_d, MOLD=AF11) + ALLOCATE (C2OSQRTVG_GC_d, MOLD=C2OSQRTVG_GC) + ALLOCATE (CM_GC_d, MOLD=CM_GC) + ALLOCATE (COFRM4_d, MOLD=COFRM4) + ALLOCATE (COSTH_d, MOLD=COSTH) + ALLOCATE (CUMULW_d, MOLD=CUMULW) + ALLOCATE (DELKCC_GC_NS_d, MOLD=DELKCC_GC_NS) + ALLOCATE (DELKCC_OMXKM3_GC_d, MOLD=DELKCC_OMXKM3_GC) + ALLOCATE (DFIM_d, MOLD=DFIM) + ALLOCATE (DFIMFR_d, MOLD=DFIMFR) + ALLOCATE (DFIMFR2_d, MOLD=DFIMFR2) + ALLOCATE (DFIMOFR_d, MOLD=DFIMOFR) + ALLOCATE (DFIM_SIM_d, MOLD=DFIM_SIM) + ALLOCATE (FKLAM_d, MOLD=FKLAM) + ALLOCATE (FKLAM1_d, MOLD=FKLAM1) + ALLOCATE (FKLAP_d, MOLD=FKLAP) + ALLOCATE (FKLAP1_d, MOLD=FKLAP1) + ALLOCATE (FLMAX_d, MOLD=FLMAX) + ALLOCATE (FR_d, MOLD=FR) + ALLOCATE (FR5_d, MOLD=FR5) + ALLOCATE (IKM_d, MOLD=IKM) + ALLOCATE (IKM1_d, MOLD=IKM1) + ALLOCATE (IKP_d, MOLD=IKP) + ALLOCATE (IKP1_d, MOLD=IKP1) + ALLOCATE (INDICESSAT_d, MOLD=INDICESSAT) + ALLOCATE (INLCOEF_d, MOLD=INLCOEF) + ALLOCATE (K11W_d, MOLD=K11W) + ALLOCATE (K1W_d, MOLD=K1W) + ALLOCATE (K21W_d, MOLD=K21W) + ALLOCATE (K2W_d, MOLD=K2W) + ALLOCATE (OM3GMKM_GC_d, MOLD=OM3GMKM_GC) + ALLOCATE (OMEGA_GC_d, MOLD=OMEGA_GC) + ALLOCATE (OMXKM3_GC_d, MOLD=OMXKM3_GC) + ALLOCATE (RHOWG_DFIM_d, MOLD=RHOWG_DFIM) + ALLOCATE (RNLCOEF_d, MOLD=RNLCOEF) + ALLOCATE (SATWEIGHTS_d, MOLD=SATWEIGHTS) + ALLOCATE (SINTH_d, MOLD=SINTH) + ALLOCATE (SWELLFT_d, MOLD=SWELLFT) + ALLOCATE (TH_d, MOLD=TH) + ALLOCATE (WTAUHF_d, MOLD=WTAUHF) + ALLOCATE (XKMSQRTVGOC2_GC_d, MOLD=XKMSQRTVGOC2_GC) + ALLOCATE (XKM_GC_d, MOLD=XKM_GC) + ALLOCATE (XK_GC_d, MOLD=XK_GC) + ALLOCATE (ZPIFR_d, MOLD=ZPIFR) + ALLOCATE (IMPLSCH_RAORW(NPROMA_WAM, NCHNK)) + ALLOCATE (IMPLSCH_EMEAN(NPROMA_WAM, NCHNK)) + ALLOCATE (IMPLSCH_FMEAN(NPROMA_WAM, NCHNK)) + ALLOCATE (IMPLSCH_HALP(NPROMA_WAM, NCHNK)) + ALLOCATE (IMPLSCH_EMEANWS(NPROMA_WAM, NCHNK)) + ALLOCATE (IMPLSCH_FMEANWS(NPROMA_WAM, NCHNK)) + ALLOCATE (IMPLSCH_F1MEAN(NPROMA_WAM, NCHNK)) + ALLOCATE (IMPLSCH_AKMEAN(NPROMA_WAM, NCHNK)) + ALLOCATE (IMPLSCH_XKMEAN(NPROMA_WAM, NCHNK)) + ALLOCATE (IMPLSCH_PHIWA(NPROMA_WAM, NCHNK)) + ALLOCATE (IMPLSCH_FLM(NPROMA_WAM, NANG_loki_param, NCHNK)) + ALLOCATE (IMPLSCH_COSWDIF(NPROMA_WAM, NANG_loki_param, NCHNK)) + ALLOCATE (IMPLSCH_SINWDIF2(NPROMA_WAM, NANG_loki_param, NCHNK)) + ALLOCATE (IMPLSCH_RHOWGDFTH(NPROMA_WAM, NFRE_loki_param, NCHNK)) + ALLOCATE (IMPLSCH_FLD(NPROMA_WAM, NANG_loki_param, NFRE_loki_param, NCHNK)) + ALLOCATE (IMPLSCH_SL(NPROMA_WAM, NANG_loki_param, NFRE_loki_param, NCHNK)) + ALLOCATE (IMPLSCH_SPOS(NPROMA_WAM, NANG_loki_param, NFRE_loki_param, NCHNK)) + ALLOCATE (IMPLSCH_CIREDUC(NPROMA_WAM, NANG_loki_param, NFRE_loki_param, NCHNK)) + ALLOCATE (IMPLSCH_SSOURCE(NPROMA_WAM, NANG_loki_param, NFRE_loki_param, NCHNK)) + ALLOCATE (SINFLX_RNFAC(NPROMA_WAM, NCHNK)) + ALLOCATE (SINFLX_TMP_EM(NPROMA_WAM, NCHNK)) + ALLOCATE (STRESSO_TAUHF(NPROMA_WAM, NCHNK)) + ALLOCATE (STRESSO_PHIHF(NPROMA_WAM, NCHNK)) + ALLOCATE (STRESSO_UST(NPROMA_WAM, NCHNK)) + ALLOCATE (SNONLIN_XNU(NPROMA_WAM, NCHNK)) + ALLOCATE (SNONLIN_SIG_TH(NPROMA_WAM, NCHNK)) + + ! Copy host to device + AF11_d = AF11 + C2OSQRTVG_GC_d = C2OSQRTVG_GC + CM_GC_d = CM_GC + COFRM4_d = COFRM4 + COSTH_d = COSTH + CUMULW_d = CUMULW + DELKCC_GC_NS_d = DELKCC_GC_NS + DELKCC_OMXKM3_GC_d = DELKCC_OMXKM3_GC + DFIM_d = DFIM + DFIMFR_d = DFIMFR + DFIMFR2_d = DFIMFR2 + DFIMOFR_d = DFIMOFR + DFIM_SIM_d = DFIM_SIM + FKLAM_d = FKLAM + FKLAM1_d = FKLAM1 + FKLAP_d = FKLAP + FKLAP1_d = FKLAP1 + FLMAX_d = FLMAX + FR_d = FR + FR5_d = FR5 + IKM_d = IKM + IKM1_d = IKM1 + IKP_d = IKP + IKP1_d = IKP1 + INDICESSAT_d = INDICESSAT + INLCOEF_d = INLCOEF + K11W_d = K11W + K1W_d = K1W + K21W_d = K21W + K2W_d = K2W + OM3GMKM_GC_d = OM3GMKM_GC + OMEGA_GC_d = OMEGA_GC + OMXKM3_GC_d = OMXKM3_GC + RHOWG_DFIM_d = RHOWG_DFIM + RNLCOEF_d = RNLCOEF + SATWEIGHTS_d = SATWEIGHTS + SINTH_d = SINTH + SWELLFT_d = SWELLFT + TH_d = TH + WTAUHF_d = WTAUHF + XKMSQRTVGOC2_GC_d = XKMSQRTVGOC2_GC + XKM_GC_d = XKM_GC + XK_GC_d = XK_GC + ZPIFR_d = ZPIFR + + ! ---------------------------------------------------------------------- + + IF (LHOOK) CALL DR_HOOK('WAMINTGR', 0, ZHOOK_HANDLE) + + !* PROPAGATION TIME + ! ---------------- + + CALL SRC_CONTRIBS%INIT(FL1=FL1(:, :, :, :)) + CALL SRC_CONTRIBS%UPDATE_DEVICE(FL1=FL1_DPTR) + CALL WVPRPT_FIELD%INIT(WAVNUM=WVPRPT%WAVNUM, CGROUP=WVPRPT%CGROUP, OMOSNH2KD=WVPRPT%OMOSNH2KD) + CALL WVPRPT_FIELD%UPDATE_DEVICE(WAVNUM=WAVNUM_DPTR, CGROUP=CGROUP_DPTR, OMOSNH2KD=OMOSNH2KD_DPTR) + CALL WVENVI_FIELD%INIT(DEPTH=WVENVI%DEPTH, DELLAM1=WVENVI%DELLAM1, COSPHM1=WVENVI%COSPHM1, UCUR=WVENVI%UCUR, VCUR=WVENVI%VCUR) + CALL WVENVI_FIELD%UPDATE_DEVICE(DEPTH=DEPTH_DPTR, DELLAM1=DELLAM1_DPTR, COSPHM1=COSPHM1_DPTR, UCUR=UCUR_DPTR, VCUR=VCUR_DPTR) +!$acc data present( FL1_DPTR, WAVNUM_DPTR, CGROUP_DPTR, OMOSNH2KD_DPTR, DEPTH_DPTR, DELLAM1_DPTR, COSPHM1_DPTR, UCUR_DPTR, & +!$acc & VCUR_DPTR ) + + IF (CDATE == CDTPRA) THEN + TIME0 = -WAM_USER_CLOCK() + CALL PROPAG_WAM(BLK2GLO, WAVNUM_DPTR(:, :, :), CGROUP_DPTR(:, :, :), OMOSNH2KD_DPTR(:, :, :), FL1_DPTR(:, :, :, :), & + & DEPTH_DPTR(:, :), DELLAM1_DPTR(:, :), COSPHM1_DPTR(:, :), UCUR_DPTR(:, :), VCUR_DPTR(:, :)) + TIME1(1) = TIME1(1) + (TIME0 + WAM_USER_CLOCK())*1.E-06 + CDATE = CDTPRO + END IF +!$acc end data + + !* RETRIEVING NEW FORCING FIELDS IF NEEDED. + ! ---------------------------------------- + CALL NEWWIND(CDTIMP, CDATEWH, LLNEWFILE, WVPRPT, FF_NOW, FF_NEXT) + + ! IT IS TIME TO INTEGRATE THE SOURCE TERMS + ! ---------------------------------------- + IF (CDATE >= CDTIMPNEXT) THEN + ! COMPUTE UPDATE DUE TO SOURCE TERMS + CALL GSTATS(1431, 0) + IF (LLSOURCE) THEN + + TIME2 = -WAM_USER_CLOCK() + CALL WVPRPT_FIELD%INIT(CIWA=WVPRPT%CIWA, CINV=WVPRPT%CINV, XK2CG=WVPRPT%XK2CG, STOKFAC=WVPRPT%STOKFAC) + CALL WVENVI_FIELD%INIT(EMAXDPT=WVENVI%EMAXDPT, INDEP=WVENVI%INDEP, IOBND=WVENVI%IOBND, IODP=WVENVI%IODP) + CALL FF_NOW_FIELD%INIT(AIRD=FF_NOW%AIRD, WDWAVE=FF_NOW%WDWAVE, CICOVER=FF_NOW%CICOVER, WSWAVE=FF_NOW%WSWAVE, & + & WSTAR=FF_NOW%WSTAR, UFRIC=FF_NOW%UFRIC, TAUW=FF_NOW%TAUW, TAUWDIR=FF_NOW%TAUWDIR, Z0M=FF_NOW%Z0M, Z0B=FF_NOW%Z0B, & + & CHRNCK=FF_NOW%CHRNCK, CITHICK=FF_NOW%CITHICK) + CALL WAM2NEMO_FIELD%INIT(NEMOUSTOKES=WAM2NEMO%NEMOUSTOKES, NEMOVSTOKES=WAM2NEMO%NEMOVSTOKES, NEMOSTRN=WAM2NEMO%NEMOSTRN, & + & NPHIEPS=WAM2NEMO%NPHIEPS, NTAUOC=WAM2NEMO%NTAUOC, NSWH=WAM2NEMO%NSWH, NMWP=WAM2NEMO%NMWP, NEMOTAUX=WAM2NEMO%NEMOTAUX, & + & NEMOTAUY=WAM2NEMO%NEMOTAUY, NEMOWSWAVE=WAM2NEMO%NEMOWSWAVE, NEMOPHIF=WAM2NEMO%NEMOPHIF) + CALL INTFLDS_FIELD%INIT(WSEMEAN=INTFLDS%WSEMEAN, WSFMEAN=INTFLDS%WSFMEAN, USTOKES=INTFLDS%USTOKES, & + & VSTOKES=INTFLDS%VSTOKES, STRNMS=INTFLDS%STRNMS, TAUXD=INTFLDS%TAUXD, TAUYD=INTFLDS%TAUYD, TAUOCXD=INTFLDS%TAUOCXD, & + & TAUOCYD=INTFLDS%TAUOCYD, TAUOC=INTFLDS%TAUOC, PHIOCD=INTFLDS%PHIOCD, PHIEPS=INTFLDS%PHIEPS, PHIAW=INTFLDS%PHIAW) + CALL SRC_CONTRIBS%INIT(XLLWS=XLLWS(:, :, :, :), MIJ=MIJ(:, :)) + +! ! $ acc update device( & +! ! $ acc & BETAMAXOXKAPPA2,FKLAP,FLOGSPRDM1,NANG,DELKCC_OMXKM3_GC,NFRE_RED,XKM_GC,SWELLFT,LWNEMOCOU,LLUNSTR,SATWEIGHTS,OM3GMKM_GC,DTHRN_U,LWFLUXOUT,ALPHAMIN,IKM1,CM_GC,COFRM4,DFIM,KFRH,CUMULW,G,C2OSQRTVG_GC,LWNEMOCOUSEND,WTAUHF,COSTH,NSDSNTH,CDICWA,K2W,LWVFLX_SNL,RNLCOEF,K21W,CITHRSH_TAIL,LLCAPCHNK,BMAXOKAP,EGRCRV,DFIM_SIM,FR,IKM,CDIS,MLSTHG,FLMAX,CITHRSH,DELTH,MFRSTLW,ZPI,ZALP,IKP1,TAUWSHELTER,INDICESSAT,RN1_RN,X0TAUHF,Z0RAT,LBIWBK,DFIMOFR,DAL2,ZPIFR,CHNKMIN_U,LLGCBZ0,ANG_GC_B,LICERUN,IKP,ZPI4GM1,INLCOEF,ISNONLIN,LWAMRSETCI,DTHRN_A,NFRE_ODD,TAILFACTOR_PM,AFCRV,CIBLOCK,LWNEMOTAUOC,ALPHAPMAX,OMXKM3_GC,OMEGA_GC,AF11,XKMSQRTVGOC2_GC,LWCOU,TAILFACTOR,ANG_GC_C,K1W,IDELT,FR5,NFRE,DAL1,WSPMIN,LWNEMOCOUSTK,ICODE,ICODE_CPL,SQRTGOSURFT,SWELLF5,LLNORMAGAM,Z0TUBMAX,ZPI4GM2,LCIWABR,DELTA_SDIS,RNUM,ANG_GC_A,SINTH,LWFLUX,FKLAM1,ALPHA,LMASKICE,DFIMFR2,XK_GC,GAMNCONST,BFCRV,FKLAM,RHOWG_DFIM,TH,LWNEMOCOUSTRN,NDEPTH,NWAV_GC,FKLAP1,CDISVIS,RNU,DELKCC_GC_NS,IPHYS,GM1,NDIKCUMUL,DFIMFR,IDAMPING,K11W & +! ! $ !acc & ) + + CALL WVPRPT_FIELD%UPDATE_DEVICE(CIWA=CIWA_DPTR, CINV=CINV_DPTR, XK2CG=XK2CG_DPTR, STOKFAC=STOKFAC_DPTR) + CALL WVENVI_FIELD%UPDATE_DEVICE(EMAXDPT=EMAXDPT_DPTR, INDEP=INDEP_DPTR, IOBND=IOBND_DPTR, IODP=IODP_DPTR) + CALL FF_NOW_FIELD%UPDATE_DEVICE(AIRD=AIRD_DPTR, WDWAVE=WDWAVE_DPTR, CICOVER=CICOVER_DPTR, WSWAVE=WSWAVE_DPTR, & + & WSTAR=WSTAR_DPTR, UFRIC=UFRIC_DPTR, TAUW=TAUW_DPTR, TAUWDIR=TAUWDIR_DPTR, Z0M=Z0M_DPTR, Z0B=Z0B_DPTR, & + & CHRNCK=CHRNCK_DPTR, CITHICK=CITHICK_DPTR) + CALL WAM2NEMO_FIELD%UPDATE_DEVICE(NEMOUSTOKES=NEMOUSTOKES_DPTR, NEMOVSTOKES=NEMOVSTOKES_DPTR, NEMOSTRN=NEMOSTRN_DPTR, & + & NPHIEPS=NPHIEPS_DPTR, NTAUOC=NTAUOC_DPTR, NSWH=NSWH_DPTR, NMWP=NMWP_DPTR, NEMOTAUX=NEMOTAUX_DPTR, & + & NEMOTAUY=NEMOTAUY_DPTR, NEMOWSWAVE=NEMOWSWAVE_DPTR, NEMOPHIF=NEMOPHIF_DPTR) + CALL INTFLDS_FIELD%UPDATE_DEVICE(WSEMEAN=WSEMEAN_DPTR, WSFMEAN=WSFMEAN_DPTR, USTOKES=USTOKES_DPTR, VSTOKES=VSTOKES_DPTR, & + & STRNMS=STRNMS_DPTR, TAUXD=TAUXD_DPTR, TAUYD=TAUYD_DPTR, TAUOCXD=TAUOCXD_DPTR, TAUOCYD=TAUOCYD_DPTR, TAUOC=TAUOC_DPTR, & + & PHIOCD=PHIOCD_DPTR, PHIEPS=PHIEPS_DPTR, PHIAW=PHIAW_DPTR) + CALL SRC_CONTRIBS%UPDATE_DEVICE(XLLWS=XLLWS_DPTR, MIJ=MIJ_DPTR) + +!$acc data present( FL1_DPTR,XLLWS_DPTR,MIJ_DPTR,WAVNUM_DPTR,CGROUP_DPTR,CIWA_DPTR,CINV_DPTR,XK2CG_DPTR,STOKFAC_DPTR, & +!$acc & EMAXDPT_DPTR,INDEP_DPTR,DEPTH_DPTR,IOBND_DPTR,IODP_DPTR,CICOVER_DPTR,WSWAVE_DPTR,WDWAVE_DPTR,AIRD_DPTR, & +!$acc & WSTAR_DPTR,UFRIC_DPTR,TAUW_DPTR,TAUWDIR_DPTR,Z0M_DPTR,Z0B_DPTR,CHRNCK_DPTR,CITHICK_DPTR,NEMOUSTOKES_DPTR, & +!$acc & NEMOVSTOKES_DPTR,NEMOSTRN_DPTR,NPHIEPS_DPTR,NTAUOC_DPTR,NSWH_DPTR,NMWP_DPTR,NEMOTAUX_DPTR,NEMOTAUY_DPTR, & +!$acc & NEMOWSWAVE_DPTR,NEMOPHIF_DPTR,WSEMEAN_DPTR,WSFMEAN_DPTR,USTOKES_DPTR,VSTOKES_DPTR,STRNMS_DPTR,TAUXD_DPTR, & +!$acc & TAUYD_DPTR,TAUOCXD_DPTR,TAUOCYD_DPTR,TAUOC_DPTR,PHIOCD_DPTR,PHIEPS_DPTR,PHIAW_DPTR ) + TIME0 = -WAM_USER_CLOCK() + +!$loki start removed loop + + BLOCKDIM = DIM3(NPROMA_WAM, 1, 1) + GRIDDIM = DIM3(1, 1, NCHNK) +!$acc host_data use_device( FL1_DPTR, WAVNUM_DPTR, CGROUP_DPTR, CIWA_DPTR, CINV_DPTR, XK2CG_DPTR, STOKFAC_DPTR, EMAXDPT_DPTR, & +!$acc & INDEP_DPTR, DEPTH_DPTR, IOBND_DPTR, IODP_DPTR, AIRD_DPTR, WDWAVE_DPTR, CICOVER_DPTR, WSWAVE_DPTR, WSTAR_DPTR, & +!$acc & UFRIC_DPTR, TAUW_DPTR, TAUWDIR_DPTR, Z0M_DPTR, Z0B_DPTR, CHRNCK_DPTR, CITHICK_DPTR, NEMOUSTOKES_DPTR, NEMOVSTOKES_DPTR, & +!$acc & NEMOSTRN_DPTR, NPHIEPS_DPTR, NTAUOC_DPTR, NSWH_DPTR, NMWP_DPTR, NEMOTAUX_DPTR, NEMOTAUY_DPTR, NEMOWSWAVE_DPTR, & +!$acc & NEMOPHIF_DPTR, WSEMEAN_DPTR, WSFMEAN_DPTR, USTOKES_DPTR, VSTOKES_DPTR, STRNMS_DPTR, TAUXD_DPTR, TAUYD_DPTR, & +!$acc & TAUOCXD_DPTR, TAUOCYD_DPTR, TAUOC_DPTR, PHIOCD_DPTR, PHIEPS_DPTR, PHIAW_DPTR, MIJ_DPTR, XLLWS_DPTR ) + + CALL IMPLSCH_CUF_HOIST_NEW<<>>(1, NPROMA_WAM, FL1_DPTR(:, :, :, :), WAVNUM_DPTR(:, :, :), & + & CGROUP_DPTR(:, :, :), CIWA_DPTR(:, :, :), CINV_DPTR(:, :, :), XK2CG_DPTR(:, :, :), STOKFAC_DPTR(:, :, :), & + & EMAXDPT_DPTR(:, :), INDEP_DPTR(:, :), DEPTH_DPTR(:, :), IOBND_DPTR(:, :), IODP_DPTR(:, :), AIRD_DPTR(:, :), & + & WDWAVE_DPTR(:, :), CICOVER_DPTR(:, :), WSWAVE_DPTR(:, :), WSTAR_DPTR(:, :), UFRIC_DPTR(:, :), TAUW_DPTR(:, :), & + & TAUWDIR_DPTR(:, :), Z0M_DPTR(:, :), Z0B_DPTR(:, :), CHRNCK_DPTR(:, :), CITHICK_DPTR(:, :), NEMOUSTOKES_DPTR(:, :), & + & NEMOVSTOKES_DPTR(:, :), NEMOSTRN_DPTR(:, :), NPHIEPS_DPTR(:, :), NTAUOC_DPTR(:, :), NSWH_DPTR(:, :), NMWP_DPTR(:, :), & + & NEMOTAUX_DPTR(:, :), NEMOTAUY_DPTR(:, :), NEMOWSWAVE_DPTR(:, :), NEMOPHIF_DPTR(:, :), WSEMEAN_DPTR(:, :), & + & WSFMEAN_DPTR(:, :), USTOKES_DPTR(:, :), VSTOKES_DPTR(:, :), STRNMS_DPTR(:, :), TAUXD_DPTR(:, :), TAUYD_DPTR(:, :), & + & TAUOCXD_DPTR(:, :), TAUOCYD_DPTR(:, :), TAUOC_DPTR(:, :), PHIOCD_DPTR(:, :), PHIEPS_DPTR(:, :), PHIAW_DPTR(:, :), & + & MIJ_DPTR(:, :), XLLWS_DPTR(:, :, :, :), ABMAX, ABMIN, ACD, ACDLIN, AF11_d, AFCRV, ALPHA, ALPHAMAX, ALPHAMIN, ALPHAPMAX, & + & ANG_GC_A, ANG_GC_B, ANG_GC_C, BATHYMAX, BCD, BCDLIN, BETAMAXOXKAPPA2, BFCRV, BMAXOKAP, C2OSQRTVG_GC_d, CDICWA, CDIS, & + & CDISVIS, CDMAX, CHNKMIN_U, CIBLOCK, CITHRSH, CITHRSH_TAIL, CM_GC_d, COFRM4_d, COSTH_d, CUMULW_d, DAL1, DAL2, & + & DELKCC_GC_NS_d, DELKCC_OMXKM3_GC_d, DELTA_SDIS, DELTH, DFIM_d, DFIMFR_d, DFIMFR2_d, DFIMOFR_d, DFIM_SIM_d, DKMAX, & + & DTHRN_A, DTHRN_U, EGRCRV, EPS1, EPSMIN, EPSU10, EPSUS, FKLAM_d, FKLAM1_d, FKLAP_d, FKLAP1_d, FLMAX_d, FLMIN, FLOGSPRDM1, & + & FR_d, FR5_d, FRATIO, FRIC, FRTAIL, G, GAMNCONST, GM1, IAB, ICODE, ICODE_CPL, IDAMPING, IDELT, IKM_d, IKM1_d, IKP_d, & + & IKP1_d, INDICESSAT_d, INLCOEF_d, IPHYS, IPSAT, ISNONLIN, JTOT_TAUHF, K11W_d, K1W_d, K21W_d, K2W_d, KFRH, LBIWBK, & + & LCIWABR, LICERUN, LLCAPCHNK, LLGCBZ0, LLNORMAGAM, LLUNSTR, LMASKICE, LWAMRSETCI, LWCOU, LWFLUX, LWFLUXOUT, LWNEMOCOU, & + & LWNEMOCOUSEND, LWNEMOCOUSTK, LWNEMOCOUSTRN, LWNEMOTAUOC, LWVFLX_SNL, MFRSTLW, MICHE, MLSTHG, NANG, NDEPTH, NDIKCUMUL, & + & NFRE, NFRE_ODD, NFRE_RED, NSDSNTH, NWAV_GC, OM3GMKM_GC_d, OMEGA_GC_d, OMXKM3_GC_d, PHIEPSMAX, PHIEPSMIN, RHOWG_DFIM_d, & + & RN1_RN, RNLCOEF_d, RNU, RNUM, ROWATER, ROWATERM1, SATWEIGHTS_d, SDSBR, SINTH_d, SQRTGOSURFT, SSDSC2, SSDSC3, SSDSC4, & + & SSDSC5, SSDSC6, SWELLF, SWELLF2, SWELLF3, SWELLF4, SWELLF5, SWELLF6, SWELLF7, SWELLF7M1, SWELLFT_d, TAILFACTOR, & + & TAILFACTOR_PM, TAUOCMAX, TAUOCMIN, TAUWSHELTER, TH_d, WETAIL, WP1TAIL, WP2TAIL, WSEMEAN_MIN, WSPMIN, WTAUHF_d, X0TAUHF, & + & XKAPPA, XKDMIN, XKMSQRTVGOC2_GC_d, XKM_GC_d, XK_GC_d, XLOGKRATIOM1_GC, XNLEV, Z0RAT, Z0TUBMAX, ZALP, ZPI, ZPI4GM1, & + & ZPI4GM2, ZPIFR_d, 1, NCHNK, 1, NCHNK, RAORW=IMPLSCH_RAORW, EMEAN=IMPLSCH_EMEAN, FMEAN=IMPLSCH_FMEAN, HALP=IMPLSCH_HALP, & + & EMEANWS=IMPLSCH_EMEANWS, FMEANWS=IMPLSCH_FMEANWS, F1MEAN=IMPLSCH_F1MEAN, AKMEAN=IMPLSCH_AKMEAN, XKMEAN=IMPLSCH_XKMEAN, & + & PHIWA=IMPLSCH_PHIWA, FLM=IMPLSCH_FLM, COSWDIF=IMPLSCH_COSWDIF, SINWDIF2=IMPLSCH_SINWDIF2, RHOWGDFTH=IMPLSCH_RHOWGDFTH, & + & FLD=IMPLSCH_FLD, SL=IMPLSCH_SL, SPOS=IMPLSCH_SPOS, CIREDUC=IMPLSCH_CIREDUC, SSOURCE=IMPLSCH_SSOURCE, & + & SINFLX_RNFAC=SINFLX_RNFAC, SINFLX_TMP_EM=SINFLX_TMP_EM, STRESSO_TAUHF=STRESSO_TAUHF, STRESSO_PHIHF=STRESSO_PHIHF, & + & STRESSO_UST=STRESSO_UST, SNONLIN_XNU=SNONLIN_XNU, SNONLIN_SIG_TH=SNONLIN_SIG_TH, ENH=ENH) + istat = cudaDeviceSynchronize() + + ! print *, "finished call to implsch ..." +!$acc end host_data + +!$loki end removed loop + + TIME1(2) = TIME1(2) + (TIME0 + WAM_USER_CLOCK())*1.E-06 +!$acc end data + CALL WVPRPT_FIELD%ENSURE_HOST() + CALL WVENVI_FIELD%ENSURE_HOST() + CALL FF_NOW_FIELD%ENSURE_HOST() + CALL WAM2NEMO_FIELD%ENSURE_HOST() + CALL INTFLDS_FIELD%ENSURE_HOST() + CALL SRC_CONTRIBS%ENSURE_HOST() + + CALL WVPRPT_FIELD%FINAL() + CALL WVENVI_FIELD%FINAL() + CALL FF_NOW_FIELD%FINAL() + CALL WAM2NEMO_FIELD%FINAL() + CALL INTFLDS_FIELD%FINAL() + CALL SRC_CONTRIBS%FINAL() + TIME1(3) = TIME1(3) + (TIME2 + WAM_USER_CLOCK())*1.E-06 + + IF (LWNEMOCOU) NEMONTAU = NEMONTAU + 1 + + ELSE + ! NO SOURCE TERM CONTRIBUTION +!$OMP PARALLEL DO SCHEDULE( STATIC ) PRIVATE( ICHNK ) + DO ICHNK=1,NCHNK + MIJ(:, ICHNK) = NFRE + FL1(:, :, :, ICHNK) = MAX(FL1(:, :, :, ICHNK), EPSMIN) + XLLWS(:, :, :, ICHNK) = 0.0_JWRB + END DO +!$OMP END PARALLEL DO + END IF + CALL GSTATS(1431, 1) + + + !* UPDATE FORCING FIELDS TIME COUNTER + ! ---------------------------------- + IF (LLNEWFILE) THEN + LLNEWFILE = .false. + IDELWH = MAX(IDELWI, IDELPRO) + CALL INCDATE(CDAWIFL, IDELWH) + CALL INCDATE(CDATEFL, IDELWH) + END IF + + CDATEWO = CDATEWH + CDTIMP = CDTIMPNEXT + CALL INCDATE(CDTIMPNEXT, IDELT) + + END IF + + IF (LHOOK) CALL DR_HOOK('WAMINTGR', 1, ZHOOK_HANDLE) + + + ! Copy device to host + ZPIFR = ZPIFR_d + XK_GC = XK_GC_d + XKM_GC = XKM_GC_d + XKMSQRTVGOC2_GC = XKMSQRTVGOC2_GC_d + WTAUHF = WTAUHF_d + TH = TH_d + SWELLFT = SWELLFT_d + SINTH = SINTH_d + SATWEIGHTS = SATWEIGHTS_d + RNLCOEF = RNLCOEF_d + RHOWG_DFIM = RHOWG_DFIM_d + OMXKM3_GC = OMXKM3_GC_d + OMEGA_GC = OMEGA_GC_d + OM3GMKM_GC = OM3GMKM_GC_d + K2W = K2W_d + K21W = K21W_d + K1W = K1W_d + K11W = K11W_d + INLCOEF = INLCOEF_d + INDICESSAT = INDICESSAT_d + IKP1 = IKP1_d + IKP = IKP_d + IKM1 = IKM1_d + IKM = IKM_d + FR5 = FR5_d + FR = FR_d + FLMAX = FLMAX_d + FKLAP1 = FKLAP1_d + FKLAP = FKLAP_d + FKLAM1 = FKLAM1_d + FKLAM = FKLAM_d + DFIM_SIM = DFIM_SIM_d + DFIMOFR = DFIMOFR_d + DFIMFR2 = DFIMFR2_d + DFIMFR = DFIMFR_d + DFIM = DFIM_d + DELKCC_OMXKM3_GC = DELKCC_OMXKM3_GC_d + DELKCC_GC_NS = DELKCC_GC_NS_d + CUMULW = CUMULW_d + COSTH = COSTH_d + COFRM4 = COFRM4_d + CM_GC = CM_GC_d + C2OSQRTVG_GC = C2OSQRTVG_GC_d + AF11 = AF11_d + + ! De-allocation + DEALLOCATE (AF11_d) + DEALLOCATE (C2OSQRTVG_GC_d) + DEALLOCATE (CM_GC_d) + DEALLOCATE (COFRM4_d) + DEALLOCATE (COSTH_d) + DEALLOCATE (CUMULW_d) + DEALLOCATE (DELKCC_GC_NS_d) + DEALLOCATE (DELKCC_OMXKM3_GC_d) + DEALLOCATE (DFIM_d) + DEALLOCATE (DFIMFR_d) + DEALLOCATE (DFIMFR2_d) + DEALLOCATE (DFIMOFR_d) + DEALLOCATE (DFIM_SIM_d) + DEALLOCATE (FKLAM_d) + DEALLOCATE (FKLAM1_d) + DEALLOCATE (FKLAP_d) + DEALLOCATE (FKLAP1_d) + DEALLOCATE (FLMAX_d) + DEALLOCATE (FR_d) + DEALLOCATE (FR5_d) + DEALLOCATE (IKM_d) + DEALLOCATE (IKM1_d) + DEALLOCATE (IKP_d) + DEALLOCATE (IKP1_d) + DEALLOCATE (INDICESSAT_d) + DEALLOCATE (INLCOEF_d) + DEALLOCATE (K11W_d) + DEALLOCATE (K1W_d) + DEALLOCATE (K21W_d) + DEALLOCATE (K2W_d) + DEALLOCATE (OM3GMKM_GC_d) + DEALLOCATE (OMEGA_GC_d) + DEALLOCATE (OMXKM3_GC_d) + DEALLOCATE (RHOWG_DFIM_d) + DEALLOCATE (RNLCOEF_d) + DEALLOCATE (SATWEIGHTS_d) + DEALLOCATE (SINTH_d) + DEALLOCATE (SWELLFT_d) + DEALLOCATE (TH_d) + DEALLOCATE (WTAUHF_d) + DEALLOCATE (XKMSQRTVGOC2_GC_d) + DEALLOCATE (XKM_GC_d) + DEALLOCATE (XK_GC_d) + DEALLOCATE (ZPIFR_d) + DEALLOCATE (IMPLSCH_RAORW) + DEALLOCATE (IMPLSCH_EMEAN) + DEALLOCATE (IMPLSCH_FMEAN) + DEALLOCATE (IMPLSCH_HALP) + DEALLOCATE (IMPLSCH_EMEANWS) + DEALLOCATE (IMPLSCH_FMEANWS) + DEALLOCATE (IMPLSCH_F1MEAN) + DEALLOCATE (IMPLSCH_AKMEAN) + DEALLOCATE (IMPLSCH_XKMEAN) + DEALLOCATE (IMPLSCH_PHIWA) + DEALLOCATE (IMPLSCH_FLM) + DEALLOCATE (IMPLSCH_COSWDIF) + DEALLOCATE (IMPLSCH_SINWDIF2) + DEALLOCATE (IMPLSCH_RHOWGDFTH) + DEALLOCATE (IMPLSCH_FLD) + DEALLOCATE (IMPLSCH_SL) + DEALLOCATE (IMPLSCH_SPOS) + DEALLOCATE (IMPLSCH_CIREDUC) + DEALLOCATE (IMPLSCH_SSOURCE) + DEALLOCATE (SINFLX_RNFAC) + DEALLOCATE (SINFLX_TMP_EM) + DEALLOCATE (STRESSO_TAUHF) + DEALLOCATE (STRESSO_PHIHF) + DEALLOCATE (STRESSO_UST) + DEALLOCATE (SNONLIN_XNU) + DEALLOCATE (SNONLIN_SIG_TH) + DEALLOCATE (ENH) +END SUBROUTINE WAMINTGR_LOKI_GPU diff --git a/src/phys-scc-cuf-hoist/wnfluxes.cuf_hoist_new.F90 b/src/phys-scc-cuf-hoist/wnfluxes.cuf_hoist_new.F90 new file mode 100644 index 00000000..3de3d314 --- /dev/null +++ b/src/phys-scc-cuf-hoist/wnfluxes.cuf_hoist_new.F90 @@ -0,0 +1,293 @@ +! (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. +! +MODULE WNFLUXES_CUF_HOIST_NEW_MOD + CONTAINS + ATTRIBUTES(DEVICE) SUBROUTINE WNFLUXES_CUF_HOIST_NEW (KIJS, KIJL, MIJ, RHOWGDFTH, CINV, SSURF, CICOVER, PHIWA, EM, F1, WSWAVE, & + & WDWAVE, UFRIC, AIRD, NPHIEPS, NTAUOC, NSWH, NMWP, NEMOTAUX, NEMOTAUY, NEMOWSWAVE, NEMOPHIF, TAUXD, TAUYD, TAUOCXD, TAUOCYD, & + & TAUOC, PHIOCD, PHIEPS, PHIAW, LNUPD, AFCRV, BFCRV, CIBLOCK, CITHRSH, COSTH, EGRCRV, EPSU10, EPSUS, FR, G, LICERUN, & + & LWAMRSETCI, LWNEMOCOU, LWNEMOTAUOC, NANG, NFRE, PHIEPSMAX, PHIEPSMIN, SINTH, TAUOCMAX, TAUOCMIN, ICHNK, NCHNK, IJ) + + ! ---------------------------------------------------------------------- + + !**** *WNFLUXES* - WAVE FLUXES CALCULATION + + !* PURPOSE. + ! -------- + + !** INTERFACE. + ! ---------- + + ! *CALL* *WNFLUXES* (KIJS, KIJL, + ! & MIJ, RHOWGDFTH, + ! & CINV, + ! & SSURF, CICOVER, + ! & PHIWA, + ! & EM, F1, WSWAVE, WDWAVE, + ! & UFRIC, AIRD, INTFLDS, WAM2NEMO, + ! & LNUPD) + ! *KIJS* - INDEX OF FIRST GRIDPOINT. + ! *KIJL* - INDEX OF LAST GRIDPOINT. + ! *MIJ* - LAST FREQUENCY INDEX OF THE PROGNOSTIC RANGE + ! *RHOWGDFTH - WATER DENSITY * G * DF * DTHETA + ! FOR TRAPEZOIDAL INTEGRATION BETWEEN FR(1) and FR(MIJ) + ! !!!!!!!! RHOWGDFTH=0 FOR FR > FR(MIJ) + ! *CINV* - INVERSE PHASE SPEED. + ! *SSURF* - CONTRIBUTION OF ALL SOURCE TERMS ACTING ON + ! THE SURFACE MOMENTUM AND ENERGY FLUXES. + ! *CICOVER*- SEA ICE COVER. + ! *PHIWA* - ENERGY FLUX FROM WIND INTO WAVES INTEGRATED + ! OVER THE FULL FREQUENCY RANGE. + ! *EM* - MEAN WAVE VARIANCE. + ! *F1* - MEAN WAVE FREQUENCY BASED ON f*F INTEGRATION. + ! *WSWAVE* - WIND SPEED IN M/S. + ! *WDWAVE* - WIND DIRECTION IN RADIANS IN OCEANOGRAPHIC CONVENTION + ! *UFRIC* - FRICTION VELOCITY IN M/S. + ! *AIRD* - AIR DENSITY IN KG/M3. + ! *INTFLDS*- INTEGRATED/DERIVED PARAMETERS + ! WAM2NEMO*- WAVE FIELDS PASSED TO NEMO + ! *LNUPD* - UPDATE NEMO FIELDS. + + ! ---------------------------------------------------------------------- + + USE cudafor + USE PARKIND_WAVE, ONLY: JWIM, JWRU, JWRO, JWRB + USE YOWDRVTYPE, ONLY: INTGT_PARAM_FIELDS, FORCING_FIELDS, WAVE2OCEAN + + + USE YOWPCONS, ONLY: ZPI + + + ! ---------------------------------------------------------------------- + + IMPLICIT NONE + + INTEGER(KIND=JWIM), PARAMETER :: NFRE_loki_param = 36 + INTEGER(KIND=JWIM), PARAMETER :: NANG_loki_param = 24 + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJS + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJL + INTEGER(KIND=JWIM), INTENT(IN) :: MIJ(KIJL, NCHNK) + + REAL(KIND=JWRB), INTENT(IN) :: RHOWGDFTH(KIJL, NFRE_loki_param) + REAL(KIND=JWRB), INTENT(IN) :: CINV(KIJL, NFRE_loki_param, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: SSURF(KIJL, NANG_loki_param, NFRE_loki_param) + REAL(KIND=JWRB), INTENT(IN) :: CICOVER(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: PHIWA(KIJL) + REAL(KIND=JWRB), INTENT(IN) :: EM(KIJL) + REAL(KIND=JWRB), INTENT(IN) :: F1(KIJL) + REAL(KIND=JWRB), INTENT(IN) :: WSWAVE(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: WDWAVE(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: UFRIC(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: AIRD(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: TAUXD(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: TAUYD(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: TAUOCXD(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: TAUOCYD(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: TAUOC(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: PHIOCD(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: PHIEPS(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(INOUT) :: PHIAW(KIJL, NCHNK) + REAL(KIND=JWRO), INTENT(INOUT) :: NPHIEPS(KIJL, NCHNK) + REAL(KIND=JWRO), INTENT(INOUT) :: NTAUOC(KIJL, NCHNK) + REAL(KIND=JWRO), INTENT(INOUT) :: NSWH(KIJL, NCHNK) + REAL(KIND=JWRO), INTENT(INOUT) :: NMWP(KIJL, NCHNK) + REAL(KIND=JWRO), INTENT(INOUT) :: NEMOTAUX(KIJL, NCHNK) + REAL(KIND=JWRO), INTENT(INOUT) :: NEMOTAUY(KIJL, NCHNK) + REAL(KIND=JWRO), INTENT(INOUT) :: NEMOWSWAVE(KIJL, NCHNK) + REAL(KIND=JWRO), INTENT(INOUT) :: NEMOPHIF(KIJL, NCHNK) + LOGICAL, VALUE, INTENT(IN) :: LNUPD + + + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: IJ + INTEGER(KIND=JWIM) :: K + INTEGER(KIND=JWIM) :: M + + ! FICTITIOUS VALUE OF THE NORMALISED WAVE ENERGY FLUX UNDER THE SEA ICE + ! (negative because it is defined as leaving the waves) + REAL(KIND=JWRB), PARAMETER :: PHIOC_ICE = -3.75_JWRB + REAL(KIND=JWRB), PARAMETER :: PHIAW_ICE = 3.75_JWRB + + ! USE HERSBACH 2011 FOR CD(U10) (SEE ALSO EDSON et al. 2013) + REAL(KIND=JWRB), PARAMETER :: C1 = 1.03E-3_JWRB + REAL(KIND=JWRB), PARAMETER :: C2 = 0.04E-3_JWRB + REAL(KIND=JWRB), PARAMETER :: P1 = 1.48_JWRB + REAL(KIND=JWRB), PARAMETER :: P2 = -0.21_JWRB + REAL(KIND=JWRB), PARAMETER :: CDMAX = 0.003_JWRB + + REAL(KIND=JWRB), PARAMETER :: EFD_MIN = 0.0625_JWRB ! corresponds to min Hs=1m under sea ice + REAL(KIND=JWRB), PARAMETER :: EFD_MAX = 6.25_JWRB ! corresponds to max Hs=10m under sea ice + + REAL(KIND=JWRB) :: TAU + REAL(KIND=JWRB) :: XN + REAL(KIND=JWRB) :: TAUO + REAL(KIND=JWRB) :: U10P + REAL(KIND=JWRB) :: CD_BULK + REAL(KIND=JWRB) :: CD_WAVE + REAL(KIND=JWRB) :: CD_ICE + REAL(KIND=JWRB) :: CNST + REAL(KIND=JWRB) :: EPSUS3 + REAL(KIND=JWRB) :: CITHRSH_INV + REAL(KIND=JWRB) :: EFD + REAL(KIND=JWRB) :: FFD + REAL(KIND=JWRB) :: EFD_FAC + REAL(KIND=JWRB) :: FFD_FAC + + REAL(KIND=JWRB) :: XSTRESS + REAL(KIND=JWRB) :: YSTRESS + REAL(KIND=JWRB) :: USTAR + REAL(KIND=JWRB) :: PHILF + REAL(KIND=JWRB) :: OOVAL + REAL(KIND=JWRB) :: EM_OC + REAL(KIND=JWRB) :: F1_OC + REAL(KIND=JWRB) :: CMRHOWGDFTH + REAL(KIND=JWRB) :: SUMT + REAL(KIND=JWRB) :: SUMX + REAL(KIND=JWRB) :: SUMY + REAL(KIND=JWRB), VALUE, INTENT(IN) :: AFCRV + REAL(KIND=JWRB), VALUE, INTENT(IN) :: BFCRV + REAL(KIND=JWRB), VALUE, INTENT(IN) :: CIBLOCK + REAL(KIND=JWRB), VALUE, INTENT(IN) :: CITHRSH + REAL(KIND=JWRB), INTENT(IN), DEVICE :: COSTH(NFRE_loki_param) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: EGRCRV + REAL(KIND=JWRB), VALUE, INTENT(IN) :: EPSU10 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: EPSUS + REAL(KIND=JWRB), INTENT(IN), DEVICE :: FR(NFRE_loki_param) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: G + LOGICAL, VALUE, INTENT(IN) :: LICERUN + LOGICAL, VALUE, INTENT(IN) :: LWAMRSETCI + LOGICAL, VALUE, INTENT(IN) :: LWNEMOCOU + LOGICAL, VALUE, INTENT(IN) :: LWNEMOTAUOC + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NANG + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: NFRE + REAL(KIND=JWRB), VALUE, INTENT(IN) :: PHIEPSMAX + REAL(KIND=JWRB), VALUE, INTENT(IN) :: PHIEPSMIN + REAL(KIND=JWRB), INTENT(IN), DEVICE :: SINTH(NFRE_loki_param) + REAL(KIND=JWRB), VALUE, INTENT(IN) :: TAUOCMAX + REAL(KIND=JWRB), VALUE, INTENT(IN) :: TAUOCMIN + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: ICHNK + INTEGER, VALUE, INTENT(IN) :: NCHNK + + ! ---------------------------------------------------------------------- + + + EPSUS3 = EPSUS*SQRT(EPSUS) + + CITHRSH_INV = 1._JWRB / MAX(CITHRSH, 0.01_JWRB) + + EFD_FAC = 4.0_JWRB*EGRCRV / G**2 + FFD_FAC = (EGRCRV / AFCRV)**(1.0_JWRB / BFCRV)*G + + !* DETERMINE NORMALIZED FLUXES FROM AIR TO WAVE AND FROM WAVE TO OCEAN. + ! ------------------------------------------------------------------- + + ! ENERGY FLUX from SSURF + ! MOMENTUM FLUX FROM SSURF + + PHILF = 0.0_JWRB + XSTRESS = 0.0_JWRB + YSTRESS = 0.0_JWRB + + ! THE INTEGRATION ONLY UP TO FR=MIJ + DO M=1,NFRE + K = 1 + SUMT = SSURF(IJ, K, M) + SUMX = SINTH(K)*SSURF(IJ, K, M) + SUMY = COSTH(K)*SSURF(IJ, K, M) + DO K=2,NANG + SUMT = SUMT + SSURF(IJ, K, M) + SUMX = SUMX + SINTH(K)*SSURF(IJ, K, M) + SUMY = SUMY + COSTH(K)*SSURF(IJ, K, M) + END DO + PHILF = PHILF + SUMT*RHOWGDFTH(IJ, M) + CMRHOWGDFTH = CINV(IJ, M, ICHNK)*RHOWGDFTH(IJ, M) + XSTRESS = XSTRESS + SUMX*CMRHOWGDFTH + YSTRESS = YSTRESS + SUMY*CMRHOWGDFTH + END DO + + IF (LICERUN .and. LWAMRSETCI) THEN + IF (CICOVER(IJ, ICHNK) > CIBLOCK) THEN + OOVAL = EXP(-MIN((CICOVER(IJ, ICHNK)*CITHRSH_INV)**4, 10._JWRB)) + ! ADJUST USTAR FOR THE PRESENCE OF SEA ICE + U10P = MAX(WSWAVE(IJ, ICHNK), EPSU10) + CD_BULK = MIN((C1 + C2*U10P**P1)*U10P**P2, CDMAX) + CD_WAVE = (UFRIC(IJ, ICHNK) / U10P)**2 + CD_ICE = OOVAL*CD_WAVE + (1.0_JWRB - OOVAL)*CD_BULK + USTAR = MAX(SQRT(CD_ICE)*U10P, EPSUS) + + ! EM_OC and F1_OC with fully developed model ENERGY + ! The significant wave height derived from EM_OC will be used + ! by NEMO as a scaling factor as if it was open ocean + EFD = MIN(EFD_FAC*USTAR**4, EFD_MAX) + EM_OC = MAX(OOVAL*EM(IJ) + (1.0_JWRB - OOVAL)*EFD, EFD_MIN) + FFD = FFD_FAC / USTAR + F1_OC = OOVAL*F1(IJ) + (1.0_JWRB - OOVAL)*FFD + F1_OC = MIN(MAX(F1_OC, FR(2)), FR(NFRE)) + ELSE + OOVAL = 1.0_JWRB + USTAR = UFRIC(IJ, ICHNK) + EM_OC = EM(IJ) + F1_OC = F1(IJ) + END IF + ELSE + OOVAL = 1.0_JWRB + USTAR = UFRIC(IJ, ICHNK) + EM_OC = EM(IJ) + F1_OC = F1(IJ) + END IF + + + TAU = AIRD(IJ, ICHNK)*MAX(USTAR**2, EPSUS) + TAUXD(IJ, ICHNK) = TAU*SIN(WDWAVE(IJ, ICHNK)) + TAUYD(IJ, ICHNK) = TAU*COS(WDWAVE(IJ, ICHNK)) + + TAUOCXD(IJ, ICHNK) = TAUXD(IJ, ICHNK) - OOVAL*XSTRESS + TAUOCYD(IJ, ICHNK) = TAUYD(IJ, ICHNK) - OOVAL*YSTRESS + TAUO = SQRT(TAUOCXD(IJ, ICHNK)**2 + TAUOCYD(IJ, ICHNK)**2) + TAUOC(IJ, ICHNK) = MIN(MAX(TAUO / TAU, TAUOCMIN), TAUOCMAX) + + XN = AIRD(IJ, ICHNK)*MAX(USTAR**3, EPSUS3) + PHIOCD(IJ, ICHNK) = OOVAL*(PHILF - PHIWA(IJ)) + (1.0_JWRB - OOVAL)*PHIOC_ICE*XN + + PHIEPS(IJ, ICHNK) = PHIOCD(IJ, ICHNK) / XN + PHIEPS(IJ, ICHNK) = MIN(MAX(PHIEPS(IJ, ICHNK), PHIEPSMIN), PHIEPSMAX) + + PHIOCD(IJ, ICHNK) = PHIEPS(IJ, ICHNK)*XN + + PHIAW(IJ, ICHNK) = PHIWA(IJ) / XN + PHIAW(IJ, ICHNK) = OOVAL*PHIWA(IJ) / XN + (1.0_JWRB - OOVAL)*PHIAW_ICE + + IF (LWNEMOCOU .and. LNUPD) THEN + NPHIEPS(IJ, ICHNK) = PHIEPS(IJ, ICHNK) + NTAUOC(IJ, ICHNK) = TAUOC(IJ, ICHNK) + IF (EM_OC /= 0.0_JWRB) THEN + NSWH(IJ, ICHNK) = 4.0_JWRO*SQRT(EM_OC) + ELSE + NSWH(IJ, ICHNK) = 0.0_JWRO + END IF + IF (F1_OC /= 0.0_JWRB) THEN + NMWP(IJ, ICHNK) = 1.0_JWRO / F1_OC + ELSE + NMWP(IJ, ICHNK) = 0.0_JWRO + END IF + + IF (LWNEMOTAUOC) THEN + NEMOTAUX(IJ, ICHNK) = NEMOTAUX(IJ, ICHNK) + TAUOCXD(IJ, ICHNK) + NEMOTAUY(IJ, ICHNK) = NEMOTAUY(IJ, ICHNK) + TAUOCYD(IJ, ICHNK) + ELSE + NEMOTAUX(IJ, ICHNK) = NEMOTAUX(IJ, ICHNK) + TAUXD(IJ, ICHNK) + NEMOTAUY(IJ, ICHNK) = NEMOTAUY(IJ, ICHNK) + TAUYD(IJ, ICHNK) + END IF + NEMOWSWAVE(IJ, ICHNK) = NEMOWSWAVE(IJ, ICHNK) + WSWAVE(IJ, ICHNK) + NEMOPHIF(IJ, ICHNK) = NEMOPHIF(IJ, ICHNK) + PHIOCD(IJ, ICHNK) + END IF + + + ! ---------------------------------------------------------------------- + + END SUBROUTINE WNFLUXES_CUF_HOIST_NEW +END MODULE WNFLUXES_CUF_HOIST_NEW_MOD diff --git a/src/phys-scc-cuf-hoist/yowaltas.cuf_hoist_new.F90 b/src/phys-scc-cuf-hoist/yowaltas.cuf_hoist_new.F90 new file mode 100644 index 00000000..d89b931e --- /dev/null +++ b/src/phys-scc-cuf-hoist/yowaltas.cuf_hoist_new.F90 @@ -0,0 +1,176 @@ +! (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. +! +MODULE YOWALTAS + + USE PARKIND_WAVE, ONLY: JWIM, JWRB, JWRU + + IMPLICIT NONE + + INTEGER(KIND=JWIM), PARAMETER :: NUMALT = 10 + INTEGER(KIND=JWIM), PARAMETER :: NIJALT = 4 + INTEGER(KIND=JWIM), PARAMETER :: NALTDT = 3 + INTEGER(KIND=JWIM), PARAMETER :: NALTEDT = 3 + INTEGER(KIND=JWIM), PARAMETER :: NALTUDT = 2 + + INTEGER(KIND=JWIM) :: NALTAVLB + INTEGER(KIND=JWIM) :: IBUFRSAT(NUMALT) + INTEGER(KIND=JWIM), ALLOCATABLE :: IJALT(:, :) + INTEGER(KIND=JWIM), ALLOCATABLE :: INTLMAX(:) + INTEGER(KIND=JWIM), ALLOCATABLE :: KMINLMAX(:) + INTEGER(KIND=JWIM), ALLOCATABLE :: KMAXLMAX(:) + INTEGER(KIND=JWIM), ALLOCATABLE :: NOBSPE(:) + + REAL(KIND=JWRB) :: EGRCRV + REAL(KIND=JWRB) :: AGRCRV + REAL(KIND=JWRB) :: BGRCRV + REAL(KIND=JWRB) :: AFCRV + REAL(KIND=JWRB) :: BFCRV + REAL(KIND=JWRB) :: ESH + REAL(KIND=JWRB) :: ASH + REAL(KIND=JWRB) :: BSH + REAL(KIND=JWRB) :: ASWKM + REAL(KIND=JWRB) :: BSWKM + + REAL(KIND=JWRB) :: XKAPPA2(NUMALT) + REAL(KIND=JWRB) :: HSCOEFCOR(NUMALT) + REAL(KIND=JWRB) :: HSCONSCOR(NUMALT) + REAL(KIND=JWRB) :: ALTSDTHRSH(NUMALT) + REAL(KIND=JWRB) :: ALTBGTHRSH(NUMALT) + REAL(KIND=JWRB) :: HSALTCUT(NUMALT) + + REAL(KIND=JWRB), ALLOCATABLE :: ALTDATA(:, :) + REAL(KIND=JWRB), ALLOCATABLE :: ALTEXDATA(:, :) + REAL(KIND=JWRB), ALLOCATABLE, DIMENSION(:) :: XLONOBS, SIGRATIO2, DIFFALTFG + + REAL(KIND=JWRU), ALLOCATABLE :: ALTUNDATA(:, :) + + CHARACTER(LEN=25) :: CSATNAME(NUMALT) + CHARACTER(LEN=14), ALLOCATABLE, DIMENSION(:) :: CDATEOBS + + LOGICAL :: LODBRALT + LOGICAL :: LALTCOR(NUMALT) + LOGICAL :: LALTLRGR(NUMALT) + LOGICAL :: LALTGRDOUT(NUMALT) + LOGICAL :: LALTPAS(NUMALT) + LOGICAL, ALLOCATABLE :: LALTPASSIV(:) + + ! VARIABLE TYPE PURPOSE + ! -------- ---- ------- + ! *NUMALT* INTEGER MAXIMUM NUMBER OF ALTIMETERS ALLOWED IN ALTAS. + ! *NIJALT* INTEGER SECOND DIMENSION OF IJALT + ! *NALTDT* INTEGER SECOND DIMENSION OF ALTDATA + ! IF 1 : CORRECTED WAVE HEIGHTS + ! 2 : ERROR ASSOCIATED WITH THE DATUM + ! 3 : ORIGINAL WAVE HEIGHT + ! *NALTEDT* INTEGER SECOND DIMENSION OF ALTEXDATA + ! 1 : LATITUDE OF OBSERVATION + ! 2 : LONGITUDE OF OBSERVATION + ! 3 : ORIGINAL WIND SPEED + ! *NALTUDT* INTEGER SECOND DIMENSION OF ALTUNDATA + ! 1 : LATITUDE OF CLOSEST NODE TO OBSERVATION + ! 2 : LONGITUDE OF CLOSEST NODE OBSERVATION + ! *NALTAVLB* INTEGER NUMBER OF ALTIMETERS FROM WHICH THERE ARE + ! AVAILABLE DATA. + ! *IBUFRSAT* INTEGER BUFR IDENTIFIER FOR THE SATELLITES + ! *IJALT* INTEGER ARRAY FOR: 1: ALTIMETER DATA BLOCK INDEX, + ! 2: SATELLITE IDENTIFIER, AND + ! 3: WAVE HEIGHT QUALITY STATUS + ! 4: WIND SPEED QUALITY STATUS + ! STATUS: + ! 1: ACTIVE + ! 0: PASSIVE OR BLACKLISTED (passing all QC's) + ! -1: MISSING DATA + ! -2: TOO SMALL (BELOW A CERTAIN THRESHOLD) + ! -3: TOO FEW MEASUREMENTS TO CREATE SUPEROBS + ! -4: STANDARD DEVIATION TOO LARGE TO CREATE SUPEROBS + ! -5: OVER MODEL SEA ICE THRESHOLD (SEE CITHRSH_SAT) + ! -6: FAILED BACKGROUNG CHECK + + ! *INTLMAX* INTEGER TABLE INDICATING WHETHER A PE COULD SHARE + ! ALTIMETER DATA WITH LOCAL PE (IRANK) + ! *KMINLMAX* INTEGER SOUTHERN LATITUDE INDEX OF THE SOUTHERN + ! LATITUDONAL BAND OF WIDTH LMAX FOR EACH PE + ! *KMAXLMAX* INTEGER NORTHERN LATITUDE INDEX OF THE NORTHERN + ! 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 + ! *EGRCRV* REAL PARAMETER OF THE NON DIMENSIONAL ENERGY + ! GROWTH CURVE. + ! ESTAR=EGRCRV*(TSTAR/(AGRCRV+TSTAR))**BGRCRV + ! *AGRCRV* REAL PARAMETER OF THE NON DIMENSIONAL ENERGY + ! GROWTH CURVE. + ! *BGRCRV* REAL PARAMETER OF THE NON DIMENSIONAL ENERGY + ! GROWTH CURVE. + ! *AFCRV* REAL PARAMETER OF THE NON DIMENSIONAL FREQUENCY + ! GROWTH CURVE. Based on f * F(f) + ! FSTAR=(EGRCRV/AFCRV)**(1/BFCRV) + ! *BFCRV* REAL PARAMETER OF THE NON DIMENSIONAL FREQUENCY + ! GROWTH CURVES. + ! *AFMRV* REAL PARAMETER OF THE NON DIMENSIONAL FREQUENCY + ! GROWTH CURVE. Based on 1/f F(f) + ! FSTAR=(EGRCRV/AFCRV)**(1/BFCRV) + ! *BFMRV* REAL PARAMETER OF THE NON DIMENSIONAL FREQUENCY + ! GROWTH CURVE. + ! *ESH* REAL PARAMETER OF THE NON DIMENSIONAL ENERGY LIMIT + ! AS A FUNCTION OF NON-DIMENSIONAL DEPTH DSTAR + ! ESTAR_LIMIT=ESH*TANH(ASH*DSTAR**BSH), where + ! DSTAR=DEPTH*G/USTAR**2 + ! *ASH* REAL PARAMETER OF THE NON DIMENSIONAL ENERGY LIMIT + ! SEE ESH. + ! *BSH* REAL PARAMETER OF THE NON DIMENSIONAL ENERGY LIMIT + ! SEE ESH. + ! *ASWKM* REAL PARAMETER TO EXPRESS MINIMUM KMEAN AS A FUNCTION + ! OF DEPTH: KMEAN >= ASWKM/DEPTH**BSWKM + ! *BSWKM* REAL PARAMETER TO EXPRESS MINIMUM KMEAN AS A FUNCTION + ! OF DEPTH: KMEAN >= ASWKM/DEPTH**BSWKM + + ! *XKAPPA2* REAL KAPPA2 PARAMETER USED IN THE DETERMINATION + ! OF ALTIMETER WAVE HEIGHTS (SEE GRFIELD) + ! *HSCOEFCOR*REAL COEFFICIENT OF THE CORRECTIVE LINEAR + ! REGRESSION FOR ALTIMETER WAVE HEIGHTS. + ! *HSCONSCOR*REAL CONSTANT COEFFICIE$NT OF THE CORRECTIVE + ! LINEAR REGRESSION FOR ALTIMETER WAVE + ! HEIGHTS. + ! *ALTSDTHRSH* REAL THRESHOLD FOR SUSPICIOUS DATA (SEE GRFIELD). + ! *ALTBGTHRSH* REAL THRESHOLD FOR BACKGROUND CHECK (SEE GRFIELD). + ! *HSALTCUT* REAL USER INPUT OF THE MINIMUM WAVE HEIGHT ALLOWED + ! FOR THE ALTIMETER WAVE HEIGHT. THE ACTUAL + ! MINIMUM HSCUT=MIN(HSALTCUT,SIGMA_ALT) + ! SEE GRFIELD. + ! *ALTDATA* REAL ALTIMETER DATA AND ERROR ESTIMATE AFTER + ! PREPROCESSING + ! *ALTEXDATA* REAL EXTRA ALTIMETER DATA (THAT WILL NOT BE PASSED + ! TO THE MODEL .. NEEDED ONLY FOR ODB CREATION) + ! *XLONOBS* REAL LONGITUDE OF ALTIMETER DATA AS USED BY OI. + ! *SIGRATIO2*REAL RATIO OF ALTIMETER TO MODEL ERROR IN OI. + ! *DIFFALTFG*REAL OBS MINUS FIRST GUESS AT OBS LOCATIONS. + + ! *ALTUNDATA* REAL8 FOR UNSTRUCTURED GRID: THE COORDINATES OF THE CLOSEST NODE + + ! *CSATNAME* CHARACTER NAME OF THE DIFFERENT ALTIMETERS + ! *LODBRALT* LOGICAL CONTROLS THE USE OF ODB FOR RADAR ALTIMETER OBS. + ! *LALTCOR* LOGICAL CONTROLS WHETHER THE ALTIMETER WAVE HEIGHT + ! OBSERVATION IS CORRECTED USING THE WAVE + ! SEA STATE PRIOR TO ITS ASSIMILATION. + ! *LALTLRGR* LOGICAL CONTROLS WHETHER THE ALTIMETER WAVE HEIGHT + ! OBSERVATION IS CORRECTED USING A PRESCRIBED + ! LINEAR REGRESSION. + ! *LALTGRDOUT* LOGICAL CONTROLS WHETHER TO OUTPUT THE GRIDDED + ! ALTIMETER PRODUCTS OF THE SPECIFIC + ! INSTRUMENT (AS PROVIDED IN THE NAME LIST) + ! *LALTPAS* LOGICAL CONTROLS WHETHER OR NOT THE DATA ARE FED + ! PASSIVELY OR NOT (DEFAULT). + ! *LALTPASSIV*LOGICAL USE BY OIFIELD TO EXCLUDE PASSIVE DATA. + + ! ---------------------------------------------------------------------- +!$acc declare create( EGRCRV ) +!$acc declare create( AFCRV ) +!$acc declare create( BFCRV ) +END MODULE YOWALTAS diff --git a/src/phys-scc-cuf-hoist/yowcoup.cuf_hoist_new.F90 b/src/phys-scc-cuf-hoist/yowcoup.cuf_hoist_new.F90 new file mode 100644 index 00000000..043e11fa --- /dev/null +++ b/src/phys-scc-cuf-hoist/yowcoup.cuf_hoist_new.F90 @@ -0,0 +1,251 @@ +! (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. +! +MODULE YOWCOUP + + USE PARKIND_WAVE, ONLY: JWIM, JWRB, JWRU, JWRO + + IMPLICIT NONE + + !* ** *COUPL* - PARAMETERS FOR COUPLING. + + LOGICAL :: LLCAPCHNK + LOGICAL :: LLGCBZ0 + LOGICAL :: LLNORMAGAM + LOGICAL :: LWCOU + LOGICAL :: LWCOUSAMEGRID = .false. + LOGICAL :: LWNEMOCOU = .false. + LOGICAL :: LWNEMOCOUSEND + LOGICAL :: LWNEMOTAUOC + LOGICAL :: LWNEMOCOUSTRN = .false. + LOGICAL :: LWNEMOCOURECV + LOGICAL :: LWNEMOCOUCIC = .false. + LOGICAL :: LWNEMOCOUCIT = .false. + LOGICAL :: LWNEMOCOUCUR = .false. + LOGICAL :: LWNEMOCOUSTK = .false. + LOGICAL :: LWNEMOCOUDEBUG + LOGICAL :: LWCOU2W + LOGICAL :: LWCOURNW + LOGICAL :: LWCOUHMF + LOGICAL :: LWFLUX + LOGICAL :: LWVFLX_SNL + LOGICAL :: LWCOUNORMS + LOGICAL :: LLNORMIFS2WAM + LOGICAL :: LLNORMWAM2IFS + LOGICAL :: LLNORMWAMOUT + LOGICAL :: LLNORMWAMOUT_GLOBAL + CHARACTER(LEN=1024) :: CNORMWAMOUT_FILE + INTEGER :: IUWAMNORM_OUT + LOGICAL :: LMASK_OUT_NOT_SET + LOGICAL :: LMASK_TASK_STR + INTEGER(KIND=JWIM) :: KCOUSTEP + INTEGER(KIND=JWIM), ALLOCATABLE :: LFROMTASK(:), LTOTASK(:) + INTEGER(KIND=JWIM), ALLOCATABLE :: IJFROMTASK(:), IJTOTASK(:) + INTEGER(KIND=JWIM), ALLOCATABLE :: ISTFROMTASK(:), ISTTOTASK(:) + INTEGER(KIND=JWIM) :: NFROMTASKS, NTOTASKS + INTEGER(KIND=JWIM), ALLOCATABLE :: I_MASK_IN(:) + INTEGER(KIND=JWIM) :: N_MASK_IN + INTEGER(KIND=JWIM), ALLOCATABLE :: I_MASK_OUT(:), J_MASK_OUT(:) + INTEGER(KIND=JWIM) :: N_MASK_OUT + + INTEGER(KIND=JWIM), PARAMETER :: JTOT_TAUHF = 19 + ! must be odd !!! + REAL(KIND=JWRB) :: WTAUHF(JTOT_TAUHF) + REAL(KIND=JWRB) :: X0TAUHF + + INTEGER(KIND=JWIM) :: NEMONTAU + + INTEGER(KIND=JWIM) :: NEMOINIDATE + INTEGER(KIND=JWIM) :: NEMOINITIME + INTEGER(KIND=JWIM) :: NEMOITINI + INTEGER(KIND=JWIM) :: NEMOITEND + REAL(KIND=JWRO) :: NEMOTSTEP + INTEGER(KIND=JWIM) :: NEMOFRCO + INTEGER(KIND=JWIM) :: NEMONSTEP + INTEGER(KIND=JWIM) :: NEMOCSTEP + INTEGER(KIND=JWIM) :: NEMOWSTEP + + INTEGER(KIND=JWIM) :: IFSNSTEP + REAL(KIND=JWRB) :: IFSTSTEP + LOGICAL :: LIFS_IO_SERV_ENABLED + + CHARACTER(LEN=32) :: IFSCONTEXT + ! Corresponds to ALGORITHM_STATE_MOD%GET_ALGOR_TYPE() + INTEGER(KIND=JWIM) :: IFSNUPTRA + ! Corresponds to ALGORITHM_STATE_MOD%GET_NUPTRA() + INTEGER(KIND=JWIM) :: IFSMUPTRA + ! Corresponds to ALGORITHM_STATE_MOD%GET_MUPTRA() + + PROCEDURE(OUTWSPEC_IO_SERV), POINTER :: OUTWSPEC_IO_SERV_HANDLER => NULL() + PROCEDURE(OUTINT_IO_SERV), POINTER :: OUTINT_IO_SERV_HANDLER => NULL() + PROCEDURE(IFSTOWAM), POINTER :: IFSTOWAM_HANDLER => NULL() + + !* VARIABLE. TYPE. PURPOSE. + ! --------- ------- -------- + ! *LWCOU* LOGICAL CONTROLS COUPLING WITH ATMOSPHERIC MODEL + ! *LWCOUSAMEGRID TRUE when coupled and the atmospheric grid and the wave grid is the same + ! *LWNEMOCOUSEND* L SENDS DATA TO THE NEMO MODEL. + ! *LWNEMOCOUSTK LOGI. SEND SURFACE STOKES DRIFT TO NEMO + ! *LWNEMOCOUSTRN LOGI. SEND ICE WAVE STRAIN TO NEMO + ! *LWNEMOCOURECV* L RECV DATA FROM THE NEMO MODEL. + ! *LWNEMOCOU* LOGICAL CONTROLS COUPLING WITH NEMO OCEAN MODEL + ! *LWNEMOCOUDEBUG* LO EXTRA NETCDF DEBUGGING OUTPUT FOR NEMO COUPLING + ! *LWNEMOTAUOC* LO USE TAUOC OR FULL TAU FOR SENDING TO NEMO + ! *LWNEMOCOUCIC LOGI. USE THE ICE CONCENTRATION FROM NEMO for open ocean points as determined by the lake cover (see micep) + ! *LWNEMOCOUCIT LOGI. USE THE ICE THICKNESS FROM NEMO (see LWNEMOCOUCIC) + ! *LWNEMOCOUCUR LOGI. USE THE OCEAN CURRENTS FROM NEMO for open ocean points as determined by the lake cover (see getcurr) + ! *LWCOU2W* LOGICAL CONTROLS 1-WAY OR 2-WAY COUPLING TO ATMOSPHERE + ! *LWCOURNW* LOGICAL WHEN COUPLED, IF TRUE THEN THE WINDS ARE THE 10m NEUTRAL WINDS RELATIVE TO SURFACE OCEAN CURRENTS + ! *LWCOUHMF* LOGICAL WHEN COUPLED, IF TRUE THEN THE SEA STATE EFFECT ON THE HEAT AND MOISTURE WILL BE ACTIVATED + ! *LWFLUX* LOGICAL IF TRUE FLUXES FOR OCEAN MODEL ARE PRODUCED + ! FOR THE IFS. + ! *LWVFLX_SNL LOGICAL IF TRUE FLUXES FOR OCEAN MODEL ARE PRODUCED + ! WITh THE NONLINEAR SOURCE TERM CONTRIBUTION + ! *LWCOUNORMS*LOGICAL CONTROLS COMPUTING/PRINTING OF TRUE GLOBAL NORMS OF FIELDS + ! FROM/TO THE ATMOS MODEL + ! *LLNORMIFS2WAM* LOGICAL IF TRUE NORMS FOR FIELDS PASSED FROM IFS TO WAM WILL BE PRODUCED + ! *LLNORMWAM2IFS* LOGICAL IF TRUE NORMS FOR FIELDS PASSED FROM WAM TO IFS WILL BE PRODUCED + ! *LLNORMWAMOUT* LOGICAL IF TRUE NORMS OF SELECTED OUPTUT FIELDS WILL BE PRODUCED + ! *LLNORMWAMOUT_GLOBAL* LOGICAL IF TRUE NORMS OF SELECTED OUPTUT FIELDS WILL BE GLOBAL (see above) + ! *LMASK_OUT_NOT_SET INDICATES IF THE MASK USED FOR FIELDS RETURNED + ! TO IFS IS UNSET OR NOT. + ! *LMASK_TASK_STR* LOGICAL TRUE UNTIL THE TASK STRUCTURE CORRESPONDING + ! TO MASK_OUT IS DETERMINED. + ! *KCOUSTEP* INTEGER COUPLING TIME TO THE IFS (in seconds). + ! *LFROMTASK* INTEGER CONTROLS WHICH WAM TASKS CONTRIBUTE TO THE FIELDS + ! RETURNED TO THE IFS FROM CURRENT TASK + ! BY SPECIFYING THE NUMBER OF SEA POINTS THAT + ! CONTRIBUTES TO THE FIELDS + ! *LTOTASK* INTEGER CONTROLS WHICH WAM TASKS NEED TO RECEIVE + ! CONTRIBUTIONS TO THE FIELDS RETURNED TO IFS + ! FROM CURRENT WAM TASK BY SPECIFYING + ! THE NUMBER OF SEA POINTS THAT ARE NEEDED. + ! *IJFROMTASK*INTEGER GIVES THE (global) IJ INDEX FOR EACH SEA POINT + ! REFERRED TO BY LFROMTASK. + ! SIZE IS GIVEN BY NFROMTASKS + ! *IJTOTASK* INTEGER GIVES THE (global) IJ INDEX FOR EACH SEA POINT + ! REFERRED TO BY LTOTASK + ! SIZE IS GIVEN BY NTOTASKS. + ! *ISTFROMTASK*INTEGER GIVES THE STARTNG INDEX IN IJFROMTASK FOR ALL + ! IJ's THAT ARE FROM EACH TASK (if any). + ! *ISTTOTASK* INTEGER GIVES THE STARTNG INDEX IN IJTOTASK FOR ALL + ! IJ's THAT ARE TO BE SENT FROM EACh TASK (if any). + ! *NFROMTASKS*INTEGER SUM OF LFROMTASKS ON EACH TASK. + ! *NTOTASKS* INTEGER SUM OF LTOTASKS ON EACH TASK. + ! *I_MASK_IN* INTEGER LIST OF I INDEX OF MASK_IN THAT ARE LOCAL TO TASK + ! *N_MASK_IN* INTEGER MAXIMUM SIZE OF I_MASK_IN + ! *I_MASK_OUT*INTEGER LIST OF I INDEX OF MASK_OUT THAT ARE LOCAL TO TASK + ! *J_MASK_OUT*INTEGER LIST OF J INDEX OF MASK_OUT THAT ARE LOCAL TO TASK + ! *N_MASK_OUT*INTEGER MAXIMUM SIZE OF I_MASK_OUT AND J_MASK_OUT + ! *LLCAPCHNK* LOGICAL IF TRUE CHARNOCK FOR HIGH WINDS WILL BE CAPPED (see chnkmin) + ! *LLGCBZ0* LOGICAL IF TRUE USE GRAVITY-CAPILLARY MODEL FOR BACKGROUND ROUGHNESS + ! *LNORMAGAM* LOGICAL IF TRUE USE THE RENORMALISTION OF THE GROWTH RATE. + + ! *JTOT_TAUHF INTEGER DIMENSION OF WTAUHF. IT MUST BE ODD !!! + ! *WTAUHF* REAL INTEGRATION WEIGHT FOR TAU_PHI_HF + ! *X0TAUHF* REAL LOWEST LIMIT FOR INTEGRATION IN TAU_PHI_HF: X0 *(G/USTAR) + ! + + ! FOR ACCUMULATED FIELDS PASSED TO NEMO: + ! *NEMONTAU* INTEGER ACCUMULATION COUNT + ! + ! *NEMOINIDATE* INTEGER NEMO INITIAL DATE + ! *NEMOINITIME* INTEGER NEMO INITIAL TIME + ! *NEMOITINI* INTEGER NEMO INITIAL TIME STEP + ! *NEMOITEND* INTEGER NEMO FINAL TIME STEP + ! *NEMOTSTEP* REAL NEMO TIMESTEP + ! *NEMOFRCO* INTEGER NEMO COUPLING FREQ IN WAM TIME STEPS + ! *NEMONSTEP* INTEGER NEMO COUPLING FREQ IN NEMO TIME STEPS + ! *NEMOCSTEP* INTEGER NEMO CURRENT TIME STEP + ! *NEMOWSTEP* INTEGER WAM CURRENT TIME STEP + + ! *IFSTSTEP* TIME STEP OF ATMOSPHERIC MODEL + ! *IFSNSTEP* CURRENT STEP OF ATMOSPHERIC MODEL + ! *LIFS_IO_SERV_ENABLED* LOGICAL TRUE IF IFS IO SERVER ENABLED + ! + ! IFSCONTEXT Corresponds to ALGORITHM_STATE_MOD%GET_ALGOR_TYPE() + ! IFSNUPTRA Corresponds to ALGORITHM_STATE_MOD%GET_NUPTRA() + ! IFSMUPTRA Corresponds to ALGORITHM_STATE_MOD%GET_MUPTRA() + ! + ! ---------------------------------------------------------------------- + +!$acc declare create( LWFLUX ) +!$acc declare create( LWVFLX_SNL ) +!$acc declare create( LWNEMOTAUOC ) +!$acc declare create( LWCOU ) +!$acc declare create( LWNEMOCOU ) +!$acc declare create( LWNEMOCOUSEND ) +!$acc declare create( LWNEMOCOUSTK ) +!$acc declare create( LWNEMOCOUSTRN ) +!$acc declare create( LLCAPCHNK ) +!$acc declare create( X0TAUHF ) +!$acc declare create( WTAUHF ) +!$acc declare create( LLNORMAGAM ) +!$acc declare create( LLGCBZ0 ) + CONTAINS + + !---------------------------------------------------------------------------------------- + + SUBROUTINE IFSTOWAM (BLK2LOC, NFIELDS, NGPTOTG, NCA, NRA, FIELDS, LWCUR, MASK_IN, NXS, NXE, NYS, NYE, FIELDG) + USE PARKIND_WAVE, ONLY: JWIM, JWRB + USE YOWDRVTYPE, ONLY: WVGRIDLOC, FORCING_FIELDS + USE YOWGRID, ONLY: NPROMA_WAM, NCHNK + USE YOWABORT, ONLY: WAM_ABORT + TYPE(WVGRIDLOC), INTENT(IN) :: BLK2LOC + INTEGER(KIND=JWIM), INTENT(IN) :: NFIELDS, NGPTOTG, NCA, NRA + REAL(KIND=JWRB), INTENT(IN) :: FIELDS(NGPTOTG, NFIELDS) + LOGICAL, INTENT(IN) :: LWCUR + INTEGER(KIND=JWIM), INTENT(INOUT) :: MASK_IN(NGPTOTG) + INTEGER(KIND=JWIM), INTENT(IN) :: NXS, NXE, NYS, NYE + TYPE(FORCING_FIELDS), INTENT(INOUT) :: FIELDG + + IF (.not.ASSOCIATED(IFSTOWAM_HANDLER)) CALL WAM_ABORT('IFSTOWAM_HANDLER IS NOT INITIALIZED') + CALL IFSTOWAM_HANDLER(BLK2LOC, NFIELDS, NGPTOTG, NCA, NRA, FIELDS, LWCUR, MASK_IN, NXS, NXE, NYS, NYE, FIELDG) + + END SUBROUTINE IFSTOWAM + + !---------------------------------------------------------------------------------------- + + SUBROUTINE OUTWSPEC_IO_SERV (IJS, IJL, SPEC, MARSTYPE, CDATE, IFCST) + USE PARKIND_WAVE, ONLY: JWIM, JWRB + USE YOWPARAM, ONLY: NANG, NFRE + USE YOWABORT, ONLY: WAM_ABORT + IMPLICIT NONE + INTEGER(KIND=JWIM), INTENT(IN) :: IJS, IJL + REAL(KIND=JWRB), INTENT(IN) :: SPEC(IJS:IJL, NANG, NFRE) + CHARACTER(LEN=2), INTENT(IN) :: MARSTYPE + CHARACTER(LEN=14), INTENT(IN) :: CDATE + INTEGER, INTENT(IN) :: IFCST + + IF (.not.ASSOCIATED(OUTWSPEC_IO_SERV_HANDLER)) CALL WAM_ABORT('OUTWSPEC_IO_SERV_HANDLER IS NOT INITIALIZED') + CALL OUTWSPEC_IO_SERV_HANDLER(IJS, IJL, SPEC, MARSTYPE, CDATE, IFCST) + + END SUBROUTINE OUTWSPEC_IO_SERV + + !---------------------------------------------------------------------------------------- + + SUBROUTINE OUTINT_IO_SERV (NIPRMOUT, BOUT, INFOBOUT, MARSTYPE, CDATE, IFCST) + USE PARKIND_WAVE, ONLY: JWIM, JWRB + USE YOWGRID, ONLY: NPROMA_WAM, NCHNK + USE YOWABORT, ONLY: WAM_ABORT + IMPLICIT NONE + INTEGER(KIND=JWIM), INTENT(IN) :: NIPRMOUT + REAL(KIND=JWRB), INTENT(IN) :: BOUT(NPROMA_WAM, NIPRMOUT, NCHNK) + INTEGER(KIND=JWIM), INTENT(IN) :: INFOBOUT(NIPRMOUT, 3) + CHARACTER(LEN=2), INTENT(IN) :: MARSTYPE + CHARACTER(LEN=14), INTENT(IN) :: CDATE + INTEGER(KIND=JWIM), INTENT(IN) :: IFCST + + IF (.not.ASSOCIATED(OUTINT_IO_SERV_HANDLER)) CALL WAM_ABORT('OUTINT_IO_SERV_HANDLER IS NOT INITIALIZED') + CALL OUTINT_IO_SERV_HANDLER(NIPRMOUT, BOUT, INFOBOUT, MARSTYPE, CDATE, IFCST) + + END SUBROUTINE OUTINT_IO_SERV + + !---------------------------------------------------------------------------------------- + +END MODULE YOWCOUP diff --git a/src/phys-scc-cuf-hoist/yowcout.cuf_hoist_new.F90 b/src/phys-scc-cuf-hoist/yowcout.cuf_hoist_new.F90 new file mode 100644 index 00000000..a0201d23 --- /dev/null +++ b/src/phys-scc-cuf-hoist/yowcout.cuf_hoist_new.F90 @@ -0,0 +1,152 @@ +! (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. +! +MODULE YOWCOUT + + USE PARKIND_WAVE, ONLY: JWIM, JWRB, JWRU + + IMPLICIT NONE + + !* ** *COUT* OUTPUT POINTS INDICES AND FLAGS. + + INTEGER(KIND=JWIM), PARAMETER :: NTRAIN = 3 + INTEGER(KIND=JWIM), PARAMETER :: JPPFLAG = 69 + 3*NTRAIN + 5 + !!!! change also in scripts: wave_setgflag + INTEGER(KIND=JWIM), PARAMETER :: NREAL = 14 + INTEGER(KIND=JWIM), PARAMETER :: NIPRMINFO = 5 + INTEGER(KIND=JWIM), PARAMETER :: NINFOBOUT = 3 + + CHARACTER(LEN=14), ALLOCATABLE :: COUTT(:) + CHARACTER(LEN=14) :: COUTLST + CHARACTER(LEN=14), ALLOCATABLE :: COUTS(:) + CHARACTER(LEN=14), ALLOCATABLE :: CASS(:) + + CHARACTER(LEN=256) :: COUTDESCRIPTION(JPPFLAG) + CHARACTER(LEN=33) :: COUTNAME(JPPFLAG) + + LOGICAL :: FFLAG(JPPFLAG) + LOGICAL :: FFLAG20 + LOGICAL :: GFLAG(JPPFLAG) + LOGICAL :: GFLAG20 + LOGICAL :: NFLAG(JPPFLAG) + LOGICAL :: NFLAGALL + LOGICAL :: UFLAG(JPPFLAG) + LOGICAL :: LFDB + LOGICAL :: LOUTINT + LOGICAL :: LWFLUXOUT + LOGICAL :: LSECONDORDER + LOGICAL :: LRSTST0 + LOGICAL :: LWAMANOUT + LOGICAL :: LWAMANOUT_ORIG + LOGICAL :: LRSTPARALR + LOGICAL :: LRSTPARALW + LOGICAL :: LRSTINFDAT + LOGICAL :: LLPARTITION + LOGICAL :: LWAM_USE_IO_SERV + LOGICAL :: LOUTMDLDCP + + INTEGER(KIND=JWIM) :: NWRTOUTWAM = 1 + INTEGER(KIND=JWIM) :: NIPRMOUT + INTEGER(KIND=JWIM) :: NGOUT + INTEGER(KIND=JWIM), ALLOCATABLE :: IJAR(:) + INTEGER(KIND=JWIM) :: NOUTT + INTEGER(KIND=JWIM) :: NOUTS + INTEGER(KIND=JWIM) :: NASS + INTEGER(KIND=JWIM) :: IRWDIR, IRCD, IRU10, IRHS, IRTP, IRT1, IRPHIAW, IRPHIOC, IRTAUOC + INTEGER(KIND=JWIM) :: IRHSWS, IRT1WS, IRBATHY + INTEGER(KIND=JWIM) :: IRALTHS, IRALTHSC, IRALTRC + INTEGER(KIND=JWIM) :: IFRSTPARTI + INTEGER(KIND=JWIM) :: IPFGTBL(JPPFLAG + 1) + INTEGER(KIND=JWIM), PARAMETER :: KDEL = 1 + INTEGER(KIND=JWIM), PARAMETER :: MDEL = 1 + INTEGER(KIND=JWIM) :: IPRMINFO(JPPFLAG, NIPRMINFO) + INTEGER(KIND=JWIM) :: ITOBOUT(JPPFLAG) + INTEGER(KIND=JWIM), ALLOCATABLE, DIMENSION(:, :) :: INFOBOUT + + !* VARIABLE. TYPE. PURPOSE. + ! --------- ------- -------- + ! *NTRAIN* INTEGER MAXIMUM NUMBER OF SWELL TRAINS. + ! *NREAL* INTEGER NUMBER OF REAL FIELDS IN RESTART FILE + ! *NIPRMINFO* INTEGER NUMBER OF AUXILLIARY INFORMATION ITEMS ON OUTPUT INTEGRATED PARAMETERS + ! *NINFOBOUT* INTEGER NUMBER OF AUXILLIARY INFORMATION NEEDED TO ENCODE IN GRIB THE INTEGRATED PARAMETERS + ! *COUTT* CHAR*14 OUTPUT TIMES. + ! *COUTLST* CHAR*14 LAST OUTPUT TIME. + ! *COUTS* CHAR*14 OUTPUT TIMES FOR THE SPECTRA. + ! *CASS* CHAR*14 ASSIMILATION TIMES. + ! *COUTNAME CHAR*33 NAME OF THE OUTPUT VARIABLES + ! *COUTDESCRIPTION CHAR*256 CHARACTER DESCRIPTION OF THE OUTPUT VARIABLES + ! *FFLAG* LOGICAL FILE OUTPUT FLAG FOR EACH OUTPUT TYPE. + ! *FFLAG20* LOGICAL .TRUE. IF OUTPUT IS WRITTEN TO UNIT IU20. + ! *GFLAG* LOGICAL GRIB OUTPUT FLAG FOR EACH OUTPUT TYPE. + ! *GFLAG20* LOGICAL .TRUE. IF OUTPUT IS GRIBBED TO UNIT IU30. + ! *NFLAG* LOGICAL NORM OUTPUT FLAG FOR EACH OUTPUT TYPE. + ! *NFLAGALL* LOGICAL .TRUE. IF NORM OUTPUT IS REQUESTED. + ! *UFLAG* LOGICAL FLAG WHETHER OUTPUT GRID FIELD IS USED + ! IN THE ASSIMILATION SCHEME + ! *LFDB* LOGICAL .TRUE. IF OUTPUT IS SENT TO FDB. + ! *LOUTINT* LOGICAL .TRUE. IF OUTINT WAS CALLED. + ! *NGOUT* INTEGER NUMBER OF OUTPUT POINTS. + ! *IJAR* INTEGER GRIDPOINT NUMBER OF OUTPUT POINT. + ! *NOUTT* INTEGER NUMBER OF OUTPUT TIMES. + ! *NOUTS* INTEGER NUMBER OF OUTPUT TIMES FOR THE SPECTRA. + ! *NASS* INTEGER NUMBER OF ASSIMILATION TIMES. + ! *IPFGTBL* INTEGER TABLE THAT ASSOCIATES EACH INTEGRATED OUTPUT PARAMETER + ! WITH A SPECIFIC PROCESSOR. IF SET TO -1, IT MEANS THAT + ! THE PARAMETER IS ONLY NEEDED FOR NORM CALCULATION. + ! *IRWDIR* INTEGER INDEX IN IPFGTBL OF WIND DIRECTION + ! *IRCD* INTEGER INDEX IN IPFGTBL OF CD + ! *IRU10* INTEGER INDEX IN IPFGTBL OF U10 + ! *IRHS* INTEGER INDEX IN IPFGTBL OF HS + ! *IRTP* INTEGER INDEX IN IPFGTBL OF TP + ! *IRT1* INTEGER INDEX IN IPFGTBL OF T1 + ! *IRPHIAW* INTEGER INDEX IN IPFGTBL OF PHIAW + ! *IRPHIOC* INTEGER INDEX IN IPFGTBL OF PHIOC + ! *IRTAUOC* INTEGER INDEX IN IPFGTBL OF TAUOC + ! *IRHSWS* INTEGER INDEX IN IPFGTBL OF HS WINDSEA + ! *IRT1WS* INTEGER INDEX IN IPFGTBL OF T1 WINDSEA + ! *IRBATHY* INTEGER INDEX IN IPFGTBL OF WATER DEPTH + ! *IRALTHS* INTEGER INDEX IN IPFGTBL OF ALTIMETER HS + ! *IRALTHSC* INTEGER INDEX IN IPFGTBL OF ALTIMETER HS CORRECTED + ! *IRALTRC* INTEGER INDEX IN IPFGTBL OF ALTIMETER RANGE CORRECTION + ! *IFRSTPARTI*INTEGER INDEX IN IPFGTBL OF THE FIRST PARTITONED PARAMETERS + ! *KDEL* INTEGER NUMBER OF DIRECTIONS THAT WILL BE WRITTEN + ! OUT/READ IN WHEN BINARY SPECTRA ARE PRODUCED + ! *MDEL* INTEGER NUMBER OF FREQUENCIES THAT WILL BE WRITTEN + ! OUT/READ IN WHEN BINARY SPECTRA ARE PRODUCED + ! *LWFLUXOUT* LOGICAL TRUE IF THE OCEAN FLUXES ARE OUTPUT PARAMETERS. + ! *LSECONDORDER* TRUE IF SECOND ORDER CORRECTION IS COMPUTED + ! FOR OUTPUT INTEGRATED PARAMETERS. + ! *LRSTST0 LOGICAL TRUE IF GRIB HEADER HAVE TO BE RESET + ! SUCH THAT THE FORECAST STEP POINTS TO + ! THE START OF THE RUN. + ! *LWAMANOUT* LOGICAL CONTROLS WHETHER FIELDS WILL BE WRITTEN AT + ! ANALYSIS TIME OR NOT. (USEFUL WHEN WAVE DATA + ! ASSIMILATION IS DONE IN MORE THAN ONE TRAJECTORY.) + ! *LRSTPARALR*LOGICAL TRUE WILL READ BINARY RESTART FILES IN PARALLEL (i.e. PER MPI TASK) + ! *LRSTPARALW*LOGICAL TRUE WILL WRITE BINARY RESTART FILES IN PARALLEL (i.e. PER MPI TASK) + ! *LRSTINFDAT*LOGICAL TRUE WILL WRITE AN ADDITIONAL wamfile WITH DATE/TIME INFO + ! *LLPARTITION* TRUE IF ANY SWELL PARTITION PARAMETER IS TO BE OUPUT + ! *NWRTOUTWAM INTEGER CONTROLS THE STRIDE WITH WHICH FDB OUTPUT PE's + ! ARE SELECTED (BY DEFAULT = 1) + ! *NIPRMOUT* INTEGER ACTUAL TOTAL NUMBER OF OUTPUT INTEGRATED PARAMETERS + ! *IPRMINFO* INTEGER AUXILIARY INFORMATION FOR OUTPUT OF INTEGRATED PARAMETERS + ! IPRMINFO(:,1) : GRIB TABLE NUMBER. + ! IPRMINFO(:,2) : GRIB PARAMETER IDENTIFIER. + ! IPRMINFO(:,3) : GRIB REFERENCE LEVEL IN FULL METER. + ! IPRMINFO(:,4) : 1 IF SEA ICE MASK IS IMPOSED ON OUTPUT FIELD. + ! IPRMINFO(:,5) : 1 IF TOO SHALLOW POINTS ARE SET TO MISSING. + ! *ITOBOUT* INTEGER GIVES THE INDEX IN BOUT OF THE INTEGRATED FIELDS THAT ARE ACTUALLY OUTPUT + ! *INFOBOUT* AUXILIARY INFORMATION TO ENCODE INTEGRATED PARAMETERS IN GRIB + ! INFOBOUT(:,1) : GRIB TABLE NUMBER. + ! INFOBOUT(:,2) : GRIB PARAMETER IDENTIFIER. + ! INFOBOUT(:,3) : GRIB REFERENCE LEVEL IN FULL METER. + ! *LWAM_USE_IO_SERV* LOGICAL CONTROLS WHETHER WAVE MODEL SHOULD USE IFS IO SERVER + ! *LOUTMDLDCP* LOGICAL, CONTROLS WHETHER THE MODEL MPI DECOMPOSITION IS WRITTEN OUT TO A FILE (see OUTMDLDCP) + ! ---------------------------------------------------------------------- +!$acc declare create( LWFLUXOUT ) +END MODULE YOWCOUT diff --git a/src/phys-scc-cuf-hoist/yowfred.cuf_hoist_new.F90 b/src/phys-scc-cuf-hoist/yowfred.cuf_hoist_new.F90 new file mode 100644 index 00000000..9dabf803 --- /dev/null +++ b/src/phys-scc-cuf-hoist/yowfred.cuf_hoist_new.F90 @@ -0,0 +1,219 @@ +! (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. +! +MODULE YOWFRED + + USE PARKIND_WAVE, ONLY: JWIM, JWRB, JWRU + USE YOWDRVTYPE, ONLY: FREQUENCY_LAND + + IMPLICIT NONE + + !* ** *FREDIR* - FREQUENCY AND DIRECTION GRID. + +!$loki dimension( NFRE ) + REAL(KIND=JWRB), ALLOCATABLE :: FR(:) +!$loki dimension( NFRE ) + REAL(KIND=JWRB), ALLOCATABLE :: DFIM(:) +!$loki dimension( NFRE ) + REAL(KIND=JWRB), ALLOCATABLE :: RHOWG_DFIM(:) +!$loki dimension( NFRE ) + REAL(KIND=JWRB), ALLOCATABLE :: DFIM_SIM(:) +!$loki dimension( NFRE ) + REAL(KIND=JWRB), ALLOCATABLE :: DFIMOFR(:) +!$loki dimension( NFRE ) + REAL(KIND=JWRB), ALLOCATABLE :: DFIMOFR_SIM(:) +!$loki dimension( NFRE ) + REAL(KIND=JWRB), ALLOCATABLE :: DFIM_END_L(:) +!$loki dimension( NFRE ) + REAL(KIND=JWRB), ALLOCATABLE :: DFIM_END_U(:) +!$loki dimension( NFRE ) + REAL(KIND=JWRB), ALLOCATABLE :: DFIMFR(:) +!$loki dimension( NFRE ) + REAL(KIND=JWRB), ALLOCATABLE :: DFIMFR_SIM(:) +!$loki dimension( NFRE ) + REAL(KIND=JWRB), ALLOCATABLE :: DFIMFR2(:) +!$loki dimension( NFRE ) + REAL(KIND=JWRB), ALLOCATABLE :: DFIMFR2_SIM(:) +!$loki dimension( NFRE ) + REAL(KIND=JWRB), ALLOCATABLE :: GOM(:) +!$loki dimension( NFRE ) + REAL(KIND=JWRB), ALLOCATABLE :: C(:) + REAL(KIND=JWRB) :: DELTH + REAL(KIND=JWRB) :: DELTR +!$loki dimension( NFRE ) + REAL(KIND=JWRB), ALLOCATABLE :: TH(:) +!$loki dimension( NFRE ) + REAL(KIND=JWRB), ALLOCATABLE :: COSTH(:) +!$loki dimension( NFRE ) + REAL(KIND=JWRB), ALLOCATABLE :: SINTH(:) +!$loki dimension( NFRE ) + REAL(KIND=JWRB), ALLOCATABLE :: ZPIFR(:) +!$loki dimension( NFRE ) + REAL(KIND=JWRB), ALLOCATABLE :: FR5(:) +!$loki dimension( NFRE ) + REAL(KIND=JWRB), ALLOCATABLE :: FRM5(:) +!$loki dimension( NFRE ) + REAL(KIND=JWRB), ALLOCATABLE :: COFRM4(:) + +!$loki dimension( NFRE ) + REAL(KIND=JWRB), ALLOCATABLE :: FLMAX(:) + + TYPE(FREQUENCY_LAND) :: WVPRPT_LAND + + + REAL(KIND=JWRB), PARAMETER :: FRATIO = 1.1_JWRB + REAL(KIND=JWRB), PARAMETER :: WETAIL = 0.25_JWRB + REAL(KIND=JWRB), PARAMETER :: FRTAIL = 0.2_JWRB + REAL(KIND=JWRB), PARAMETER :: WP1TAIL = 1.0_JWRB / 3.0_JWRB + REAL(KIND=JWRB), PARAMETER :: WP2TAIL = 0.5_JWRB + 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 + 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 + REAL(KIND=JWRB), PARAMETER :: XKL_GC = 20000.0_JWRB + +!$loki dimension( NWAV_GC ) + REAL(KIND=JWRB), ALLOCATABLE :: XK_GC(:) +!$loki dimension( NWAV_GC ) + REAL(KIND=JWRB), ALLOCATABLE :: XKM_GC(:) +!$loki dimension( NWAV_GC ) + REAL(KIND=JWRB), ALLOCATABLE :: OMEGA_GC(:) +!$loki dimension( NWAV_GC ) + REAL(KIND=JWRB), ALLOCATABLE :: OMXKM3_GC(:) +!$loki dimension( NWAV_GC ) + REAL(KIND=JWRB), ALLOCATABLE :: VG_GC(:) +!$loki dimension( NWAV_GC ) + REAL(KIND=JWRB), ALLOCATABLE :: C_GC(:) +!$loki dimension( NWAV_GC ) + REAL(KIND=JWRB), ALLOCATABLE :: CM_GC(:) +!$loki dimension( NWAV_GC ) + REAL(KIND=JWRB), ALLOCATABLE :: C2OSQRTVG_GC(:) +!$loki dimension( NWAV_GC ) + REAL(KIND=JWRB), ALLOCATABLE :: XKMSQRTVGOC2_GC(:) +!$loki dimension( NWAV_GC ) + REAL(KIND=JWRB), ALLOCATABLE :: OM3GMKM_GC(:) +!$loki dimension( NWAV_GC ) + REAL(KIND=JWRB), ALLOCATABLE :: DELKCC_GC(:) +!$loki dimension( NWAV_GC ) + REAL(KIND=JWRB), ALLOCATABLE :: DELKCC_GC_NS(:) +!$loki dimension( NWAV_GC ) + REAL(KIND=JWRB), ALLOCATABLE :: DELKCC_OMXKM3_GC(:) + + REAL(KIND=JWRB), PARAMETER :: FRIC = 28.0_JWRB + REAL(KIND=JWRB), PARAMETER :: OLDWSFC = 1.2_JWRB + REAL(KIND=JWRB) :: FLOGSPRDM1 + + !* VARIABLE. TYPE. PURPOSE. + ! --------- ------- -------- + ! *FR* REAL FREQUENCIES IN HERTZ. + ! *DFIM* REAL FREQUENCY INTERVAL*DIRECTION INTERVAL. + ! FOR TRAPEZOIDAL RULE + ! *RHOWG_DFIM*REAL FREQUENCY INTERVAL*DIRECTION INTERVAL TIMES WATER DENSITY AND G. + ! *DFIM_SIM* REAL FREQUENCY INTERVAL*DIRECTION INTERVAL. + ! FOR SIMPSON RULE + ! *DFIMOFR* REAL DFIM/FR + ! *DFIMOFR_SIMREAL DFIM_SIM/FR + ! *DFIM_END_L REAL FREQUENCY INTERVAL*DIRECTION INTERVAL + ! FOR LOWER BOUND FOR TRAPEZOIDAL INTEGRATION WHERE + ! DFIM IS USED IN BETWEEN DFIM_END_L AND DFIM_END_U + ! *DFIM_END_U REAL FREQUENCY INTERVAL*DIRECTION INTERVAL + ! FOR UPPER BOUND FOR TRAPEZOIDAL INTEGRATION WHERE + ! DFIM IS USED IN BETWEEN DFIM_END_L AND DFIM_END_U + ! *DFIMFR* REAL DFIM*FR + ! *DFIMFR_SIM REAL DFIM_SIM*FR + ! *DFIMFR2* REAL DFIM*FR**2 + ! *DFIMFR2_SIMREAL DFIM_SIM*FR**2 + ! *GOM* REAL DEEP WATER GROUP VELOCITIES (M/S). + ! *C* REAL DEEP WATER PHASE VELOCITIES (M/S). + ! *DELTH* REAL ANGULAR INCREMENT OF SPECTRUM (RADIANS). + ! *DELTR* REAL DELTH TIMES RADIUS OF EARTH (METRES). + ! *TH* REAL DIRECTIONS IN RADIANS. + ! *COSTH* REAL COS OF DIRECTION. + ! *SINTH* REAL SIN OF DIRECTION. + ! *ZPIFR* REAL ZPI*FR(M) + ! *FR5* REAL FR(M)**5 + ! *FRM5* REAL (1./FR(M))**5 + ! *COFRM4* REAL COEF4*G*FR(M)**(-4.) + ! *FLMAX* REAL MAXIMUM SPECTRAL COMPONENT ALLOWED. + ! (ALPHAPMAX/PI) (G**2/(2PI)**4) FR(M)**-5 + ! ALPHAPMAX MAXIMUM PHILLIPS PARAMETER (SEE YOWPHYS). + ! *WVPRPT_LAND* FICTIOUS VALUE FOR LAND POINT (NSUP+1) + ! *FRATIO* REAL FREQUENCY RATIO. + ! *WETAIL* REAL WAVE ENERGY TAIL CONSTANT FACTOR. + ! *FRTAIL* REAL FREQUENCY TAIL CONSTANT FACTOR. + ! *WP1TAIL* REAL PERIOD 1 TAIL CONSTANT FACTOR. + ! *WP2TAIL* REAL PERIOD 2 TAIL CONSTANT FACTOR. + ! *QPTAIL* REAL GODA TAIL CONSTANT FACTOR. + ! *COEF4* REAL COEFFICIENT USED TO COMPUTE THE SPECTRAL + ! LIMITER IN IMPLSCH. + + ! *XKMSS_CUTOFF* IF DIFFERENT FROM 0., SETS THE MAXIMUM WAVE NUMBER TO BE USED IN + ! THE CALCULATION OF THE MEAN SQUARE SLOPE. + + ! *NWAV_GC* INTEGER TOTAL NUMBER OF DISCRETISED WAVE NUMBER OF THE GRAVITY-CAPILLARY SPECTRUM. + ! *KRATIO_GC* REAL WAVE NUMBER RATIO FOR THE GRAVITY-CAPILLARY SPECTRUM. + ! *XKS_GC* REAL WAVE NUMBER LOWER LIMIT FOR THE GRAVITY-CAPILLARY SPECTRUM. + ! *XKL_GC* REAL WAVE NUMBER UPPER LIMIT FOR THE GRAVITY-CAPILLARY SPECTRUM. + + ! *XK_GC* WAVE NUMBER OF THE GRAVITY-CAPILLARY SPECTRUM. + ! *XKM_GC* 1 / XK_GC + ! *OMEGA_GC* ANGULAR FREQUENCY OF THE GRAVITY-CAPILLARY SPECTRUM. + ! *OMXKM3_GC* OMEGA_GC * XKM_GC**3 + ! *VG_GC* GROUP VELOCITY OF THE GRAVITY-CAPILLARY SPECTRUM. + ! *C_GC* PHASE VELOCITY OF THE GRAVITY-CAPILLARY SPECTRUM. + ! *CM_GC* 1 / C_GC + ! *C2OSQRTVG_GC* C_GC**2/SQRT(VG_GC) + ! *XKMSQRTVGOC2_GC* XKM_GC * SQRT(VG_GC)/C_GC**2 + ! *OM3GMKM_GC* OMEGA_GC**3 / (g*XK_GC) + ! *DELKCC_GC* WAVE NUMBER OF THE GRAVITY-CAPILLARY SPECTRUM SPACING / C2OSQRTVG_GC + ! *DELKCC_GC_NS* WAVE NUMBER OF THE GRAVITY-CAPILLARY SPECTRUM SPACING for index NS / C2OSQRTVG_GC + ! *DELKCC_OMXKM3_GC* DELKCC_GC * OMXKM3_GC + + + ! *FRIC* REAL COEFFICIENT RELATING THE PIERSON-MOSKOVITCH + ! ANGULAR FREQUENCY OF THE SPECTRAL PEAK + ! TO THE FRICTION VELOCITY: + ! OMEGA_PM=G/(FRIC*USTAR) + ! *OLDWSFC* REAL OLD WIND SEA FACTOR USED TO DETERMINE THE THRESHOLD + ! FOR WINDSEA/SWELL SEPARATION + ! *FLOGSPRDM1* REAL FLOGSPRDM1=1./LOG10(FRATIO) + ! ---------------------------------------------------------------------- +!$acc declare create( COFRM4 ) +!$acc declare create( FLMAX ) +!$acc declare create( FLOGSPRDM1 ) +!$acc declare create( RHOWG_DFIM ) +!$acc declare create( DFIMFR ) +!$acc declare create( DFIMOFR ) +!$acc declare create( DFIMFR2 ) +!$acc declare create( DFIM_SIM ) +!$acc declare create( FR ) +!$acc declare create( DFIM ) +!$acc declare create( COSTH ) +!$acc declare create( SINTH ) +!$acc declare create( ZPIFR ) +!$acc declare create( FR5 ) +!$acc declare create( TH ) +!$acc declare create( DELTH ) +!$acc declare create( OMXKM3_GC ) +!$acc declare create( CM_GC ) +!$acc declare create( C2OSQRTVG_GC ) +!$acc declare create( XKMSQRTVGOC2_GC ) +!$acc declare create( OM3GMKM_GC ) +!$acc declare create( DELKCC_GC_NS ) +!$acc declare create( DELKCC_OMXKM3_GC ) +!$acc declare create( OMEGA_GC ) +!$acc declare create( XK_GC ) +!$acc declare create( NWAV_GC ) +!$acc declare create( XKM_GC ) +END MODULE YOWFRED diff --git a/src/phys-scc-cuf-hoist/yowice.cuf_hoist_new.F90 b/src/phys-scc-cuf-hoist/yowice.cuf_hoist_new.F90 new file mode 100644 index 00000000..2d1e3595 --- /dev/null +++ b/src/phys-scc-cuf-hoist/yowice.cuf_hoist_new.F90 @@ -0,0 +1,83 @@ +! (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. +! +MODULE YOWICE + + USE PARKIND_WAVE, ONLY: JWIM, JWRB, JWRU + + IMPLICIT NONE + + !* ** *ICE* ICE POINTS + + + INTEGER(KIND=JWIM) :: IPARAMCI + INTEGER(KIND=JWIM) :: NICT, NICH + + REAL(KIND=JWRB), PARAMETER :: FLMIN = 0.00001_JWRB + ! MINIMUM ENERGY IN SPECTRAL BINS + REAL(KIND=JWRB) :: CITHRSH + REAL(KIND=JWRB) :: CIBLOCK + REAL(KIND=JWRB) :: CITHRSH_SAT + REAL(KIND=JWRB) :: CITHRSH_TAIL + REAL(KIND=JWRB) :: CDICWA + REAL(KIND=JWRB) :: TICMIN, HICMIN + REAL(KIND=JWRB) :: DTIC, DHIC + REAL(KIND=JWRB), ALLOCATABLE :: CIDEAC(:, :) + + LOGICAL :: LICERUN + LOGICAL :: LICETH + LOGICAL :: LMASKICE + LOGICAL :: LWAMRSETCI + LOGICAL :: LCIWABR + + !-------------------------------------------------------------------- + + !* VARIABLE TYPE PURPOSE + ! -------- ---- ------- + ! IPARAMCI INTEGER GRIB PARAMETER VALUE OF SEA ICE FRACTION OR SST. + ! NICT INTEGER FIRST DIMENSION (WAVE PERIOD) OF TABLE CIDEAC. + ! NICH INTEGER SECOND DIMENSION (ICE THICKNESS) OF TABLE CIDEAC. + ! FLMIN REAL ABSOLUTE MINIMUM VALUE + ! OF EACH SPECTRAL COMPONENTS. + ! CITHRSH REAL SEA ICE TRESHOLD, ALL SEA POINTS WITH CICOVER > CITHRSH + ! WILL BE SET TO MISSING + ! WHEN LMASKICE IS TRUE IT IS DONE AT ALL TIME STEP + ! WHEN IT IS FALSE IT IS !ONLY! DONE FOR THE OUTPUT OF + ! THE WAVE INTEGRATED PARAMETERS. + ! CIBLOCK REAL IF LMASKICE : FULL BLOCKING SEA ICE TRESHOLD, ALL SEA POINTS WITH CICOVER > CIBLOCK + ! AND THRESHOLD OVER WHICH FIELDS THAT ARE EXCHANGED WITH THE ATMOSPHERE AND THE OCEAN + ! ARE RESET. + ! CITHRSH_SAT REAL SEA ICE TRESHOLD FOR DATA ASSIMILATION, WHICH WILL ONLY BE DONE FOR + ! ALL SEA POINTS WITH CICOVER < CITHRSH_SAT + ! CITHRSH_TAIL REAL SEA ICE TRESHOLD FOR IMPOSITION OF SPECTRAL TAIL, + ! FOR ALL SEA POINTS WITH CICOVER < CITHRSH_TAIL + ! CDICWA REAL DRAG COEFFICIENT ICE-WATER. + ! TICMIN REAL MINIMUM WAVE PERIOD IN TABLE CIDEAC. + ! HICMIN REAL MINIMUM ICE THICKNESS IN TABLE CIDEAC. + ! DTIC REAL WAVE PERIOD INCREMENT IN TABLE CIDEAC. + ! DHIC REAL ICE THICKNESS INCREMENT IN TABLE CIDEAC. + ! CIDEAC REAL SEA ICE DIMENSIONLESS ENERGY ATTENUATION COEFFICIENT TABLE. + ! LICERUN LOGICAL SET TO TRUE IF SEA ICE IS TAKEN INTO ACCOUNT. + ! LICETH LOGICAL SET TO TRUE IF SEA ICE THICKNESS IS PART OF THE INPUT DATA. + ! LMASKICE LOGICAL SET TO TRUE IF ICE MASK IS APPLIED (SEE CITHRSH) + ! NOTE THAT THE MASK IS ALWAYS APPLIED FOR SATELLITE + ! DATA PROCESSING AS WELL AS FOR CHARNOCK THAT + ! IS RETURNED TO THE IFS. + ! LWAMRSETCI LOGICAL SET TO TRUE IF FIELDS THAT ARE EXCHANGED WITH THE ATMOSPHERE AND THE OCEAN + ! ARE RESET TO WHAT WOULD BE USED IF THERE WERE NO WAVE MODELS. + ! LCIWABR LOGICAL SET TO TRUE IF SEA ICE BOTTOM FRICTION ATTENUATION IS USED. + !-------------------------------------------------------------------- +!$acc declare create( LCIWABR ) +!$acc declare create( LMASKICE ) +!$acc declare create( CDICWA ) +!$acc declare create( CIBLOCK ) +!$acc declare create( CITHRSH_TAIL ) +!$acc declare create( LICERUN ) +!$acc declare create( LWAMRSETCI ) +!$acc declare create( CITHRSH ) +END MODULE YOWICE diff --git a/src/phys-scc-cuf-hoist/yowindn.cuf_hoist_new.F90 b/src/phys-scc-cuf-hoist/yowindn.cuf_hoist_new.F90 new file mode 100644 index 00000000..36e9861e --- /dev/null +++ b/src/phys-scc-cuf-hoist/yowindn.cuf_hoist_new.F90 @@ -0,0 +1,130 @@ +! (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. +! +MODULE YOWINDN + + USE PARKIND_WAVE, ONLY: JWIM, JWRB, JWRU + + IMPLICIT NONE + + !* ** *INDNL* - INDICES AND WEIGHTS USED IN THE COMPUTATION + ! OF THE NONLINEAR TRANSFER RATE. + + INTEGER(KIND=JWIM), PARAMETER :: NINL = 5 + INTEGER(KIND=JWIM), PARAMETER :: NRNL = 25 + INTEGER(KIND=JWIM) :: KFRH + INTEGER(KIND=JWIM) :: MFRSTLW + INTEGER(KIND=JWIM) :: MLSTHG + +!$loki dimension( MFRSTLW:MLSTHG ) + INTEGER(KIND=JWIM), ALLOCATABLE :: IKP(:) +!$loki dimension( MFRSTLW:MLSTHG ) + INTEGER(KIND=JWIM), ALLOCATABLE :: IKP1(:) +!$loki dimension( MFRSTLW:MLSTHG ) + INTEGER(KIND=JWIM), ALLOCATABLE :: IKM(:) +!$loki dimension( MFRSTLW:MLSTHG ) + INTEGER(KIND=JWIM), ALLOCATABLE :: IKM1(:) +!$loki dimension( NANG,2 ) + INTEGER(KIND=JWIM), ALLOCATABLE :: K1W(:, :) +!$loki dimension( NANG,2 ) + INTEGER(KIND=JWIM), ALLOCATABLE :: K2W(:, :) +!$loki dimension( NANG,2 ) + INTEGER(KIND=JWIM), ALLOCATABLE :: K11W(:, :) +!$loki dimension( NANG,2 ) + INTEGER(KIND=JWIM), ALLOCATABLE :: K21W(:, :) +!$loki dimension( NINL,1:MLSTHG ) + INTEGER(KIND=JWIM), ALLOCATABLE :: INLCOEF(:, :) + +!$loki dimension( MFRSTLW:MLSTHG ) + REAL(KIND=JWRB), ALLOCATABLE :: AF11(:) +!$loki dimension( MFRSTLW:MLSTHG ) + REAL(KIND=JWRB), ALLOCATABLE :: FKLAP(:) +!$loki dimension( MFRSTLW:MLSTHG ) + REAL(KIND=JWRB), ALLOCATABLE :: FKLAP1(:) +!$loki dimension( MFRSTLW:MLSTHG ) + REAL(KIND=JWRB), ALLOCATABLE :: FKLAM(:) +!$loki dimension( MFRSTLW:MLSTHG ) + REAL(KIND=JWRB), ALLOCATABLE :: FKLAM1(:) + REAL(KIND=JWRB) :: ACL1 + REAL(KIND=JWRB) :: ACL2 + REAL(KIND=JWRB) :: CL11 + REAL(KIND=JWRB) :: CL21 + REAL(KIND=JWRB) :: DAL1 + REAL(KIND=JWRB) :: DAL2 +!$loki dimension( KFRH ) + REAL(KIND=JWRB), ALLOCATABLE :: FRH(:) +!$loki dimension( MFRSTLW:1 ) + REAL(KIND=JWRB), ALLOCATABLE :: FTRF(:) +!$loki dimension( NRNL,1:MLSTHG ) + REAL(KIND=JWRB), ALLOCATABLE :: RNLCOEF(:, :) + + !* VARIABLE. TYPE. PURPOSE. + ! --------- ------- ------- + ! *NINL* INTEGER SIZE OF INLCOEF + ! *NRNL* INTEGER SIZE OF RNLCOEF + ! *KFRH* INTEGER SIZE OF FRH + ! *MFRSTLW* INTEGER INDEX OF FIRST EXTRA LOW FREQUENCY FOR SNL + ! *MLSTHG* INTEGER INDEX OF LAST EXTRA HIGH FREQUENCY FOR SNL + ! *IKP* INTEGER FREQUENCY INDEX ARRAY FOR STORING ENERGY + ! TRANSFER INCREMENTS INTO BINS, WAVE NO. 3. + ! *IKP1* INTEGER IKP+1. + ! *IKM* INTEGER FREQUENCY INDEX ARRAY FOR STORING ENERGY + ! TRANSFER INCREMENTS INTO BINS, WAVE NO. 4. + ! *IKM1* INTEGER IKM+1 + ! *K1W* INTEGER ANGULAR INDEX ARRAY FOR STORING ENERGY + ! TRANSFER INCREMENTS INTO BINS, WAVE NO. 3. + ! *K11W* INTEGER K1W(.,1)-1, K1W(.,2)+1. + ! *K2W* INTEGER ANGULAR INDEX ARRAY FOR STORING ENERGY + ! TRANSFER INCREMENTS INTO BINS, WAVE NO. 4. + ! *K21W* INTEGER K2W(.,1)+1, K2W(.,2)-1. + ! *INLCOEF* INTEGER ARRAY USED TO STORE ALL FREQUENCY DEPENDENT + ! INDICES FOUND IN SNONLIN + ! *AF11* REAL WEIGHTS FOR DISCRETE APPROXIMATION OF NONL + ! TRANSFER (AT PRESENT ONE TERM ONLY SET TO + ! 3000). MULTIPLIED BY FREQUENCIES **11. + ! *FKLAP* REAL WEIGHT IN FREQUENCY GRID FOR INTERPOLATION, + ! WAVE NO. 3 ("1+LAMBDA" TERM). + ! *FKLAP1* REAL 1-FKLAP. + ! *FKLAM* REAL WEIGHT IN FREQUENCY GRID FOR INTERPOLATION, + ! WAVE NO. 4 ("1-LAMBDA" TERM). + ! *ACL1* REAL WEIGHT IN ANGULAR GRID FOR INTERPOLATION, + ! WAVE NO. 3 ("1+LAMBDA" TERM). + ! *ACL2* REAL WEIGHT IN ANGULAR GRID FOR INTERPOLATION, + ! WAVE NO. 4 ("1-LAMBDA" TERM). + ! *CL11* REAL 1.-ACL1. + ! *CL21* REAL 1.-ACL2. + ! *DAL1* REAL 1./ACL1. + ! *DAL2* REAL 1./ACL2. + ! *FRH* REAL TAIL FREQUENCY RATION **5 + ! *FTRF* REAL FRONT TAIL REDUCTIOn FACTOR USED TO A SPECTRAL + ! TAIL IN FRONT OF THE FIRST DISCRETISED FREQUENCY + ! *RNLCOEF* REAL ARRAY USED TO STORE ALL FREQUENCY DEPENDENT + ! COEFFICIENT FOUND IN SNONLIN + + ! ---------------------------------------------------------------------- +!$acc declare create( IKP ) +!$acc declare create( IKP1 ) +!$acc declare create( IKM ) +!$acc declare create( IKM1 ) +!$acc declare create( K1W ) +!$acc declare create( K2W ) +!$acc declare create( K11W ) +!$acc declare create( K21W ) +!$acc declare create( AF11 ) +!$acc declare create( FKLAP ) +!$acc declare create( FKLAP1 ) +!$acc declare create( FKLAM ) +!$acc declare create( FKLAM1 ) +!$acc declare create( DAL1 ) +!$acc declare create( DAL2 ) +!$acc declare create( MFRSTLW ) +!$acc declare create( MLSTHG ) +!$acc declare create( KFRH ) +!$acc declare create( INLCOEF ) +!$acc declare create( RNLCOEF ) +END MODULE YOWINDN diff --git a/src/phys-scc-cuf-hoist/yowparam.cuf_hoist_new.F90 b/src/phys-scc-cuf-hoist/yowparam.cuf_hoist_new.F90 new file mode 100644 index 00000000..b7c214b1 --- /dev/null +++ b/src/phys-scc-cuf-hoist/yowparam.cuf_hoist_new.F90 @@ -0,0 +1,101 @@ +! (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. +! +MODULE YOWPARAM + + USE PARKIND_WAVE, ONLY: JWIM, JWRB, JWRU + + IMPLICIT NONE + + INTEGER(KIND=JWIM), PARAMETER :: IMDLGRDID = 218 + INTEGER(KIND=JWIM), PARAMETER :: KWAMVER = 8 + INTEGER(KIND=JWIM), PARAMETER :: NANG_PARAM = 36 + + !* ** *PARAM* GENERAL GRID SIZE INFORMATION. + + INTEGER(KIND=JWIM) :: NANG + INTEGER(KIND=JWIM) :: NFRE + INTEGER(KIND=JWIM) :: NFRE_RED + INTEGER(KIND=JWIM) :: NFRE_ODD + INTEGER(KIND=JWIM) :: NGX + INTEGER(KIND=JWIM) :: NGY + INTEGER(KIND=JWIM) :: NIBLO + INTEGER(KIND=JWIM) :: NOVER + INTEGER(KIND=JWIM) :: NIBL1 + INTEGER(KIND=JWIM) :: NIBLD + INTEGER(KIND=JWIM) :: NIBLC + + REAL(KIND=JWRB) :: SWAMPWIND + REAL(KIND=JWRB) :: SWAMPWIND2 + REAL(KIND=JWRB) :: DTNEWWIND + REAL(KIND=JWRB) :: SWAMPCIFR + REAL(KIND=JWRB) :: SWAMPCITH + + CHARACTER(LEN=1) :: CLDOMAIN + + LOGICAL :: LTURN90 + LOGICAL :: LL1D + LOGICAL :: LWDINTS + + ! Moved here from yowunpool + LOGICAL :: LLUNSTR + LOGICAL :: LLR8TOR4 = .false. + ! Is input in fact legacy REAL*8 & NKIND == 4 ? + + !* VARIABLE. TYPE. PURPOSE. + ! --------- ------- -------- + ! *IMDLGRDID* INTEGER MODEL GRID IDENTIFICATION NUMBER. + ! IT SHOULD BE UPDATED ONLY IF NEW gridglou + ! AND ubufglou FILES ARE PRODUCED!!!! + ! *KWAMVER* INTEGER WAM SOFTWARE VERSION NUMBER. + ! *NANG* INTEGER NUMBER OF ANGLES. + ! *NFRE* INTEGER NUMBER OF FREQUENCIES FOR THE PHYSICS. + ! *NFRE_RED* INTEGER REDUCED NUMBER OF FREQUENCIES FOR THE PROPAGATION AND IO + ! BY DEFAULT = NFRE + ! *NFRE_ODD* INTEGER NFRE-1 IF NFRE EVEN, BUT NFRE IS NFRE ODD + ! *NGX* INTEGER NUMBER OF LONGITUDES IN GRID. + ! *NGY* INTEGER NUMBER OF LATITUDES IN GRID. + ! *NIBLO* INTEGER NUMBER OF SEA POINTS IN BLOCK. + ! *NOVER* INTEGER MAXIMUM NUMBER POINTS IN FIRST LATITUDE + ! OF BLOCKS. + ! *NIBL1* INTEGER = NIBLO IF MULTI BLOCK VERSION. + ! = 1 IF ONE BLOCK VERSION. + ! *NIBLD* INTEGER = NIBLO IF DEPTH OR CURRENT REFRACTION. + ! = 1 ELSE. + ! *NIBLC* INTEGER = NIBLO IF CURRENT REFRACTION. + ! = 1 ELSE. + ! *SWAMPWIND* REAL CONSTANT WIND SPEED USED TO RUN SWAMP CASE. + ! FIRST VALUE + ! *SWAMPWIND2*REAL CONSTANT WIND SPEED USED TO RUN SWAMP CASE. + ! SECOND VALUE PROVIDED IT'S NOT ZERO + ! *DTNEWWIND* REAL TIME AFTER WHICH SWAMPWIND2 IS APPLIED + ! IN HOURS + ! *SWAMPCIFR* REAL SEA ICE COVER FOR THE NORTHERN HALF OF THE SWAMP DOMAIN + ! *SWAMPCITH* REAL SEA ICE THICKNESS FOR THE NORTHERN HALF OF THE SWAMP DOMAIN + ! *LTURN90* LOGICAL IF TRUE THE NEW SWAMP WIND WILL BE TURNED + ! BY 90 DEGREES. + ! *LWDINTS* LOGICAL IF TRUE A FILE CONTAINING WIND SPEED (m/s) AND DIRECTION + ! (in degrees following the meteorological convention) + ! TIME SERIES WILL BY USED TO SET THE WIND FORCING + ! OVER THE ALL DOMAIN. + ! THE PRESENCE OF THE FILE, windforcing_time_series + ! WILL DETERMINE WHETHER OR NOT LWDINTS IS TRUE OR NOT + ! *CLDOMAIN* CHARACTER DEFINES THE DOMAIN OF THE MODEL (for the + ! FDB and for selection of some variables) + ! *LL1D* LOGICAL IF TRUE THEN THE DOMAIN DECOMPOSITION IS ONLY + ! DONE IN LATITUNAL BANDS + ! (like it used to be done). + ! ---------------------------------------------------------------------- +!$acc declare create( nang ) +!$acc declare create( nfre_red ) +!$acc declare create( ngy ) +!$acc declare create( niblo ) +!$acc declare create( LLUNSTR ) +!$acc declare create( NFRE_ODD ) +!$acc declare create( NFRE ) +END MODULE YOWPARAM diff --git a/src/phys-scc-cuf-hoist/yowpcons.cuf_hoist_new.F90 b/src/phys-scc-cuf-hoist/yowpcons.cuf_hoist_new.F90 new file mode 100644 index 00000000..05f9d91e --- /dev/null +++ b/src/phys-scc-cuf-hoist/yowpcons.cuf_hoist_new.F90 @@ -0,0 +1,133 @@ +! (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. +! +MODULE YOWPCONS + + USE PARKIND_WAVE, ONLY: JWIM, JWRB, JWRU + + IMPLICIT NONE + + !* *PARAMETER* OF GLOBAL CONSTANTS. + ! THE NON PARAMETRIC CONSTANTS WILL BE RESET BY CALLING INIWCST !!!! + + REAL(KIND=JWRB) :: G = 9.806_JWRB + REAL(KIND=JWRB) :: GM1 = 0.101978381_JWRB + REAL(KIND=JWRB), PARAMETER :: OLDPI = 3.1415927_JWRB + REAL(KIND=JWRB) :: PI = OLDPI + REAL(KIND=JWRB), PARAMETER :: CIRC = 40000000.0_JWRB + REAL(KIND=JWRB) :: ZPI = 6.2831854_JWRB + REAL(KIND=JWRB) :: THREEZPI = 18.849555922_JWRB + REAL(KIND=JWRB) :: ZPI4GM1 = 158.93794172_JWRB + REAL(KIND=JWRB) :: ZPI4GM2 = 16.208233910_JWRB + REAL(KIND=JWRB) :: ZPISQRT = 1.7724539_JWRB + REAL(KIND=JWRB) :: ZCONST = 0.0281349_JWRB + REAL(KIND=JWRB) :: RAD = 0.017453293_JWRB + REAL(KIND=JWRB) :: DEG = 57.295778667_JWRB + REAL(KIND=JWRB) :: R = 6366198.0_JWRB + REAL(KIND=JWRB), PARAMETER :: EPSMIN = 0.1E-32_JWRB + REAL(KIND=JWRB), PARAMETER :: DKMAX = 40.0_JWRB + REAL(KIND=JWRB), PARAMETER :: TAUOCMIN = 0.01_JWRB + REAL(KIND=JWRB), PARAMETER :: TAUOCMAX = 50.0_JWRB + REAL(KIND=JWRB), PARAMETER :: PHIEPSMIN = -3276.80_JWRB + REAL(KIND=JWRB), PARAMETER :: PHIEPSMAX = -0.05_JWRB + REAL(KIND=JWRB), PARAMETER :: WSEMEAN_MIN = 0.001_JWRB + REAL(KIND=JWRB) :: ZMISS = -999.0_JWRB + REAL(KIND=JWRB), PARAMETER :: ROAIR = 1.225_JWRB + REAL(KIND=JWRB), PARAMETER :: ROWATER = 1000.0_JWRB + REAL(KIND=JWRB), PARAMETER :: ROWATERM1 = 1.0_JWRB / ROWATER + REAL(KIND=JWRB), PARAMETER :: YEPS = ROAIR / ROWATER + REAL(KIND=JWRB), PARAMETER :: YINVEPS = 1.0_JWRB / YEPS + REAL(KIND=JWRB), PARAMETER :: GAM_SURF = 0.0717_JWRB + !!!! will need to be adapted if you change ROWATER + REAL(KIND=JWRB), PARAMETER :: SURFT = GAM_SURF / ROWATER + REAL(KIND=JWRB) :: SQRTGOSURFT + !! SQRT(G/SURFT) (see wavemdl) + REAL(KIND=JWRB), PARAMETER :: WSTAR0 = 0.0_JWRB + REAL(KIND=JWRB), PARAMETER :: Rconstant = 287.16_JWRB + ! The gas constant + REAL(KIND=JWRB), PARAMETER :: EpsWaterVapor = 0.61_JWRB + ! The mass ratio of water vapor to dry air + REAL(KIND=JWRB), PARAMETER :: EPSUS = 1.0E-6_JWRB + REAL(KIND=JWRB), PARAMETER :: EPSU10 = SQRT(1.0E-3_JWRB) + + REAL(KIND=JWRB), PARAMETER :: ACD = 8.0E-4_JWRB + REAL(KIND=JWRB), PARAMETER :: BCD = 8.0E-5_JWRB + + REAL(KIND=JWRB), PARAMETER :: ACDLIN = 0.0008_JWRB + REAL(KIND=JWRB), PARAMETER :: BCDLIN = 0.00047_JWRB + + REAL(KIND=JWRB), PARAMETER :: C1CD = 1.03E-3_JWRB + REAL(KIND=JWRB), PARAMETER :: C2CD = 0.04E-3_JWRB + REAL(KIND=JWRB), PARAMETER :: P1CD = 1.48_JWRB + REAL(KIND=JWRB), PARAMETER :: P2CD = -0.21_JWRB + + REAL(KIND=JWRB), PARAMETER :: CDMAX = 0.0025_JWRB + + REAL(KIND=JWRB), PARAMETER :: FM2FP = 0.9_JWRB + + !* VARIABLE. TYPE. PURPOSE. + ! --------- ------- -------- + ! *G* REAL ACCELLERATION OF GRAVITY. + ! *GM1* REAL 1/G. + ! *OLDPI* REAL OLD VALUE USED FOR PI (PRIOR TO CY21R3). + ! *PI* REAL PI (See SUB. INIWCST). + ! *CIRC* REAL EARTH CIRCUMFERENCE (METRES). + ! *RAD* REAL PI / 180. + ! *DEG* REAL 180. / PI. + ! *ZPI* REAL 2. * PI. + ! *ZPI4GM1* REAL ZPI**4/G* + ! *ZPI4GM2* REAL ZPI**4/G**2 + ! *ZPISQRT* REAL SQRT(PI) + ! *ZCONST* REAL 1./(8.*PI*SQRT(2.)) + ! *R* REAL EARTH RADIUS (METRES). + ! *EPSMIN* REAL SMALL NUMBER + ! *DKMAX* REAL MAXIMUM VALUE OF DEPTH*WAVENUMBER BEFORE + ! SIMPLIFYING TO DEEP WATER EXPRESIONS. + ! *BF2MAX* REAL MAXIMUM VALUE ALLOWED FOR BFI SQUARED + ! *BF2MIN* REAL MINIMUM VALUE ALLOWED FOR BFI SQUARED + ! *C4MAX* REAL MAXIMUM VALUE ALLOWED FOR KURTOSIS + ! *C4MIN* REAL MINIMUM VALUE ALLOWED FOR KUTOSIS + ! *PHIEPSMIN* REAL MINIMUM VALUE ALLOWED FOR NORMALISED ENERGY FLUX INTO OCEAN + ! *PHIEPSMAX* REAL MAXIMUM VALUE ALLOWED FOR NORMALISED ENERGY FLUX INTO OCEAN + ! *WSEMEAN_MIN* REAL MINIMUM VALUE ALLOWED FOR WSEMEAN + ! *ZMISS* REAL MISSING DATA INDICATOR + ! (SET IN CHIEF OR VIA THE IFS). + ! *ROAIR* REAL AIR DENSITY. + ! *ROWATER* REAL WATER DENSITY. + ! *ROWATERM1* REAL 1 /(WATER DENSITY). + ! *GAM_SURF* REAL SURFACE TENSION (in N/m) + ! *SURFT* REAL SURFACE TENSION divided by water density (in m**3 s**-2) + ! *YEPS* REAL ROAIR/ROWATER. + ! *YINVEPS* REAL 1./YEPS. + ! *WSTAR0* REAL DEFAULT VALUE FOR w*. + ! *EPSUS* REAL SMALL NUMBER ADDED TO THE SQUARE OF USTAR + ! WHEN COMPUTING CD OR THE CHARNOCK COEF. + ! *EPSU10* REAL SMALL NUMBER TO INSURE U10 IS NEVER 0 + + ! *ACD* REAL COEFFICIENTS FOR SIMPLE CD(U10) RELATION + ! *BCD* REAL CD = ACD + BCD*U10 + + ! *ACDLIN* REAL COEFFICIENTS FOR SIMPLE LINEARISED CD(U10,CHARNOCK) RELATION + ! *BCDLIN* REAL CD = ACDLIN + BCDLIN*SQRT(CHARNOCK) * U10 + + ! USE HERSBACH 2011 FOR CD(U10) (SEE ALSO EDSON et al. 2013) + ! C_D = (C1CD + C2CD*U10**P1CD)*U10**P2CD + + ! *CDMAX* REAL MAXIMUM CD ALLOWED FOR ALL CD(U10) RELATIONS + + ! *FM2FP* REAL EMPIRICAL FACTOR FOR THE CONVERSION OF WINDSEA MEAN FREQUENCY + ! TO WINDSEA PEAK FREQUENCY. + !---------------------------------------------------------------------- + +!$acc declare create( GM1 ) +!$acc declare create( ZPI ) +!$acc declare create( ZPI4GM1 ) +!$acc declare create( ZPI4GM2 ) +!$acc declare create( G ) +!$acc declare create( SQRTGOSURFT ) +END MODULE YOWPCONS diff --git a/src/phys-scc-cuf-hoist/yowphys.cuf_hoist_new.F90 b/src/phys-scc-cuf-hoist/yowphys.cuf_hoist_new.F90 new file mode 100644 index 00000000..9a260bd3 --- /dev/null +++ b/src/phys-scc-cuf-hoist/yowphys.cuf_hoist_new.F90 @@ -0,0 +1,195 @@ +! (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. +! +MODULE YOWPHYS + + !* ** *YOWPHYS* - PARAMETERS FOR WAVE PHYSICS PARAMETERISATION + + USE PARKIND_WAVE, ONLY: JWIM, JWRB, JWRU + + IMPLICIT NONE + + ! *XKAPPA* VON KARMAN CONSTANT. + REAL(KIND=JWRB), PARAMETER :: XKAPPA = 0.40_JWRB + ! *XNLEV* REAL WIND SPEED REFERENCE HEIGHT + REAL(KIND=JWRB), PARAMETER :: XNLEV = 10.0_JWRB + ! *RNU* KINEMATIC AIR VISCOSITY (when coupled get from the atmospheric model) + REAL(KIND=JWRB) :: RNU + ! *RNUM* REDUCED KINEMATIC AIR VISCOSITY FOR MOMENTUM TRANSFER (as RNU) + REAL(KIND=JWRB) :: RNUM + ! *PRCHAR* DEFAULT VALUE FOR CHARNOCK + REAL(KIND=JWRB) :: PRCHAR + + + + ! WIND INPUT :: + ! ========== + ! *BETAMAX* PARAMETER FOR WIND INPUT. + REAL(KIND=JWRB) :: BETAMAX + + ! *BETAMAXOXKAPPA2* BETAMAX/XKAPPA**2 + REAL(KIND=JWRB) :: BETAMAXOXKAPPA2 + + ! *BMAXOKAP* DELTA_THETA_RN * BETAMAXOXKAPPA2 /XKAPPA + REAL(KIND=JWRB) :: BMAXOKAP + + ! *BMAXOKAPDTH* BMAXOKAP * DELTH + REAL(KIND=JWRB) :: BMAXOKAPDTH + + ! *GAMNCONST* DELTA_THETA*0.5_JWRB*ZPI**4*GM1*3*BETAMAXOXKAPPA2/XKAPPA + REAL(KIND=JWRB) :: GAMNCONST + + ! *ZALP* SHIFTS GROWTH CURVE. + REAL(KIND=JWRB) :: ZALP + + ! *ALPHA* MINIMUM CHARNOCK CONSTANT WITH NO WAVES. + REAL(KIND=JWRB) :: ALPHA + REAL(KIND=JWRB) :: ALPHAMIN + ! MAXIMUM CHARNOCK + REAL(KIND=JWRB), PARAMETER :: ALPHAMAX = 0.11_JWRB + + ! *CHNKMIN_U* WIND THRESHOLD USED TO REDUCED MIN CHARNOCK (see *CHNKMIN*) + REAL(KIND=JWRB) :: CHNKMIN_U + + ! *TAUWSHELTER* SHELTERING COEFFICIENT in Ardhuin et al. PHYSICS + REAL(KIND=JWRB) :: TAUWSHELTER + + ! MAXIMUM PHILLIPS PARAMETER USED TO CONTROL MAXIMUM STEEPNESS + REAL(KIND=JWRB) :: ALPHAPMAX + + ! MINIMUM PHILLIPS PARAMETER ALLOWED : ALPHAPMINFAC/WAVE_AGE + REAL(KIND=JWRB), PARAMETER :: ALPHAPMINFAC = 0.1_JWRB + REAL(KIND=JWRB) :: FLMINFAC + + ! DIRECTIONALITY CORRECTION FACTORS IN THE GOWTH RATE RENORMALISATION (SEE JANSSEN ECMWF TECH MEMO 845) + REAL(KIND=JWRB) :: DELTA_THETA_RN + REAL(KIND=JWRB) :: RN1_RN + ! if LLCAPCHNK, DELTA_THETA_RN is enhanced by factor 1+DTHRN_A*(1+TANH(U10-DTHRN_U)) + ! This is intended to model the impact of unrepresented effects on the drag for very high winds + ! (i.e. spray, foam, etc...) + REAL(KIND=JWRB) :: DTHRN_A + REAL(KIND=JWRB) :: DTHRN_U + + ! 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)) + REAL(KIND=JWRB) :: TAILFACTOR + REAL(KIND=JWRB) :: TAILFACTOR_PM + + ! FOR THE GRAVITY-CAPILLARY MODEL, ONE NEEDS TO SPECIFY ANGULAR ADJUSTMENT ANG_GC (SEE *SETWAVPHYS*) + ! ANG_GC = ANG_GC_A + ANG_GC_B * TANH(ANG_GC_C * USTAR**2) + REAL(KIND=JWRB) :: ANG_GC_A, ANG_GC_B, ANG_GC_C + + ! Negative wind input, ARDHUIN et al. 2010: + REAL(KIND=JWRB), PARAMETER :: SWELLF = 0.66_JWRB + ! controls the turbulent swell dissipation + REAL(KIND=JWRB), PARAMETER :: SWELLF2 = -0.018_JWRB + REAL(KIND=JWRB), PARAMETER :: SWELLF3 = 0.022_JWRB + REAL(KIND=JWRB), PARAMETER :: SWELLF4 = 1.5E05_JWRB + REAL(KIND=JWRB) :: SWELLF5 + ! controls the viscous swell dissipation + REAL(KIND=JWRB), PARAMETER :: SWELLF6 = 1.0_JWRB + REAL(KIND=JWRB), PARAMETER :: SWELLF7 = 3.6E05_JWRB + REAL(KIND=JWRB), PARAMETER :: SWELLF7M1 = 1.0_JWRB / SWELLF7 + !!!! set it to 1 if you decide to have SWELLF7=0 + REAL(KIND=JWRB) :: Z0RAT + REAL(KIND=JWRB) :: Z0TUBMAX + + REAL(KIND=JWRB), PARAMETER :: ABMIN = 0.3_JWRB + REAL(KIND=JWRB), PARAMETER :: ABMAX = 8.0_JWRB + + + ! WHITECAP DISSIPATION :: + ! ==================== + + + ! Whitecap dissipation WAM cycle 4: + + REAL(KIND=JWRB) :: CDIS + REAL(KIND=JWRB) :: DELTA_SDIS + REAL(KIND=JWRB) :: CDISVIS + + + ! Whitecap dissipation, ARDHUIN et al. 2010: + ! TEST 473: + ! Br: + REAL(KIND=JWRB), PARAMETER :: SDSBR = 9.0E-4_JWRB + + ! Saturation dissipation coefficient + INTEGER(KIND=JWIM), PARAMETER :: ISDSDTH = 80_JWIM + INTEGER(KIND=JWIM), PARAMETER :: ISB = 2_JWIM + INTEGER(KIND=JWIM), PARAMETER :: IPSAT = 2_JWIM + + REAL(KIND=JWRB), PARAMETER :: SSDSC2 = -2.2E-5_JWRB + REAL(KIND=JWRB), PARAMETER :: SSDSC4 = 1.0_JWRB + REAL(KIND=JWRB), PARAMETER :: SSDSC6 = 0.3_JWRB + REAL(KIND=JWRB), PARAMETER :: MICHE = 1.0_JWRB + + + ! Cumulative dissipation coefficient + !!! REAL(KIND=JWRB), PARAMETER :: SSDSC3 = -0.40344_JWRB + !!! This is quite an expensive computation. Setting it to 0 will disable its calculation. + !!! It was found that if the high frequency tail is prescribed (see frcutindex), + !!! then the results are very similar. + !!! Converserly, it will be required, in particular for the wave modified fluxes to NEMO + !!! when the high frequency tail is not prescribed and used in all calculation + REAL(KIND=JWRB), PARAMETER :: SSDSC3 = 0.0_JWRB + REAL(KIND=JWRB), PARAMETER :: SSDSBRF1 = 0.5_JWRB + ! 28.16 = 22.0 * 1.6² * 1/2 with + ! 22.0 (Banner & al. 2000, figure 6) + ! 1.6 the coefficient that transforms SQRT(B) to Banner et al. (2000)'s epsilon + ! 1/2 factor to correct overestimation of Banner et al. (2000)'s breaking probability due to zero-crossing analysis + REAL(KIND=JWRB), PARAMETER :: BRKPBCOEF = 28.16_JWRB + + ! Wave-turbulence interaction coefficient + REAL(KIND=JWRB), PARAMETER :: SSDSC5 = 0.0_JWRB + + ! NSDSNTH is the number of directions on both used to compute the spectral saturation + INTEGER(KIND=JWIM) :: NSDSNTH + ! NDIKCUMUL is the integer difference in frequency bands + INTEGER(KIND=JWIM) :: NDIKCUMUL + +!$loki dimension( NANG,NSDSNTH*2+1 ) + INTEGER(KIND=JWIM), ALLOCATABLE :: INDICESSAT(:, :) +!$loki dimension( NANG,NSDSNTH*2+1 ) + REAL(KIND=JWRB), ALLOCATABLE :: SATWEIGHTS(:, :) +!$loki dimension( NDEPTH,0:NANG/2,NFRE,NFRE ) + REAL(KIND=JWRB), ALLOCATABLE :: CUMULW(:, :, :, :) + ! ---------------------------------------------------------------------- +!$acc declare create( DTHRN_A ) +!$acc declare create( DTHRN_U ) +!$acc declare create( ALPHAPMAX ) +!$acc declare create( TAILFACTOR ) +!$acc declare create( TAILFACTOR_PM ) +!$acc declare create( CDIS ) +!$acc declare create( DELTA_SDIS ) +!$acc declare create( CDISVIS ) +!$acc declare create( NSDSNTH ) +!$acc declare create( NDIKCUMUL ) +!$acc declare create( INDICESSAT ) +!$acc declare create( SATWEIGHTS ) +!$acc declare create( CUMULW ) +!$acc declare create( ANG_GC_A ) +!$acc declare create( ANG_GC_B ) +!$acc declare create( ANG_GC_C ) +!$acc declare create( RNU ) +!$acc declare create( SWELLF5 ) +!$acc declare create( Z0RAT ) +!$acc declare create( Z0TUBMAX ) +!$acc declare create( TAUWSHELTER ) +!$acc declare create( GAMNCONST ) +!$acc declare create( ZALP ) +!$acc declare create( BETAMAXOXKAPPA2 ) +!$acc declare create( BMAXOKAP ) +!$acc declare create( RN1_RN ) +!$acc declare create( ALPHA ) +!$acc declare create( CHNKMIN_U ) +!$acc declare create( RNUM ) +!$acc declare create( ALPHAMIN ) +END MODULE YOWPHYS diff --git a/src/phys-scc-cuf-hoist/yowshal.cuf_hoist_new.F90 b/src/phys-scc-cuf-hoist/yowshal.cuf_hoist_new.F90 new file mode 100644 index 00000000..4d4559ef --- /dev/null +++ b/src/phys-scc-cuf-hoist/yowshal.cuf_hoist_new.F90 @@ -0,0 +1,69 @@ +! (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. +! +MODULE YOWSHAL + + USE PARKIND_WAVE, ONLY: JWIM, JWRB, JWRU + USE YOWDRVTYPE, ONLY: ENVIRONMENT, FREQUENCY + + IMPLICIT NONE + + !* ** *SHALLOW* SHALLOW WATER TABLES and FEATURES. + + INTEGER(KIND=JWIM) :: NDEPTH + + REAL(KIND=JWRB), PARAMETER :: GAM_B_J = 0.8_JWRB + REAL(KIND=JWRB), PARAMETER :: BATHYMAX = 999.0_JWRB + REAL(KIND=JWRB), PARAMETER :: XKDMIN = 0.75_JWRB + + REAL(KIND=JWRB) :: DEPTHA + REAL(KIND=JWRB) :: DEPTHD + REAL(KIND=JWRB) :: TOOSHALLOW + + REAL(KIND=JWRB), ALLOCATABLE :: DEPTH_INPUT(:) + !!! should be removed as soon as possible + + REAL(KIND=JWRB), ALLOCATABLE :: TCGOND(:, :) + REAL(KIND=JWRB), ALLOCATABLE :: TFAK(:, :) + REAL(KIND=JWRB), ALLOCATABLE :: TSIHKD(:, :) + REAL(KIND=JWRB), ALLOCATABLE :: TFAC_ST(:, :) + + !* ** GRID POINT FIELDS ** + TYPE(ENVIRONMENT) :: WVENVI + + !* ** GRID POINT AND FREQUENCY FIELDS ** + TYPE(FREQUENCY) :: WVPRPT + + !* ** FICTIOUS VALUE FOR LAND POINT (NSUP+1) + + !* VARIABLE. TYPE. PURPOSE. + ! --------- ------- -------- + ! *NDEPTH* INTEGER LENGTH OF SHALLOW WATER TABLES (see MTABS). + ! *GAM_B_J REAL FACTIO OF THE DEPTH THAT DETERMINES THE MAXIMUM SIGNIFICANT WAVE HEIGHT ALLOWED + ! *BATHYMAX* REAL MAXIMUM DEPTH, ASSUMED TO CORRESPOND TO DEEP WATER CONDITIONS + ! *XKDMIN* REAL MINIMUM VALUE FOR K*DEPTH IN NON-LINEAR EFFECT FOR FREAK WAVE SOFTWARE. + ! *DEPTHA* REAL MINIMUM DEPTH FOR TABLES (METRES). + ! *TOOSHALLOW REAL MINIMUM DEPTH THAT WILL BE ALLOWED + ! USED TO POINT TO LAND POINTS + ! *DEPTHD* REAL DEPTH INCREMENT (METRES). + ! *TCGOND* REAL SHALLOW WATER GROUP VELOCITY TABLE. + ! *TFAK* REAL WAVE NUMBER TABLE. + ! *TSIHKD* REAL TABLE FOR OMEGA/SINH(2KD). + ! *TFAC_ST* REAL TABLE FOR 2*G*K**2/(OMEGA*TANH(2KD)). + + !! GRID POINT FIELDS: + ! ----------------- + ! *WVENVI* ENVIRONMENT IN WHICH WAVES EVOLVE + + !! GRID POINT AND FREQUENCY FIELDS: + ! -------------------------------- + ! *WVPRPT* REAL WAVE PROPERTIES + + ! ---------------------------------------------------------------------- +!$acc declare create( NDEPTH ) +END MODULE YOWSHAL diff --git a/src/phys-scc-cuf-hoist/yowstat.cuf_hoist_new.F90 b/src/phys-scc-cuf-hoist/yowstat.cuf_hoist_new.F90 new file mode 100644 index 00000000..3777b96d --- /dev/null +++ b/src/phys-scc-cuf-hoist/yowstat.cuf_hoist_new.F90 @@ -0,0 +1,262 @@ +! (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. +! +MODULE YOWSTAT + + USE PARKIND_WAVE, ONLY: JWIM, JWRB, JWRU + + IMPLICIT NONE + + !* ** *STATUS* - TIME STATUS OF INTEGRATION, WIND INPUT, + ! OUTPUT OF RESULTS, MODEL OPTIONS, + ! AND ALTIMETER DATA ASSIMILATION WINDOW. + + + CHARACTER(LEN=2) :: MARSTYPE + CHARACTER(LEN=2) :: YCLASS + CHARACTER(LEN=4) :: YEXPVER + + CHARACTER(LEN=14) :: CDATEA + CHARACTER(LEN=14) :: CDATEE + CHARACTER(LEN=14) :: CDATEF + CHARACTER(LEN=14) :: CDTPRO +!$loki dimension( NDELW_LST ) + CHARACTER(LEN=14), ALLOCATABLE :: CDTW_LST(:) + + CHARACTER(LEN=14) :: CDTRES + CHARACTER(LEN=14) :: CDTBC + CHARACTER(LEN=14) :: CDATER + CHARACTER(LEN=14) :: CDATES + CHARACTER(LEN=14) :: CDTINTT + CHARACTER(LEN=25) :: CMETER + CHARACTER(LEN=25) :: CEVENT + + INTEGER(KIND=JWIM) :: IFRELFMAX + REAL(KIND=JWRB) :: DELPRO_LF + INTEGER(KIND=JWIM) :: IDELPRO + INTEGER(KIND=JWIM) :: IDELT + INTEGER(KIND=JWIM) :: IDELWI +!$loki dimension( NDELW_LST ) + INTEGER(KIND=JWIM), ALLOCATABLE :: IDELWI_LST(:) + INTEGER(KIND=JWIM) :: IDELWO +!$loki dimension( NDELW_LST ) + INTEGER(KIND=JWIM), ALLOCATABLE :: IDELWO_LST(:) + INTEGER(KIND=JWIM) :: NDELW_LST + INTEGER(KIND=JWIM) :: IDELALT + INTEGER(KIND=JWIM) :: IREST + INTEGER(KIND=JWIM) :: IDELRES + INTEGER(KIND=JWIM) :: IDELBC + INTEGER(KIND=JWIM) :: IDELINT + INTEGER(KIND=JWIM) :: IDELINS + INTEGER(KIND=JWIM) :: IDELSPT + INTEGER(KIND=JWIM) :: IDELSPS + INTEGER(KIND=JWIM) :: ICASE + INTEGER(KIND=JWIM) :: ISHALLO + INTEGER(KIND=JWIM) :: ISNONLIN + INTEGER(KIND=JWIM) :: IPHYS + INTEGER(KIND=JWIM) :: IREFRA + INTEGER(KIND=JWIM) :: IPROPAGS = -1 + INTEGER(KIND=JWIM) :: IDAMPING + INTEGER(KIND=JWIM) :: IASSI + INTEGER(KIND=JWIM) :: IASSI_ORIG + INTEGER(KIND=JWIM) :: NENSFNB + INTEGER(KIND=JWIM) :: NTOTENS + INTEGER(KIND=JWIM) :: NSYSNB + INTEGER(KIND=JWIM) :: NMETNB + INTEGER(KIND=JWIM) :: ISTREAM + INTEGER(KIND=JWIM) :: NLOCGRB + INTEGER(KIND=JWIM) :: NCONSENSUS + INTEGER(KIND=JWIM) :: NDWD + INTEGER(KIND=JWIM) :: NMFR + INTEGER(KIND=JWIM) :: NNCEP + INTEGER(KIND=JWIM) :: NUKM + INTEGER(KIND=JWIM) :: IREFDATE + + LOGICAL :: LANAONLY + LOGICAL :: L4VTYPE + LOGICAL :: LFRSTFLD + LOGICAL :: LALTAS + LOGICAL :: LSARAS + LOGICAL :: LSARINV + LOGICAL :: LGUST + LOGICAL :: LADEN + LOGICAL :: LRELWIND + LOGICAL :: LSUBGRID + LOGICAL :: LBIWBK + LOGICAL :: LLSOURCE + LOGICAL :: LNSESTART + LOGICAL :: LSMSSIG_WAM + + !* VARIABLE. TYPE. PURPOSE. + ! --------- ------- -------- + ! *MARSTYPE* CHAR*2 CHARACTER STRING INDICATING THE CURRENT + ! STATUS OF THE MODEL. + ! *YCLASS* CHAR*2 CHARACTER STRING INDICATING THE CLASS OF + ! THE CURRENT RUN. + ! *YEXPVER* CHAR*4 CHARACTER STRING INDICATING THE EXPERIMENT + ! VERSION NUMBER OF THE CURRENT RUN. + + ! *CDATEA* CHAR*14 START DATE OF RUN (YYYYMMDDHHMMSS). + ! *CDATEE* CHAR*14 END DATE OF RUN (YYYYMMDDHHMMSS). + ! *CDATEF* CHAR*14 END DATE OF ANALYSIS RUN (YYYYMMDDHHMM). + ! *CDTPRO* CHAR*14 END DATE OF PROPAGATION. + ! *CDTW_LST* CHAR*14 LIST OF END DATES OF WIND INPUT TIMES. + ! MUST BE INPUT IN CHRONOLOGICAL ORDER !!! + ! *CDTRES* CHAR*14 NEXT DATE TO SAVE OUTPUT AND RESTART FILES. + ! *CDTBC* CHAR*14 NEXT DATE TO SAVE BC FILES. + ! *CDATER* CHAR*14 DATE FOR OUTPUT OF BOTH RESTART FILES + ! IF NOT SET (ie: BLANK LINE IN WAMINFO) + ! OR SET TO 00000000000000 THEN + ! OUTPUT WILL OCCUR AS SPECIFIED IN THE + ! INPUT FILE TO THE WAVE MODEL. + ! IF SET BUT NOT BETWEEN CDATEA AND CDATEE, + ! THEN IT WILL BE SET TO CDATEE. + ! *CDATES* CHAR*14 LAST DATE FOR OUTPUT OF RESTART FILES + ! IF NOT SET IT WILL BE SET BY DEFAULT TO + ! CDATEE + ! *CDTINTT* CHAR*14 NEXT DATE TO WRITE INTEG. PARAMETERS. + + ! *IFRELFMAX* INTEGER FREQUENCY INDEX FOR THE LOW FREQUENCY WAVES (see DELPRO_LF below) + ! *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) + ! !!! and only if IPROPAGS = 2 (I could not be bother to code if for the other options) + ! *IDELPRO* INTEGER TIMESTEP WAM PROPAGATION IN full SECONDS FOR ALL WAVES IF IFRELFMAX=0, + ! OR ALL WAVES WITH FREQUENCIES > FR(IFRELFMAX)a (see above). + ! *IDELT* INTEGER TIMESTEP SOURCE FUNCTION IN SECONDS. + ! *IDELWI* INTEGER INPUT WIND TIMESTEP PREWIND IN SECONDS. + ! *IDELWI_LST*INTEGER LIST OF IDELWI'S. (!!! ALWAYS IN SECONDS!!!) + ! *IDELWO* INTEGER OUTPUT WIND TIMESTEP IN SECONDS + ! EQUAL TO INPUT WIND TIMESTEP INTO WAMODEL. + ! *IDELWO_LST*INTEGER LIST OF IDELWO'S. (!!! ALWAYS IN SECONDS!!!) + ! *NDELW_LST* INTEGER NUMBER OF ENTRIES IN LISTS IDELWI_LST and + ! IDELWO_LST + ! *IDELALT* INTEGER LENGTH IN SECONDS OF THE CENTERED TIME + ! WINDOW FOR THE ALTIMETER DATA ASSIMILATION + ! AT EACH ASSIMILATION TIME. IF NOT + ! PRESCRIBED, IT WILL BE SET TO IDELWO. + ! *IREST* INTEGER RESTART FILE SAVE OPTION. + ! = 1 RESTART FILES ARE SAVED + ! = 2 RESTART FILES ARE SAVED IN SPLIT MODE + ! = 3 RESTART FILES ARE SAVED AND + ! PREALLOCATION OF THE OUTPUT FILE WHICH + ! IS SAVED TO A VFL FILE SYSTEM + ! = 4 RESTART FILES ARE SAVED IN SPLIT MODE + ! OF THE OUTPUT FILE WHICH IS SAVED TO + ! A VFL FILE SYSTEM + ! OTHERWISE RESTART FILES ARE NOT SAVED. + ! *IDELRES* INTEGER OUTPUT AND RESTART FILE DISPOSE TIMESTEP. + ! *IDELBC* INTEGER OUTPUT BC FILE DISPOSE TIMESTEP. + ! *IDELINT* INTEGER INTEG. PARAMETER (TOTAL SEA) OUTPUT + ! TIMESTEP IN SECONDS. + ! *IDELINS* INTEGER INTEG. PARAMETER (SEA + SWELL) OUTPUT + ! TIMESTEP IN SECONDS. + ! *IDELSPT* INTEGER SPECTRA (TOTAL) OUTPUT TIMESTEP IN SECONDS. + ! *IDELSPS* INTEGER SPECTRA (SEA + SWELL) OUTPUT + ! TIMESTEP IN SECONDS. + + ! *ICASE* INTEGER PROPAGATION FLAG + ! = 1 SPHERICAL COORDINATES + ! OTHERWISE CARTESIAN COORDINATES. + ! *ISHALLO* INTEGER SHALLOW WATER MODEL FLAG !!! no longer used. It is always shallow water option + ! = 1 DEEP WATER MODEL + ! OTHERWISE SHALLOW WATER MODEL. + ! *ISNONLIN* INTEGER SNONLIN FLAG + ! = 0 THE OLD FORMULATION IS USED. + ! *IREFRA* INTEGER REFRACTION OPTION.. + ! = 0 NO REFRACTION. + ! = 1 DEPTH REFRACTION ONLY. + ! = 2 CURRENT REFRACTION ONLY. + ! = 2 DEPTH AND CURRENT REFRACTION. + ! *IPROPAGS* INTEGER PROPAGATION SCHEME OPTION. + ! = 0 ORIGINAL FIRST ORDER SCHEME ON QUADRANT. + ! = 1 FIRST ORDER SCHEME ON TWO QUADRANTS + ! *IDAMPING* INTEGER WAVE DAMPING CONTROL + ! = 0 NO WAVE DAMPING + ! = 1 WAVE DAMPING IS ON. + ! *IASSI* INTEGER ASSIMILATION MODEL FLAG + ! = 1 ASSIMILATION IS DONE IF ANALYSIS RUN + ! OTHERWISE NO ASSIMILATION. + ! *NENSFNB* INTEGER ENSEMBLE FORECAST NUMBER (DEFAULT=0) + ! *NTOTENS* INTEGER TOTAL ENSEMBLE FORECAST MEMBERS (DEFAULT=0) + ! *NSYSNB* INTEGER SYSTEM NUMBER TO BE USED FOR GRIBBING OF + ! SEASONAL DATA (DEFAULT=-1). + ! *NMETNB* INTEGER METHOD NUMBER TO BE USED FOR GRIBBING OF + ! SEASONAL DATA (DEFAULT=-1). + ! *LANAONLY* LOGICAL CONTROLS WHETHER ANALYSIS IS RUN WITHOUT + ! PRIOR ADVECTION STEPS + ! *L4VTYPE* LOGICAL CONTROLS WHETHER MARS TYPE 4V IS USED + ! INSTEAD OF TYPE FG. + ! *LFRSTFLD* LOGICAL CONTROLS WHETHER INITIAL OUTPUT INTEGRATED + ! PARAMETERS ARE PRODUCED BASED ON THE INITIAL + ! CONDITIONS. IT WILL ONLY OUTPUT PARAMETERS + ! THAT ARE NOT USED AS INPUT (233, 245, 251) + ! OR CONNECTED TO THE ALTIMETER WAVE HEIGHT + ! CORRECTION (246, 247, 248). + ! *LALTAS* LOGICAL CONTROLS WHETHER ALTAS IS CALLED FOR THE + ! ASSIMILATION. + ! *LSARAS* LOGICAL CONTROLS WHETHER SARAS IS CALLED FOR THE + ! ASSIMILATION. + ! *LSARINV* LOGICAL CONTROLS WHETHER SARINVERT IS CALLED FOR + ! THE SAR INVERSION. + ! *ISTREAM* INTEGER STREAM NUMBER WHEN CODING DATA IN GRID + ! IF SET TO 0 IT WILL NOT BE USED AND + ! INSTEAD MARSTYPE WILL BVE USED TO DETERMINE + ! THE STREAM. + ! *LGUST* LOGICAL CONTROLS WHETHER WIND GUSTINESS EFFECT WILL + ! BE USED IN COMPUTATIONS + ! *LADEN* LOGICAL CONTROLS WHETHER COMPUTED AIR DENSITY WILL + ! BE USED IN COMPUTATIONS + ! *LRELWIND* LOGICAL CONTROLS WHETHER RELATIVE WINDS WITH RESPECT TO + ! SURFACE CURRENTS ARE USED OR NOT. + ! FOR COUPLED RUNS, THE WINDS PASSED By THE IFS + ! ARE ALREADY RELATIVE. ON THE OTHEr HAND, + ! STANDALONE MODE, THE INPUT WIND SHOULD BE IN + ! ABSOLUTE TERMS. + ! *LBIWBK* LOGICAL CONTROLS WHETHER BOTTOM INDUCED WAVE BREAKING + ! IS SHITCHED ON. + ! *LSUBGRID* LOGICAL CONTROLS WHETHER THE SUB-GRID SCALE + ! PARAMETRISATION IS USED OR RESET TO THE + ! IMPACT OF NOT HAVING SUB-GRID SCALE. + ! *LLSOURCE* LOGICAL CONTROLS WHETHER SOURCE TERM CONTRIBUTION IS + ! COMPUTED. + ! *LNSESTART* LOGICAL IF TRUE INITIAL CONDITIONS WILL BE SET TO + ! NOISE LEVEL. + ! *NLOCGRB* INTEGER LOCAL GRIB TABLE NUMBER. + ! *NCONCENSUS*INTEGER ONLY USED IN THE CONTEXT OF MULTI-ANALYSIS + ! ENSEMBLE FORECASTS. IT SPECIFIED WHETHER + ! ONE (NCONCENSUS=0) OR MORE ANALYSES ARE + ! USED IN THE INITIAL CONDITIONS. + ! *NDWD* INTEGER ONLY USED IN THE CONTEXT OF MULTI-ANALYSIS + ! ENSEMBLE FORECASTS. IT SPECIFIED WHETHER + ! DWD IS USED IN THE INITIAL CONDITIONS. + ! *NMFR* INTEGER ONLY USED IN THE CONTEXT OF MULTI-ANALYSIS + ! ENSEMBLE FORECASTS. IT SPECIFIED WHETHER + ! METEO FRANCE IS USED IN THE INITIAL + ! CONDITIONS. + ! *NNCEP* INTEGER ONLY USED IN THE CONTEXT OF MULTI-ANALYSIS + ! ENSEMBLE FORECASTS. IT SPECIFIED WHETHER + ! NCEP IS USED IN THE INITIAL CONDITIONS. + ! *NUKM* INTEGER ONLY USED IN THE CONTEXT OF MULTI-ANALYSIS + ! ENSEMBLE FORECASTS. IT SPECIFIED WHETHER + ! THE MET OFFICE IS USED IN THE INITIAL + ! CONDITIONS. + ! *IREFDATE* INTEGER REFERENCE DATE FOR MONTHLY FORECAST + ! HINDCAST RUNS. + ! + ! *LSMSSIG_WAM* LOGICAL .T. = send signals to SMS or ECFLOW (ECMWF supervisor) + ! *CMETER* CHARACTER SMS or ECFLOW meter command (ECMWF supervisor) + ! *CEVENT* CHARACTER SMS or ECFLOW event command (ECMWF supervisor) + ! ---------------------------------------------------------------------- +!$acc declare create( icase ) +!$acc declare create( IDELT ) +!$acc declare create( ISNONLIN ) +!$acc declare create( LBIWBK ) +!$acc declare create( IPHYS ) +!$acc declare create( IDAMPING ) +END MODULE YOWSTAT diff --git a/src/phys-scc-cuf-hoist/yowtabl.cuf_hoist_new.F90 b/src/phys-scc-cuf-hoist/yowtabl.cuf_hoist_new.F90 new file mode 100644 index 00000000..90f6d4b6 --- /dev/null +++ b/src/phys-scc-cuf-hoist/yowtabl.cuf_hoist_new.F90 @@ -0,0 +1,142 @@ +! (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. +! +MODULE YOWTABL + + USE PARKIND_WAVE, ONLY: JWIM, JWRB, JWRU + + IMPLICIT NONE + + !* ** *TABLE* - TABLE FOR TOTAL STRESS AND HIGH FREQ STRESS. !!!! (obsolete !!! + ! AND TABLES FOR THE CORRECTION OF ALTIMETER HS. + !* ** *TABLE* - TABLE FOR 2ND-ORDER INTERACTION COEFFICIENTS. + + INTEGER(KIND=JWIM), PARAMETER :: ITAUMAX = 400 + INTEGER(KIND=JWIM), PARAMETER :: JUMAX = 300 + INTEGER(KIND=JWIM), PARAMETER :: IUSTAR = 500 + INTEGER(KIND=JWIM), PARAMETER :: IALPHA = 400 + INTEGER(KIND=JWIM), PARAMETER :: ILEVTAIL = 50 + INTEGER(KIND=JWIM), PARAMETER :: IAB = 200 + INTEGER(KIND=JWIM), PARAMETER :: NFREHF = 49 + + INTEGER(KIND=JWIM) :: MR + INTEGER(KIND=JWIM) :: MA + INTEGER(KIND=JWIM) :: NFREH + INTEGER(KIND=JWIM) :: NANGH + INTEGER(KIND=JWIM) :: NMAX + + REAL(KIND=JWRB), PARAMETER :: EPS1 = 0.00001_JWRB + REAL(KIND=JWRB), PARAMETER :: UMAX = 75.0_JWRB + REAL(KIND=JWRB), ALLOCATABLE :: TAUT(:, :, :) + REAL(KIND=JWRB) :: DELTAUW + REAL(KIND=JWRB) :: DELU + REAL(KIND=JWRB), PARAMETER :: USTARM = 5.0_JWRB + REAL(KIND=JWRB), PARAMETER :: ALPHAMCOEF = 40.0_JWRB + REAL(KIND=JWRB), PARAMETER :: XLEVTAILM = 0.02_JWRB + REAL(KIND=JWRB), ALLOCATABLE :: TAUHFT(:, :, :) + REAL(KIND=JWRB), ALLOCATABLE :: PHIHFT(:, :, :) + REAL(KIND=JWRB), ALLOCATABLE :: TAUHFT2(:, :, :) + REAL(KIND=JWRB), ALLOCATABLE :: PHIHFT2(:, :, :) + REAL(KIND=JWRB) :: DELUST + REAL(KIND=JWRB) :: DELALP + REAL(KIND=JWRB) :: DELTAIL + REAL(KIND=JWRB), ALLOCATABLE :: FAC0(:, :, :, :) + REAL(KIND=JWRB), ALLOCATABLE :: FAC1(:, :, :, :) + REAL(KIND=JWRB), ALLOCATABLE :: FAC2(:, :, :, :) + REAL(KIND=JWRB), ALLOCATABLE :: FAC3(:, :, :, :) + REAL(KIND=JWRB), ALLOCATABLE :: FAK(:) + REAL(KIND=JWRB), ALLOCATABLE :: FRHF(:) + REAL(KIND=JWRB), ALLOCATABLE :: DFIMHF(:) + REAL(KIND=JWRB) :: SWELLFT(IAB) + REAL(KIND=JWRB) :: XMR + REAL(KIND=JWRB) :: XMA + REAL(KIND=JWRB) :: DELTHH + + INTEGER(KIND=JWIM), ALLOCATABLE :: IM_P(:, :) + INTEGER(KIND=JWIM), ALLOCATABLE :: IM_M(:, :) + + REAL(KIND=JWRB), ALLOCATABLE :: OMEGA(:) + REAL(KIND=JWRB), ALLOCATABLE :: DFDTH(:) + REAL(KIND=JWRB), ALLOCATABLE :: THH(:) + REAL(KIND=JWRB), ALLOCATABLE :: TA(:, :, :, :) + REAL(KIND=JWRB), ALLOCATABLE :: TB(:, :, :, :) + REAL(KIND=JWRB), ALLOCATABLE :: TC_QL(:, :, :, :) + REAL(KIND=JWRB), ALLOCATABLE :: TT_4M(:, :, :, :) + REAL(KIND=JWRB), ALLOCATABLE :: TT_4P(:, :, :, :) + REAL(KIND=JWRB), ALLOCATABLE :: TFAKH(:, :) + + !* VARIABLE. TYPE. PURPOSE. + ! --------- ------- -------- + ! + !*** STRESS AND HIGH-FREQUENCY WAVE STRESS. + ! ------------------------------------- + ! + ! *ITAUMAX* INTEGER TABLE DIMENSION. + ! *JUMAX* INTEGER TABLE DIMENSION. + ! *IUSTAR* INTEGER TABLE DIMENSION. + ! *IALPHA* INTEGER TABLE DIMENSION. + ! *ILEVTAIL* INTEGER TABLE DIMENSION. + ! *IAB* INTEGER TABLE DIMENSION. + ! *NFREHF* INTEGER EXTENDED NUMBER OF FREQUENCIES. + ! *EPS1* REAL SMALL MULTIPLICATIVE NUMBER TO MAKE SURE THAT A SOLUTION + ! IS OBTAINED IN ITERATION WITH TAU>TAUW. + ! *UMAX* REAL MAXIMUM WIND SPEED IN STRESS TABLE. + ! *TAUT* REAL STRESS TABLE. + ! *DELTAUW* REAL WAVE STRESS INCREMENT. + ! *DELU* REAL WIND INCREMENT. + ! *USTARM* REAL MAXIMUM FRICTION VELOCITY IN STRESS TABLE. + ! *ALPHAMCOEF*REAL MULTIPLICATIVE FACTOR TO SET THE MAXIMUM CHARNOCK + ! BASED ON THE MINIMUM CHARNOCK VALUE IN STRESS TABLE. + ! *XLEVTAILM* REAL MAXIMUM TAIL FACTOR (SATURATION LEVEL) IN STRESS TABLE. + ! *TAUHFT* REAL HIGH FREQUENCY STRESS TABLE for ECMWF PHYSICS. + ! *TAUHFT2* REAL HIGH FREQUENCY STRESS TABLE for METEO FRANCE PHYSICS. + ! *PHIHFT* REAL HIGH FREQUENCY WIND INPUT WAVE ENERGY FLUX TABLE for ECMWF PHYSICS. + ! *PHIHFT2* REAL HIGH FREQUENCY WIND INPUT WAVE ENERGY FLUX TABLE for METEO FRANCE PHYSICS. + ! *DELUST* REAL USTAR INCREMENT. + ! *DELALP* REAL ALPHA INCREMENT. + ! *DELTAIL* REAL ALPHA INCREMENT. + ! + !*** CORRECTIONS TO ALTIMETER. + ! ------------------------ + ! + ! *FAC0* REAL TABLE FOR HIGHER MOMENT CALCULATION. + ! *FAC1* REAL TABLE FOR HIGHER MOMENT CALCULATION. + ! *FAC2* REAL TABLE FOR HIGHER MOMENT CALCULATION. + ! *FAC3* REAL TABLE FOR HIGHER MOMENT CALCULATION. + ! *FAK* REAL WAVE NUMBERS FOR HIGHER MOMENT CALCULATION. + ! *FRHF* REAL FREQUENCIES FOR HIGHER MOMENT CALCULATION. + ! *DFIMHF* REAL FREQUENCY DIRECTION AREA FOR HIGHER + ! MOMENT CALCULATION. + ! *SWELLFT* REAL FRICTION COEFFICIENTS IN OSCILLATORY BOUNDARY LAYERS. + ! + !*** SECOND AND THIRD-ORDER INETERACTION COEFFICIENTS. + ! ------------------------------------------------ + ! + ! MR INTEGER THINNING PARAMETER IN FREQUECY SPACE + ! MA INTEGER THINNING PARAMETER IN ANGULAR SPACE + ! NFREH INTEGER NUMBER OF FREQUENCIES + ! NANGH INTEGER NUMBER OF DIRECTIONS + ! NMAX INTEGER MAXIMUM OF FREQUENCY INDEX + ! XMR REAL INVERSE OF THINNING FACTOR IN FREQUENCY SPACE + ! XMA REAL INVERSE OF THINNING FACTOR IN ANGULAR SPACE + ! DELTHH REAL DIRECTIONAL INCREMENT IN REDUCED SPACE + ! OMEGA REAL ANGULAR FREQUENCY ARRAY + ! DFDTH REAL FREQUENCY DIRECTION INCREMENT IN REDUCED SPACE + ! THH REAL DIRECTION ARRAY + ! TA REAL TABLE FOR MINUS INTERACTIONS + ! TB REAL TABLE FOR PLUS INTERACTIONS + ! TC_QL REAL TABLE FOR QUASI-LINEAR INTERACTIONS + ! TT_4M REAL TABLE FOR STOKES FREQUENCY CORRECTION + ! TT_4P REAL TABLE FOR STOKES FREQUENCY CORRECTION + ! IM_P INTEGER TABLE FOR WAVENUMBER M2 PLUS + ! IM_M INTEGER TABLE FOR WAVENUMBER M2 MIN + ! TFAKH REAL WAVENUMBER TABLE IN REDUCED SPACE + ! + ! ---------------------------------------------------------------------- +!$acc declare create( SWELLFT ) +END MODULE YOWTABL diff --git a/src/phys-scc-cuf-hoist/yowwind.cuf_hoist_new.F90 b/src/phys-scc-cuf-hoist/yowwind.cuf_hoist_new.F90 new file mode 100644 index 00000000..d9b43f1b --- /dev/null +++ b/src/phys-scc-cuf-hoist/yowwind.cuf_hoist_new.F90 @@ -0,0 +1,91 @@ +! (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. +! +MODULE YOWWIND + + USE PARKIND_WAVE, ONLY: JWIM, JWRB, JWRU + + USE YOWDRVTYPE, ONLY: FORCING_FIELDS + + IMPLICIT NONE + + REAL(KIND=JWRB) :: WSPMIN + REAL(KIND=JWRB), PARAMETER :: WSPMIN_RESET_TAUW = 4.0_JWRB + REAL(KIND=JWRB), PARAMETER :: USTMIN_RESET_TAUW = 0.08_JWRB + REAL(KIND=JWRB), PARAMETER :: RWFAC = 0.5_JWRB + + CHARACTER(LEN=14) :: CDATEWL + CHARACTER(LEN=14) :: CDAWIFL + CHARACTER(LEN=14) :: CDATEWO + CHARACTER(LEN=14) :: CDATEFL + CHARACTER(LEN=14) :: CDTNEXT + CHARACTER(LEN=80) :: CWDFILE + + INTEGER(KIND=JWIM) :: IIG + INTEGER(KIND=JWIM) :: NC + INTEGER(KIND=JWIM) :: NR + INTEGER(KIND=JWIM) :: NXFFS + INTEGER(KIND=JWIM) :: NXFFE + INTEGER(KIND=JWIM) :: NYFFS + INTEGER(KIND=JWIM) :: NYFFE + INTEGER(KIND=JWIM) :: NXFFS_LOC + INTEGER(KIND=JWIM) :: NXFFE_LOC + INTEGER(KIND=JWIM) :: NYFFS_LOC + INTEGER(KIND=JWIM) :: NYFFE_LOC + INTEGER(KIND=JWIM) :: NSTORE + INTEGER(KIND=JWIM) :: IUNITW = 0 + INTEGER(KIND=JWIM) :: NBITW = 8100000 + + TYPE(FORCING_FIELDS) :: FF_NEXT + + LOGICAL :: LLWSWAVE + LOGICAL :: LLWDWAVE + LOGICAL :: LLNEWCURR + + !* VARIABLE. TYPE. PURPOSE. + ! --------- ------- -------- + ! *WSPMIN* REAL MINIMUM WIND SPEED ALLOWED IN WAM (SEE USERIN). + ! *WSPMIN_RESET_TAUW MINIMUM WIND SPEED TO RESET WAVE INDUCED STRESS + ! *USTMIN_RESET_TAUW MINIMUM FRICTION VELOCITY TO RESET WAVE INDUCED STRESS + ! *RWFAC* REAL REDUCTION FACTOR OF THE SURFACE CURRENTS + ! WHEN USED TO COMPUTE THE RELATIVE WINDS + ! 0 <= RWFAC <= 1 + ! *CDATEWL* CHAR*14 DATE OF LAST WINDFIELD READ IN. + ! *CDATEWO* CHAR*14 DATE OF NEXT WIND FIELD TO BE READ. + ! *CDAWIFL* CHAR*14 DATE OF NEXT WIND FILE NAME. + ! *CDATEFL* CHAR*14 DATE OF NEXT WIND FILE TO BE ACCESSED. + ! *CDTNEXT* CHAR*14 DATE CORRESPONDING TO TEMPORARY STORAGE ??? obsolete ??? + ! (SEE BELOW). + ! *CWDFILE* CHAR*80 FILENAME FOR FILE CONTAINING WIND SPEED + ! AND DIRECTION TIMESERIES WHEN USED INSTEAD + ! OF FORCING FROM INPUT WIND FIELDS + ! (see USERIN). + ! *IIG* INTEGER BLOCK NUMBER OF LAST WIND FIELD READ IN + ! *NC* INTEGER NUMBER OF COLUMNS IN INPUT WIND ARRAY + ! *NR* INTEGER NUMBER OF ROWS IN INPUT WIND ARRAY + ! *NXFFS INTEGER FIRST ROW IN FORCING_FIELDS DATA + ! *NXFFE INTEGER LAST ROW IN FORCING_FIELDS DATA + ! *NYFFS INTEGER FIRST COLUMN IN FORCING_FIELDS DATA + ! *NYFFE INTEGER LAST COLUMN IN FORCING_FIELDS DATA + ! *NXFFS_LOC INTEGER FIRST ROW IN FORCING_FIELDS DATA FOR POINTS THAT ARE LOVAT TO A GIVEN MPI TASK + ! *NXFFE_LOC INTEGER LAST ROW IN FORCING_FIELDS DATA FOR POINTS THAT ARE LOVAT TO A GIVEN MPI TASK + ! *NYFFS_LOC INTEGER FIRST COLUMN IN FORCING_FIELDS DATA FOR POINTS THAT ARE LOVAT TO A GIVEN MPI TASK + ! *NYFFE_LOC INTEGER LAST COLUMN IN FORCING_FIELDS DATA FOR POINTS THAT ARE LOVAT TO A GIVEN MPI TASK + ! *IUNITW* INTEGER UNIT USED TO OPEN THE INPUT WIND DATA + ! OR THE FILE HANDLE IF GRIBAPI IS USED. + ! *NBITW* INTEGER SIZE OF DECODING BUFFER FOR FORCING DATA. + ! *FF_NEXT* REAL UPDATE FOR FORCING + + ! *LLWSWAVE* LOGICAL TRUE IF PARAMETER 245 IS PART OF THE INPUT + ! *LLWDWAVE* LOGICAL TRUE IF PARAMETER 249 IS PART OF THE INPUT + ! *LLNEWCURR* LOGICAL TRUE IF NEW CURRENTS ARE PASSED FROM IFS + ! TO WAM + ! ---------------------------------------------------------------------- + +!$acc declare create( WSPMIN ) +END MODULE YOWWIND diff --git a/src/phys-scc-cuf-hoist/yowwndg.cuf_hoist_new.F90 b/src/phys-scc-cuf-hoist/yowwndg.cuf_hoist_new.F90 new file mode 100644 index 00000000..7a3aa740 --- /dev/null +++ b/src/phys-scc-cuf-hoist/yowwndg.cuf_hoist_new.F90 @@ -0,0 +1,37 @@ +! (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. +! +MODULE YOWWNDG + + USE PARKIND_WAVE, ONLY: JWIM, JWRB, JWRU + + IMPLICIT NONE + + !* ** *WNDGRD* - INPUT WIND GRID SPECIFICATIONS. + + INTEGER(KIND=JWIM) :: ICODE + INTEGER(KIND=JWIM) :: ICODE_CPL + INTEGER(KIND=JWIM) :: IWPER + INTEGER(KIND=JWIM) :: ICOORD + + !* VARIABLE. TYPE. PURPOSE. + ! --------- ------- -------- + ! *ICODE* INTEGER WIND CODE FROM INPUT FILE + ! 1 = USTAR; 2 = USTRESS; 3 = U10 + ! *ICODE_CPL* INTEGER WIND CODE PASSED VIA WAVEMDL + ! 0 = NOT SET; 1 = USTAR; 2 = USTRESS; 3 = U10 + ! *IWPER* INTEGER INDICATOR PERIODICAL GRID. + ! 0= NON-PERIODICAL; 1= PERIODICAL. + ! *ICOORD* INTEGER CODE FOR COORDINATE SYSTEM USED + ! 1= RECTANGULAR,EQUIDISTANT LON/LAT GRID. + ! 2= .......NOT IMPLEMENTED. + ! ---------------------------------------------------------------------- + +!$acc declare create( ICODE ) +!$acc declare create( ICODE_CPL ) +END MODULE YOWWNDG diff --git a/src/phys-scc-cuf-hoist/z0wave.cuf_hoist_new.F90 b/src/phys-scc-cuf-hoist/z0wave.cuf_hoist_new.F90 new file mode 100644 index 00000000..b81b2868 --- /dev/null +++ b/src/phys-scc-cuf-hoist/z0wave.cuf_hoist_new.F90 @@ -0,0 +1,105 @@ +! (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. +! +MODULE Z0WAVE_CUF_HOIST_NEW_MOD + CONTAINS + ATTRIBUTES(DEVICE) SUBROUTINE Z0WAVE_CUF_HOIST_NEW (KIJS, KIJL, US, TAUW, UTOP, Z0, Z0B, CHRNCK, ALPHA, ALPHAMIN, CHNKMIN_U, & + & EPS1, G, GM1, LLCAPCHNK, ICHNK, NCHNK, IJ) + + ! ---------------------------------------------------------------------- + + !**** *Z0WAVE* - DETERMINE THE SEA STATE DEPENDENT ROUGHNESS LENGTH. + + !* PURPOSE. + ! -------- + + ! COMPUTE ROUGHNESS LENGTH. + + !** INTERFACE. + ! ---------- + + ! *CALL* *Z0WAVE (KIJS, KIJL, US, TAUW, UTOP, Z0, Z0B, CHRNCK) + ! *KIJS* - INDEX OF FIRST GRIDPOINT. + ! *KIJL* - INDEX OF LAST GRIDPOINT. + ! *US* - OUTPUT BLOCK OF SURFACE STRESSES. + ! *TAUW* - INPUT BLOCK OF WAVE STRESSES. + ! *UTOP* - WIND SPEED. + ! *Z0* - OUTPUT BLOCK OF ROUGHNESS LENGTH. + ! *Z0B* - BACKGROUND ROUGHNESS LENGTH. + ! *CHRNCK- CHARNOCK COEFFICIENT + + ! METHOD. + ! ------- + + ! EXTERNALS. + ! ---------- + + ! NONE. + + ! REFERENCE. + ! --------- + + ! NONE. + + ! ---------------------------------------------------------------------- + + USE CHNKMIN_CUF_HOIST_NEW_MOD, ONLY: CHNKMIN_CUF_HOIST_NEW + USE cudafor + USE PARKIND_WAVE, ONLY: JWIM, JWRU, JWRB + + + + ! ---------------------------------------------------------------------- + + IMPLICIT NONE + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJS + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: KIJL + REAL(KIND=JWRB), INTENT(IN) :: US(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: TAUW(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(IN) :: UTOP(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(OUT) :: Z0(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(OUT) :: Z0B(KIJL, NCHNK) + REAL(KIND=JWRB), INTENT(OUT) :: CHRNCK(KIJL, NCHNK) + + + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: IJ + REAL(KIND=JWRB) :: UST2 + REAL(KIND=JWRB) :: UST3 + REAL(KIND=JWRB) :: ARG + REAL(KIND=JWRB) :: ALPHAOG + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ALPHA + REAL(KIND=JWRB), VALUE, INTENT(IN) :: ALPHAMIN + REAL(KIND=JWRB), VALUE, INTENT(IN) :: CHNKMIN_U + REAL(KIND=JWRB), VALUE, INTENT(IN) :: EPS1 + REAL(KIND=JWRB), VALUE, INTENT(IN) :: G + REAL(KIND=JWRB), VALUE, INTENT(IN) :: GM1 + LOGICAL, VALUE, INTENT(IN) :: LLCAPCHNK + INTEGER(KIND=JWIM), VALUE, INTENT(IN) :: ICHNK + INTEGER, VALUE, INTENT(IN) :: NCHNK + + ! ---------------------------------------------------------------------- + + + + IF (LLCAPCHNK) THEN + ALPHAOG = CHNKMIN_CUF_HOIST_NEW(UTOP(IJ, ICHNK), ALPHA, ALPHAMIN, CHNKMIN_U)*GM1 + ELSE + ALPHAOG = ALPHA*GM1 + END IF + + UST2 = US(IJ, ICHNK)**2 + UST3 = US(IJ, ICHNK)**3 + ARG = MAX(UST2 - TAUW(IJ, ICHNK), EPS1) + Z0(IJ, ICHNK) = ALPHAOG*UST3 / SQRT(ARG) + Z0B(IJ, ICHNK) = ALPHAOG*UST2 + CHRNCK(IJ, ICHNK) = G*Z0(IJ, ICHNK) / UST2 + + + + END SUBROUTINE Z0WAVE_CUF_HOIST_NEW +END MODULE Z0WAVE_CUF_HOIST_NEW_MOD