New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
ldfslp.F90 in branches/2014/dev_r4650_UKMO14.12_STAND_ALONE_OBSOPER/NEMOGCM/NEMO/OPA_SRC/LDF – NEMO

source: branches/2014/dev_r4650_UKMO14.12_STAND_ALONE_OBSOPER/NEMOGCM/NEMO/OPA_SRC/LDF/ldfslp.F90 @ 5600

Last change on this file since 5600 was 5600, checked in by andrewryan, 9 years ago

merged in latest version of trunk alongside changes to SAO_SRC to be compatible with latest OBS

  • Property svn:keywords set to Id
File size: 54.3 KB
RevLine 
[3]1MODULE ldfslp
2   !!======================================================================
3   !!                       ***  MODULE  ldfslp  ***
4   !! Ocean physics: slopes of neutral surfaces
5   !!======================================================================
[1515]6   !! History :  OPA  ! 1994-12  (G. Madec, M. Imbard)  Original code
7   !!            8.0  ! 1997-06  (G. Madec)  optimization, lbc
8   !!            8.1  ! 1999-10  (A. Jouzeau)  NEW profile in the mixed layer
[2528]9   !!   NEMO     1.0  ! 2002-10  (G. Madec)  Free form, F90
10   !!             -   ! 2005-10  (A. Beckmann)  correction for s-coordinates
11   !!            3.3  ! 2010-10  (G. Nurser, C. Harris, G. Madec)  add Griffies operator
12   !!             -   ! 2010-11  (F. Dupond, G. Madec)  bug correction in slopes just below the ML
[1515]13   !!----------------------------------------------------------------------
[3]14#if   defined key_ldfslp   ||   defined key_esopa
15   !!----------------------------------------------------------------------
16   !!   'key_ldfslp'                      Rotation of lateral mixing tensor
17   !!----------------------------------------------------------------------
[3625]18   !!   ldf_slp_grif  : calculates the triads of isoneutral slopes (Griffies operator)
19   !!   ldf_slp       : calculates the slopes of neutral surface   (Madec operator)
20   !!   ldf_slp_mxl   : calculates the slopes at the base of the mixed layer (Madec operator)
21   !!   ldf_slp_init  : initialization of the slopes computation
[3]22   !!----------------------------------------------------------------------
[3848]23   USE oce            ! ocean dynamics and tracers
24   USE dom_oce        ! ocean space and time domain
25   USE ldftra_oce     ! lateral diffusion: traceur
26   USE ldfdyn_oce     ! lateral diffusion: dynamics
27   USE phycst         ! physical constants
28   USE zdfmxl         ! mixed layer depth
29   USE eosbn2         ! equation of states
[5034]30   !
31   USE in_out_manager ! I/O manager
[3848]32   USE lbclnk         ! ocean lateral boundary conditions (or mpp link)
33   USE prtctl         ! Print control
34   USE wrk_nemo       ! work arrays
35   USE timing         ! Timing
36   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)
[3]37
38   IMPLICIT NONE
39   PRIVATE
40
[2528]41   PUBLIC   ldf_slp        ! routine called by step.F90
42   PUBLIC   ldf_slp_grif   ! routine called by step.F90
43   PUBLIC   ldf_slp_init   ! routine called by opa.F90
[3]44
[2528]45   LOGICAL , PUBLIC, PARAMETER ::   lk_ldfslp = .TRUE.     !: slopes flag
46   !                                                                             !! Madec operator
[2715]47   !  Arrays allocated in ldf_slp_init() routine once we know whether we're using the Griffies or Madec operator
48   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)     ::   uslp, wslpi          !: i_slope at U- and W-points
49   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)     ::   vslp, wslpj          !: j-slope at V- and W-points
50   !                                                                !! Griffies operator
51   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)     ::   wslp2                !: wslp**2 from Griffies quarter cells
[3294]52   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:,:) ::   triadi_g, triadj_g   !: skew flux  slopes relative to geopotentials
[2715]53   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:,:) ::   triadi  , triadj     !: isoneutral slopes relative to model-coordinate
[3]54
[2528]55   !                                                              !! Madec operator
[2715]56   !  Arrays allocated in ldf_slp_init() routine once we know whether we're using the Griffies or Madec operator
57   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   omlmask           ! mask of the surface mixed layer at T-pt
58   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   uslpml, wslpiml   ! i_slope at U- and W-points just below the mixed layer
59   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   vslpml, wslpjml   ! j_slope at V- and W-points just below the mixed layer
[2528]60
61   REAL(wp) ::   repsln = 1.e-25_wp       ! tiny value used as minium of di(rho), dj(rho) and dk(rho)
62
[3]63   !! * Substitutions
64#  include "domzgr_substitute.h90"
[2528]65#  include "ldftra_substitute.h90"
66#  include "ldfeiv_substitute.h90"
[3]67#  include "vectopt_loop_substitute.h90"
68   !!----------------------------------------------------------------------
[2715]69   !! NEMO/OPA 4.0 , NEMO Consortium (2011)
[1156]70   !! $Id$
[2528]71   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
[3]72   !!----------------------------------------------------------------------
73CONTAINS
74
75   SUBROUTINE ldf_slp( kt, prd, pn2 )
76      !!----------------------------------------------------------------------
77      !!                 ***  ROUTINE ldf_slp  ***
[3294]78      !!
[1515]79      !! ** Purpose :   Compute the slopes of neutral surface (slope of isopycnal
[2528]80      !!              surfaces referenced locally) (ln_traldf_iso=T).
[3294]81      !!
82      !! ** Method  :   The slope in the i-direction is computed at U- and
83      !!      W-points (uslp, wslpi) and the slope in the j-direction is
[3]84      !!      computed at V- and W-points (vslp, wslpj).
85      !!      They are bounded by 1/100 over the whole ocean, and within the
86      !!      surface layer they are bounded by the distance to the surface
87      !!      ( slope<= depth/l  where l is the length scale of horizontal
88      !!      diffusion (here, aht=2000m2/s ==> l=20km with a typical velocity
89      !!      of 10cm/s)
90      !!        A horizontal shapiro filter is applied to the slopes
[461]91      !!        ln_sco=T, s-coordinate, add to the previously computed slopes
[3]92      !!      the slope of the model level surface.
93      !!        macro-tasked on horizontal slab (jk-loop)  (2, jpk-1)
94      !!      [slopes already set to zero at level 1, and to zero or the ocean
[461]95      !!      bottom slope (ln_sco=T) at level jpk in inildf]
[3]96      !!
[3294]97      !! ** Action : - uslp, wslpi, and vslp, wslpj, the i- and  j-slopes
[3]98      !!               of now neutral surfaces at u-, w- and v- w-points, resp.
[1515]99      !!----------------------------------------------------------------------
[2715]100      INTEGER , INTENT(in)                   ::   kt    ! ocean time-step index
101      REAL(wp), INTENT(in), DIMENSION(:,:,:) ::   prd   ! in situ density
102      REAL(wp), INTENT(in), DIMENSION(:,:,:) ::   pn2   ! Brunt-Vaisala frequency (locally ref.)
[1515]103      !!
104      INTEGER  ::   ji , jj , jk    ! dummy loop indices
105      INTEGER  ::   ii0, ii1, iku   ! temporary integer
106      INTEGER  ::   ij0, ij1, ikv   ! temporary integer
[3294]107      REAL(wp) ::   zeps, zm1_g, zm1_2g, z1_16, zcofw ! local scalars
[2528]108      REAL(wp) ::   zci, zfi, zau, zbu, zai, zbi   !   -      -
109      REAL(wp) ::   zcj, zfj, zav, zbv, zaj, zbj   !   -      -
110      REAL(wp) ::   zck, zfk,      zbw             !   -      -
[5034]111      REAL(wp) ::   zdepv, zdepu         !   -      -
[3294]112      REAL(wp), POINTER, DIMENSION(:,:,:) ::  zwz, zww
113      REAL(wp), POINTER, DIMENSION(:,:,:) ::  zdzr
114      REAL(wp), POINTER, DIMENSION(:,:,:) ::  zgru, zgrv
[5034]115      REAL(wp), POINTER, DIMENSION(:,:  ) :: zhmlpu, zhmlpv
[3]116      !!----------------------------------------------------------------------
[3294]117      !
118      IF( nn_timing == 1 )  CALL timing_start('ldf_slp')
119      !
120      CALL wrk_alloc( jpi,jpj,jpk, zwz, zww, zdzr, zgru, zgrv )
[5034]121      CALL wrk_alloc( jpi,jpj, zhmlpu, zhmlpv )
[2715]122
[4488]123      IF ( ln_traldf_iso .OR. ln_dynldf_iso ) THEN
124     
125         zeps   =  1.e-20_wp        !==   Local constant initialization   ==!
126         z1_16  =  1.0_wp / 16._wp
127         zm1_g  = -1.0_wp / grav
128         zm1_2g = -0.5_wp / grav
129         !
130         zww(:,:,:) = 0._wp
131         zwz(:,:,:) = 0._wp
132         !
133         DO jk = 1, jpk             !==   i- & j-gradient of density   ==!
134            DO jj = 1, jpjm1
135               DO ji = 1, fs_jpim1   ! vector opt.
136                  zgru(ji,jj,jk) = umask(ji,jj,jk) * ( prd(ji+1,jj  ,jk) - prd(ji,jj,jk) )
137                  zgrv(ji,jj,jk) = vmask(ji,jj,jk) * ( prd(ji  ,jj+1,jk) - prd(ji,jj,jk) )
138               END DO
[3]139            END DO
140         END DO
[4488]141         IF( ln_zps ) THEN                           ! partial steps correction at the bottom ocean level
142            DO jj = 1, jpjm1
143               DO ji = 1, jpim1
[5600]144                  zgru(ji,jj,mbku(ji,jj)) = gru(ji,jj)
145                  zgrv(ji,jj,mbkv(ji,jj)) = grv(ji,jj)
146               END DO
147            END DO
148         ENDIF
149         IF( ln_zps .AND. ln_isfcav ) THEN           ! partial steps correction at the bottom ocean level
150            DO jj = 1, jpjm1
151               DO ji = 1, jpim1
[5034]152               IF ( miku(ji,jj) > 1 ) zgru(ji,jj,miku(ji,jj)) = grui(ji,jj) 
153               IF ( mikv(ji,jj) > 1 ) zgrv(ji,jj,mikv(ji,jj)) = grvi(ji,jj)
[4488]154               END DO
[461]155            END DO
[4488]156         ENDIF
157         !
[5600]158         !==   Local vertical density gradient at T-point   == !   (evaluated from N^2)
159         ! interior value
160         DO jk = 2, jpkm1
[4488]161            !                                ! zdzr = d/dz(prd)= - ( prd ) / grav * mk(pn2) -- at t point
162            !                                !   trick: tmask(ik  )  = 0   =>   all pn2   = 0   =>   zdzr = 0
163            !                                !    else  tmask(ik+1)  = 0   =>   pn2(ik+1) = 0   =>   zdzr divides by 1
164            !                                !          umask(ik+1) /= 0   =>   all pn2  /= 0   =>   zdzr divides by 2
165            !                                ! NB: 1/(tmask+1) = (1-.5*tmask)  substitute a / by a *  ==> faster
166            zdzr(:,:,jk) = zm1_g * ( prd(:,:,jk) + 1._wp )              &
167               &                 * ( pn2(:,:,jk) + pn2(:,:,jk+1) ) * ( 1._wp - 0.5_wp * tmask(:,:,jk+1) )
[3]168         END DO
[5034]169         ! surface initialisation
[5600]170         zdzr(:,:,1) = 0._wp 
171         IF ( ln_isfcav ) THEN
172            ! if isf need to overwrite the interior value at at the first ocean point
173            DO jj = 1, jpjm1
174               DO ji = 1, jpim1
175                  zdzr(ji,jj,1:mikt(ji,jj)) = 0._wp
176               END DO
[5034]177            END DO
[5600]178         END IF
[4488]179         !
180         !                          !==   Slopes just below the mixed layer   ==!
181         CALL ldf_slp_mxl( prd, pn2, zgru, zgrv, zdzr )        ! output: uslpml, vslpml, wslpiml, wslpjml
[2389]182
[3294]183
[4488]184         ! I.  slopes at u and v point      | uslp = d/di( prd ) / d/dz( prd )
185         ! ===========================      | vslp = d/dj( prd ) / d/dz( prd )
186         !
[5600]187         IF ( ln_isfcav ) THEN
188            DO jj = 2, jpjm1
189               DO ji = fs_2, fs_jpim1   ! vector opt.
190                  IF (miku(ji,jj) .GT. miku(ji+1,jj)) zhmlpu(ji,jj) = MAX(hmlpt(ji  ,jj  ),                   5._wp)
191                  IF (miku(ji,jj) .LT. miku(ji+1,jj)) zhmlpu(ji,jj) = MAX(hmlpt(ji+1,jj  ),                   5._wp)
192                  IF (miku(ji,jj) .EQ. miku(ji+1,jj)) zhmlpu(ji,jj) = MAX(hmlpt(ji  ,jj  ), hmlpt(ji+1,jj  ), 5._wp)
193                  IF (mikv(ji,jj) .GT. miku(ji,jj+1)) zhmlpv(ji,jj) = MAX(hmlpt(ji  ,jj  ),                   5._wp)
194                  IF (mikv(ji,jj) .LT. miku(ji,jj+1)) zhmlpv(ji,jj) = MAX(hmlpt(ji  ,jj+1),                   5._wp)
195                  IF (mikv(ji,jj) .EQ. miku(ji,jj+1)) zhmlpv(ji,jj) = MAX(hmlpt(ji  ,jj  ), hmlpt(ji  ,jj+1), 5._wp)
196               ENDDO
[5034]197            ENDDO
[5600]198         ELSE
199            DO jj = 2, jpjm1
200               DO ji = fs_2, fs_jpim1   ! vector opt.
201                  zhmlpu(ji,jj) = MAX(hmlpt(ji,jj), hmlpt(ji+1,jj  ), 5._wp)
202                  zhmlpv(ji,jj) = MAX(hmlpt(ji,jj), hmlpt(ji  ,jj+1), 5._wp)
203               ENDDO
204            ENDDO
205         END IF
[4488]206         DO jk = 2, jpkm1                            !* Slopes at u and v points
207            DO jj = 2, jpjm1
208               DO ji = fs_2, fs_jpim1   ! vector opt.
209                  !                                      ! horizontal and vertical density gradient at u- and v-points
210                  zau = zgru(ji,jj,jk) / e1u(ji,jj)
211                  zav = zgrv(ji,jj,jk) / e2v(ji,jj)
212                  zbu = 0.5_wp * ( zdzr(ji,jj,jk) + zdzr(ji+1,jj  ,jk) )
213                  zbv = 0.5_wp * ( zdzr(ji,jj,jk) + zdzr(ji  ,jj+1,jk) )
214                  !                                      ! bound the slopes: abs(zw.)<= 1/100 and zb..<0
215                  !                                      ! + kxz max= ah slope max =< e1 e3 /(pi**2 2 dt)
216                  zbu = MIN(  zbu, -100._wp* ABS( zau ) , -7.e+3_wp/fse3u(ji,jj,jk)* ABS( zau )  )
217                  zbv = MIN(  zbv, -100._wp* ABS( zav ) , -7.e+3_wp/fse3v(ji,jj,jk)* ABS( zav )  )
218                  !                                      ! uslp and vslp output in zwz and zww, resp.
[5600]219                  zfi = MAX( omlmask(ji,jj,jk), omlmask(ji+1,jj  ,jk) )
220                  zfj = MAX( omlmask(ji,jj,jk), omlmask(ji  ,jj+1,jk) )
[5034]221                  ! thickness of water column between surface and level k at u/v point
[5600]222                  zdepu = 0.5_wp * ( ( fsdept(ji,jj,jk) + fsdept(ji+1,jj  ,jk) )                              &
223                                   - 2 * MAX( risfdep(ji,jj), risfdep(ji+1,jj  ) ) - fse3u(ji,jj,miku(ji,jj)) )
224                  zdepv = 0.5_wp * ( ( fsdept(ji,jj,jk) + fsdept(ji  ,jj+1,jk) )                              &
225                                   - 2 * MAX( risfdep(ji,jj), risfdep(ji  ,jj+1) ) - fse3v(ji,jj,mikv(ji,jj)) )
226                  !
227                  zwz(ji,jj,jk) = ( 1. - zfi) * zau / ( zbu - zeps )                                          &
228                     &                 + zfi  * uslpml(ji,jj) * zdepu / zhmlpu(ji,jj)
229                  zwz(ji,jj,jk) = zwz(ji,jj,jk) * wumask(ji,jj,jk)
230                  zww(ji,jj,jk) = ( 1. - zfj) * zav / ( zbv - zeps )                                          &
231                     &                 + zfj  * vslpml(ji,jj) * zdepv / zhmlpv(ji,jj) 
232                  zww(ji,jj,jk) = zww(ji,jj,jk) * wvmask(ji,jj,jk)
[5034]233                 
234                 
[2528]235!!gm  modif to suppress omlmask.... (as in Griffies case)
[4488]236!                  !                                         ! jk must be >= ML level for zf=1. otherwise  zf=0.
237!                  zfi = REAL( 1 - 1/(1 + jk / MAX( nmln(ji+1,jj), nmln(ji,jj) ) ), wp )
238!                  zfj = REAL( 1 - 1/(1 + jk / MAX( nmln(ji,jj+1), nmln(ji,jj) ) ), wp )
239!                  zci = 0.5 * ( fsdept(ji+1,jj,jk)+fsdept(ji,jj,jk) ) / MAX( hmlpt(ji,jj), hmlpt(ji+1,jj), 10. ) )
240!                  zcj = 0.5 * ( fsdept(ji,jj+1,jk)+fsdept(ji,jj,jk) ) / MAX( hmlpt(ji,jj), hmlpt(ji,jj+1), 10. ) )
241!                  zwz(ji,jj,jk) = ( zfi * zai / ( zbi - zeps ) + ( 1._wp - zfi ) * wslpiml(ji,jj) * zci ) * tmask(ji,jj,jk)
242!                  zww(ji,jj,jk) = ( zfj * zaj / ( zbj - zeps ) + ( 1._wp - zfj ) * wslpjml(ji,jj) * zcj ) * tmask(ji,jj,jk)
[2528]243!!gm end modif
[4488]244               END DO
[3]245            END DO
246         END DO
[4488]247         CALL lbc_lnk( zwz, 'U', -1. )   ;   CALL lbc_lnk( zww, 'V', -1. )      ! lateral boundary conditions
248         !
249         !                                            !* horizontal Shapiro filter
250         DO jk = 2, jpkm1
251            DO jj = 2, jpjm1, MAX(1, jpj-3)                        ! rows jj=2 and =jpjm1 only
252               DO ji = 2, jpim1
253                  uslp(ji,jj,jk) = z1_16 * (        zwz(ji-1,jj-1,jk) + zwz(ji+1,jj-1,jk)      &
254                     &                       +      zwz(ji-1,jj+1,jk) + zwz(ji+1,jj+1,jk)      &
255                     &                       + 2.*( zwz(ji  ,jj-1,jk) + zwz(ji-1,jj  ,jk)      &
256                     &                       +      zwz(ji+1,jj  ,jk) + zwz(ji  ,jj+1,jk) )    &
257                     &                       + 4.*  zwz(ji  ,jj  ,jk)                       )
258                  vslp(ji,jj,jk) = z1_16 * (        zww(ji-1,jj-1,jk) + zww(ji+1,jj-1,jk)      &
259                     &                       +      zww(ji-1,jj+1,jk) + zww(ji+1,jj+1,jk)      &
260                     &                       + 2.*( zww(ji  ,jj-1,jk) + zww(ji-1,jj  ,jk)      &
261                     &                       +      zww(ji+1,jj  ,jk) + zww(ji  ,jj+1,jk) )    &
262                     &                       + 4.*  zww(ji,jj    ,jk)                       )
263               END DO
[3]264            END DO
[4488]265            DO jj = 3, jpj-2                               ! other rows
266               DO ji = fs_2, fs_jpim1   ! vector opt.
267                  uslp(ji,jj,jk) = z1_16 * (        zwz(ji-1,jj-1,jk) + zwz(ji+1,jj-1,jk)      &
268                     &                       +      zwz(ji-1,jj+1,jk) + zwz(ji+1,jj+1,jk)      &
269                     &                       + 2.*( zwz(ji  ,jj-1,jk) + zwz(ji-1,jj  ,jk)      &
270                     &                       +      zwz(ji+1,jj  ,jk) + zwz(ji  ,jj+1,jk) )    &
271                     &                       + 4.*  zwz(ji  ,jj  ,jk)                       )
272                  vslp(ji,jj,jk) = z1_16 * (        zww(ji-1,jj-1,jk) + zww(ji+1,jj-1,jk)      &
273                     &                       +      zww(ji-1,jj+1,jk) + zww(ji+1,jj+1,jk)      &
274                     &                       + 2.*( zww(ji  ,jj-1,jk) + zww(ji-1,jj  ,jk)         &
275                     &                       +      zww(ji+1,jj  ,jk) + zww(ji  ,jj+1,jk) )    &
276                     &                       + 4.*  zww(ji,jj    ,jk)                       )
277               END DO
[3]278            END DO
[4488]279            !                                        !* decrease along coastal boundaries
280            DO jj = 2, jpjm1
281               DO ji = fs_2, fs_jpim1   ! vector opt.
282                  uslp(ji,jj,jk) = uslp(ji,jj,jk) * ( umask(ji,jj+1,jk) + umask(ji,jj-1,jk  ) ) * 0.5_wp   &
[5034]283                     &                            * ( umask(ji,jj  ,jk) + umask(ji,jj  ,jk+1) ) * 0.5_wp   &
[5600]284                     &                            *   umask(ji,jj,jk-1)
[4488]285                  vslp(ji,jj,jk) = vslp(ji,jj,jk) * ( vmask(ji+1,jj,jk) + vmask(ji-1,jj,jk  ) ) * 0.5_wp   &
[5034]286                     &                            * ( vmask(ji  ,jj,jk) + vmask(ji  ,jj,jk+1) ) * 0.5_wp   &
[5600]287                     &                            *   vmask(ji,jj,jk-1)
[4488]288               END DO
[3]289            END DO
290         END DO
291
292
[4488]293         ! II.  slopes at w point           | wslpi = mij( d/di( prd ) / d/dz( prd )
294         ! ===========================      | wslpj = mij( d/dj( prd ) / d/dz( prd )
295         !
296         DO jk = 2, jpkm1
297            DO jj = 2, jpjm1
298               DO ji = fs_2, fs_jpim1   ! vector opt.
299                  !                                  !* Local vertical density gradient evaluated from N^2
[5600]300                  zbw = zm1_2g * pn2 (ji,jj,jk) * ( prd (ji,jj,jk) + prd (ji,jj,jk-1) + 2. ) * wmask(ji,jj,jk)
[4488]301                  !                                  !* Slopes at w point
302                  !                                        ! i- & j-gradient of density at w-points
303                  zci = MAX(  umask(ji-1,jj,jk  ) + umask(ji,jj,jk  )           &
304                     &      + umask(ji-1,jj,jk-1) + umask(ji,jj,jk-1) , zeps  ) * e1t(ji,jj)
305                  zcj = MAX(  vmask(ji,jj-1,jk  ) + vmask(ji,jj,jk-1)           &
306                     &      + vmask(ji,jj-1,jk-1) + vmask(ji,jj,jk  ) , zeps  ) *  e2t(ji,jj)
307                  zai =    (  zgru (ji-1,jj,jk  ) + zgru (ji,jj,jk-1)           &
[5034]308                     &      + zgru (ji-1,jj,jk-1) + zgru (ji,jj,jk  )   ) / zci
[4488]309                  zaj =    (  zgrv (ji,jj-1,jk  ) + zgrv (ji,jj,jk-1)           &
[5034]310                     &      + zgrv (ji,jj-1,jk-1) + zgrv (ji,jj,jk  )   ) / zcj
[4488]311                  !                                        ! bound the slopes: abs(zw.)<= 1/100 and zb..<0.
312                  !                                        ! + kxz max= ah slope max =< e1 e3 /(pi**2 2 dt)
313                  zbi = MIN( zbw ,- 100._wp* ABS( zai ) , -7.e+3_wp/fse3w(ji,jj,jk)* ABS( zai )  )
314                  zbj = MIN( zbw , -100._wp* ABS( zaj ) , -7.e+3_wp/fse3w(ji,jj,jk)* ABS( zaj )  )
315                  !                                        ! wslpi and wslpj with ML flattening (output in zwz and zww, resp.)
[5600]316                  zfk = MAX( omlmask(ji,jj,jk), omlmask(ji,jj,jk-1) )   ! zfk=1 in the ML otherwise zfk=0
[5034]317                  zck = ( fsdepw(ji,jj,jk) - fsdepw(ji,jj,mikt(ji,jj) ) ) / MAX( hmlp(ji,jj), 10._wp )
318                  zwz(ji,jj,jk) = (  zai / ( zbi - zeps ) * ( 1._wp - zfk ) &
[5600]319                     &            + zck * wslpiml(ji,jj) * zfk  ) * wmask(ji,jj,jk)
[5034]320                  zww(ji,jj,jk) = (  zaj / ( zbj - zeps ) * ( 1._wp - zfk ) &
[5600]321                     &            + zck * wslpjml(ji,jj) * zfk  ) * wmask(ji,jj,jk)
[2528]322
323!!gm  modif to suppress omlmask....  (as in Griffies operator)
[4488]324!                  !                                         ! jk must be >= ML level for zfk=1. otherwise  zfk=0.
325!                  zfk = REAL( 1 - 1/(1 + jk / nmln(ji+1,jj)), wp )
326!                  zck = fsdepw(ji,jj,jk)    / MAX( hmlp(ji,jj), 10. )
327!                  zwz(ji,jj,jk) = ( zfk * zai / ( zbi - zeps ) + ( 1._wp - zfk ) * wslpiml(ji,jj) * zck ) * tmask(ji,jj,jk)
328!                  zww(ji,jj,jk) = ( zfk * zaj / ( zbj - zeps ) + ( 1._wp - zfk ) * wslpjml(ji,jj) * zck ) * tmask(ji,jj,jk)
[2528]329!!gm end modif
[4488]330               END DO
[3]331            END DO
332         END DO
[4488]333         CALL lbc_lnk( zwz, 'T', -1. )   ;    CALL lbc_lnk( zww, 'T', -1. )      ! lateral boundary conditions
334         !
335         !                                           !* horizontal Shapiro filter
336         DO jk = 2, jpkm1
337            DO jj = 2, jpjm1, MAX(1, jpj-3)                        ! rows jj=2 and =jpjm1 only
338               DO ji = 2, jpim1
339                  zcofw = tmask(ji,jj,jk) * z1_16
340                  wslpi(ji,jj,jk) = (          zwz(ji-1,jj-1,jk) + zwz(ji+1,jj-1,jk)     &
341                       &                +      zwz(ji-1,jj+1,jk) + zwz(ji+1,jj+1,jk)     &
342                       &                + 2.*( zwz(ji  ,jj-1,jk) + zwz(ji-1,jj  ,jk)     &
343                       &                +      zwz(ji+1,jj  ,jk) + zwz(ji  ,jj+1,jk) )   &
344                       &                + 4.*  zwz(ji  ,jj  ,jk)                         ) * zcofw
[3]345
[4488]346                  wslpj(ji,jj,jk) = (          zww(ji-1,jj-1,jk) + zww(ji+1,jj-1,jk)     &
347                       &                +      zww(ji-1,jj+1,jk) + zww(ji+1,jj+1,jk)     &
348                       &                + 2.*( zww(ji  ,jj-1,jk) + zww(ji-1,jj  ,jk)     &
349                       &                +      zww(ji+1,jj  ,jk) + zww(ji  ,jj+1,jk) )   &
350                       &                + 4.*  zww(ji  ,jj  ,jk)                         ) * zcofw
351               END DO
[3]352            END DO
[4488]353            DO jj = 3, jpj-2                               ! other rows
354               DO ji = fs_2, fs_jpim1   ! vector opt.
355                  zcofw = tmask(ji,jj,jk) * z1_16
356                  wslpi(ji,jj,jk) = (        zwz(ji-1,jj-1,jk) + zwz(ji+1,jj-1,jk)     &
357                       &                +      zwz(ji-1,jj+1,jk) + zwz(ji+1,jj+1,jk)     &
358                       &                + 2.*( zwz(ji  ,jj-1,jk) + zwz(ji-1,jj  ,jk)     &
359                       &                +      zwz(ji+1,jj  ,jk) + zwz(ji  ,jj+1,jk) )   &
360                       &                + 4.*  zwz(ji  ,jj  ,jk)                         ) * zcofw
[3]361
[4488]362                  wslpj(ji,jj,jk) = (        zww(ji-1,jj-1,jk) + zww(ji+1,jj-1,jk)     &
363                       &                +      zww(ji-1,jj+1,jk) + zww(ji+1,jj+1,jk)     &
364                       &                + 2.*( zww(ji  ,jj-1,jk) + zww(ji-1,jj  ,jk)     &
365                       &                +      zww(ji+1,jj  ,jk) + zww(ji  ,jj+1,jk) )   &
366                       &                + 4.*  zww(ji  ,jj  ,jk)                         ) * zcofw
367               END DO
[3]368            END DO
[4488]369            !                                        !* decrease along coastal boundaries
370            DO jj = 2, jpjm1
371               DO ji = fs_2, fs_jpim1   ! vector opt.
372                  zck =   ( umask(ji,jj,jk) + umask(ji-1,jj,jk) )   &
373                     &  * ( vmask(ji,jj,jk) + vmask(ji,jj-1,jk) ) * 0.25
[5600]374                  wslpi(ji,jj,jk) = wslpi(ji,jj,jk) * zck * wmask(ji,jj,jk)
375                  wslpj(ji,jj,jk) = wslpj(ji,jj,jk) * zck * wmask(ji,jj,jk)
[4488]376               END DO
[3]377            END DO
378         END DO
[3294]379
[4488]380         ! III.  Specific grid points
381         ! ===========================
[1515]382         !
[4488]383         IF( cp_cfg == "orca" .AND. jp_cfg == 4 ) THEN     !  ORCA_R4 configuration: horizontal diffusion in specific area
384            !                                                    ! Gibraltar Strait
385            ij0 =  50   ;   ij1 =  53
386            ii0 =  69   ;   ii1 =  71   ;   uslp ( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , : ) = 0._wp
387            ij0 =  51   ;   ij1 =  53
388            ii0 =  68   ;   ii1 =  71   ;   vslp ( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , : ) = 0._wp
389            ii0 =  69   ;   ii1 =  71   ;   wslpi( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , : ) = 0._wp
390            ii0 =  69   ;   ii1 =  71   ;   wslpj( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , : ) = 0._wp
391            !
392            !                                                    ! Mediterrannean Sea
393            ij0 =  49   ;   ij1 =  56
394            ii0 =  71   ;   ii1 =  90   ;   uslp ( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , : ) = 0._wp
395            ij0 =  50   ;   ij1 =  56
396            ii0 =  70   ;   ii1 =  90   ;   vslp ( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , : ) = 0._wp
397            ii0 =  71   ;   ii1 =  90   ;   wslpi( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , : ) = 0._wp
398            ii0 =  71   ;   ii1 =  90   ;   wslpj( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , : ) = 0._wp
399         ENDIF
[3]400
[3294]401
[4488]402         ! IV. Lateral boundary conditions
403         ! ===============================
404         CALL lbc_lnk( uslp , 'U', -1. )      ;      CALL lbc_lnk( vslp , 'V', -1. )
405         CALL lbc_lnk( wslpi, 'W', -1. )      ;      CALL lbc_lnk( wslpj, 'W', -1. )
[3]406
[1515]407
[4488]408         IF(ln_ctl) THEN
409            CALL prt_ctl(tab3d_1=uslp , clinfo1=' slp  - u : ', tab3d_2=vslp,  clinfo2=' v : ', kdim=jpk)
410            CALL prt_ctl(tab3d_1=wslpi, clinfo1=' slp  - wi: ', tab3d_2=wslpj, clinfo2=' wj: ', kdim=jpk)
411         ENDIF
412         !
413
414      ELSEIF ( lk_vvl ) THEN
415 
416         IF(lwp) THEN
417            WRITE(numout,*) '          Horizontal mixing in s-coordinate: slope = slope of s-surfaces' 
418         ENDIF 
419
420         ! geopotential diffusion in s-coordinates on tracers and/or momentum
421         ! The slopes of s-surfaces are computed at each time step due to vvl
422         ! The slopes for momentum diffusion are i- or j- averaged of those on tracers
423
424         ! set the slope of diffusion to the slope of s-surfaces
425         !      ( c a u t i o n : minus sign as fsdep has positive value )
[5034]426         DO jj = 2, jpjm1 
427            DO ji = fs_2, fs_jpim1   ! vector opt.
428               uslp(ji,jj,1) = -1./e1u(ji,jj) * ( fsdept_b(ji+1,jj,1) - fsdept_b(ji ,jj ,1) )  * umask(ji,jj,1) 
429               vslp(ji,jj,1) = -1./e2v(ji,jj) * ( fsdept_b(ji,jj+1,1) - fsdept_b(ji ,jj ,1) )  * vmask(ji,jj,1) 
430               wslpi(ji,jj,1) = -1./e1t(ji,jj) * ( fsdepw_b(ji+1,jj,1) - fsdepw_b(ji-1,jj,1) ) * tmask(ji,jj,1) * 0.5 
431               wslpj(ji,jj,1) = -1./e2t(ji,jj) * ( fsdepw_b(ji,jj+1,1) - fsdepw_b(ji,jj-1,1) ) * tmask(ji,jj,1) * 0.5 
432            END DO
433         END DO
434
435         DO jk = 2, jpk 
[4488]436            DO jj = 2, jpjm1 
437               DO ji = fs_2, fs_jpim1   ! vector opt.
438                  uslp(ji,jj,jk) = -1./e1u(ji,jj) * ( fsdept_b(ji+1,jj,jk) - fsdept_b(ji ,jj ,jk) ) * umask(ji,jj,jk) 
439                  vslp(ji,jj,jk) = -1./e2v(ji,jj) * ( fsdept_b(ji,jj+1,jk) - fsdept_b(ji ,jj ,jk) ) * vmask(ji,jj,jk) 
[5034]440                  wslpi(ji,jj,jk) = -1./e1t(ji,jj) * ( fsdepw_b(ji+1,jj,jk) - fsdepw_b(ji-1,jj,jk) ) &
[5600]441                    &                              * wmask(ji,jj,jk) * 0.5 
[5034]442                  wslpj(ji,jj,jk) = -1./e2t(ji,jj) * ( fsdepw_b(ji,jj+1,jk) - fsdepw_b(ji,jj-1,jk) ) &
[5600]443                    &                              * wmask(ji,jj,jk) * 0.5 
[4488]444               END DO
445            END DO
446         END DO 
447
448         ! Lateral boundary conditions on the slopes
449         CALL lbc_lnk( uslp , 'U', -1. )      ;      CALL lbc_lnk( vslp , 'V', -1. ) 
450         CALL lbc_lnk( wslpi, 'W', -1. )      ;      CALL lbc_lnk( wslpj, 'W', -1. ) 
451 
452         if( kt == nit000 ) then
453            IF(lwp) WRITE(numout,*) ' max slop: u',SQRT( MAXVAL(uslp*uslp)), ' v ', SQRT(MAXVAL(vslp)),  & 
454               &                             ' wi', sqrt(MAXVAL(wslpi)), ' wj', sqrt(MAXVAL(wslpj)) 
455         endif
456 
457         IF(ln_ctl) THEN
458            CALL prt_ctl(tab3d_1=uslp , clinfo1=' slp  - u : ', tab3d_2=vslp,  clinfo2=' v : ', kdim=jpk) 
459            CALL prt_ctl(tab3d_1=wslpi, clinfo1=' slp  - wi: ', tab3d_2=wslpj, clinfo2=' wj: ', kdim=jpk) 
460         ENDIF
461
[49]462      ENDIF
[4488]463     
[3294]464      CALL wrk_dealloc( jpi,jpj,jpk, zwz, zww, zdzr, zgru, zgrv )
[5034]465      CALL wrk_dealloc( jpi,jpj,     zhmlpu, zhmlpv)
[2715]466      !
[3294]467      IF( nn_timing == 1 )  CALL timing_stop('ldf_slp')
468      !
[3]469   END SUBROUTINE ldf_slp
470
[3294]471
[2528]472   SUBROUTINE ldf_slp_grif ( kt )
473      !!----------------------------------------------------------------------
474      !!                 ***  ROUTINE ldf_slp_grif  ***
475      !!
476      !! ** Purpose :   Compute the squared slopes of neutral surfaces (slope
477      !!      of iso-pycnal surfaces referenced locally) (ln_traldf_grif=T)
[3294]478      !!      at W-points using the Griffies quarter-cells.
[2528]479      !!
[3294]480      !! ** Method  :   calculates alpha and beta at T-points
[2528]481      !!
482      !! ** Action : - triadi_g, triadj_g   T-pts i- and j-slope triads relative to geopot. (used for eiv)
483      !!             - triadi , triadj    T-pts i- and j-slope triads relative to model-coordinate
484      !!             - wslp2              squared slope of neutral surfaces at w-points.
485      !!----------------------------------------------------------------------
[3294]486      INTEGER, INTENT( in ) ::   kt             ! ocean time-step index
487      !!
[2528]488      INTEGER  ::   ji, jj, jk, jl, ip, jp, kp  ! dummy loop indices
[3294]489      INTEGER  ::   iku, ikv                    ! local integer
490      REAL(wp) ::   zfacti, zfactj              ! local scalars
491      REAL(wp) ::   znot_thru_surface           ! local scalars
492      REAL(wp) ::   zdit, zdis, zdjt, zdjs, zdkt, zdks, zbu, zbv, zbti, zbtj
493      REAL(wp) ::   zdxrho_raw, zti_coord, zti_raw, zti_lim, zti_g_raw, zti_g_lim
494      REAL(wp) ::   zdyrho_raw, ztj_coord, ztj_raw, ztj_lim, ztj_g_raw, ztj_g_lim
[2528]495      REAL(wp) ::   zdzrho_raw
[3294]496      REAL(wp), POINTER, DIMENSION(:,:)     ::   z1_mlbw
497      REAL(wp), POINTER, DIMENSION(:,:,:,:) ::   zdxrho , zdyrho, zdzrho     ! Horizontal and vertical density gradients
498      REAL(wp), POINTER, DIMENSION(:,:,:,:) ::   zti_mlb, ztj_mlb            ! for Griffies operator only
[2528]499      !!----------------------------------------------------------------------
[3294]500      !
501      IF( nn_timing == 1 )  CALL timing_start('ldf_slp_grif')
502      !
503      CALL wrk_alloc( jpi,jpj, z1_mlbw )
504      CALL wrk_alloc( jpi,jpj,jpk,2, zdxrho , zdyrho, zdzrho,              klstart = 0  )
505      CALL wrk_alloc( jpi,jpj,  2,2, zti_mlb, ztj_mlb,        kkstart = 0, klstart = 0  )
506      !
[2528]507      !--------------------------------!
508      !  Some preliminary calculation  !
509      !--------------------------------!
510      !
[3294]511      DO jl = 0, 1                            !==  unmasked before density i- j-, k-gradients  ==!
512         !
513         ip = jl   ;   jp = jl                ! guaranteed nonzero gradients ( absolute value larger than repsln)
514         DO jk = 1, jpkm1                     ! done each pair of triad
515            DO jj = 1, jpjm1                  ! NB: not masked ==>  a minimum value is set
516               DO ji = 1, fs_jpim1            ! vector opt.
517                  zdit = ( tsb(ji+1,jj,jk,jp_tem) - tsb(ji,jj,jk,jp_tem) )    ! i-gradient of T & S at u-point
518                  zdis = ( tsb(ji+1,jj,jk,jp_sal) - tsb(ji,jj,jk,jp_sal) )
519                  zdjt = ( tsb(ji,jj+1,jk,jp_tem) - tsb(ji,jj,jk,jp_tem) )    ! j-gradient of T & S at v-point
520                  zdjs = ( tsb(ji,jj+1,jk,jp_sal) - tsb(ji,jj,jk,jp_sal) )
[5034]521                  zdxrho_raw = ( - rab_b(ji+ip,jj   ,jk,jp_tem) * zdit + rab_b(ji+ip,jj   ,jk,jp_sal) * zdis ) / e1u(ji,jj)
522                  zdyrho_raw = ( - rab_b(ji   ,jj+jp,jk,jp_tem) * zdjt + rab_b(ji   ,jj+jp,jk,jp_sal) * zdjs ) / e2v(ji,jj)
523                  zdxrho(ji+ip,jj   ,jk,1-ip) = SIGN( MAX( repsln, ABS( zdxrho_raw ) ), zdxrho_raw )   ! keep the sign
[3294]524                  zdyrho(ji   ,jj+jp,jk,1-jp) = SIGN( MAX( repsln, ABS( zdyrho_raw ) ), zdyrho_raw )
525               END DO
[2528]526            END DO
527         END DO
[3294]528         !
[5034]529         IF( ln_zps .AND. l_grad_zps ) THEN     ! partial steps: correction of i- & j-grad on bottom
[3294]530            DO jj = 1, jpjm1
531               DO ji = 1, jpim1
532                  iku  = mbku(ji,jj)          ;   ikv  = mbkv(ji,jj)             ! last ocean level (u- & v-points)
533                  zdit = gtsu(ji,jj,jp_tem)   ;   zdjt = gtsv(ji,jj,jp_tem)      ! i- & j-gradient of Temperature
534                  zdis = gtsu(ji,jj,jp_sal)   ;   zdjs = gtsv(ji,jj,jp_sal)      ! i- & j-gradient of Salinity
[5034]535                  zdxrho_raw = ( - rab_b(ji+ip,jj   ,iku,jp_tem) * zdit + rab_b(ji+ip,jj   ,iku,jp_sal) * zdis ) / e1u(ji,jj)
536                  zdyrho_raw = ( - rab_b(ji   ,jj+jp,ikv,jp_tem) * zdjt + rab_b(ji   ,jj+jp,ikv,jp_sal) * zdjs ) / e2v(ji,jj)
[3294]537                  zdxrho(ji+ip,jj   ,iku,1-ip) = SIGN( MAX( repsln, ABS( zdxrho_raw ) ), zdxrho_raw )   ! keep the sign
538                  zdyrho(ji   ,jj+jp,ikv,1-jp) = SIGN( MAX( repsln, ABS( zdyrho_raw ) ), zdyrho_raw )
[2528]539               END DO
540            END DO
[3294]541         ENDIF
542         !
[2528]543      END DO
[3294]544
545      DO kp = 0, 1                            !==  unmasked before density i- j-, k-gradients  ==!
546         DO jk = 1, jpkm1                     ! done each pair of triad
547            DO jj = 1, jpj                    ! NB: not masked ==>  a minimum value is set
548               DO ji = 1, jpi                 ! vector opt.
549                  IF( jk+kp > 1 ) THEN        ! k-gradient of T & S a jk+kp
550                     zdkt = ( tsb(ji,jj,jk+kp-1,jp_tem) - tsb(ji,jj,jk+kp,jp_tem) )
551                     zdks = ( tsb(ji,jj,jk+kp-1,jp_sal) - tsb(ji,jj,jk+kp,jp_sal) )
552                  ELSE
553                     zdkt = 0._wp                                             ! 1st level gradient set to zero
554                     zdks = 0._wp
555                  ENDIF
[5034]556                  zdzrho_raw = ( - rab_b(ji,jj,jk,jp_tem) * zdkt + rab_b(ji,jj,jk,jp_sal) * zdks ) / fse3w(ji,jj,jk+kp)
557                  zdzrho(ji,jj,jk,kp) = - MIN( - repsln, zdzrho_raw )    ! force zdzrho >= repsln
[3294]558                 END DO
[2528]559            END DO
560         END DO
561      END DO
562      !
[3294]563      DO jj = 1, jpj                          !==  Reciprocal depth of the w-point below ML base  ==!
[2528]564         DO ji = 1, jpi
565            jk = MIN( nmln(ji,jj), mbkt(ji,jj) ) + 1     ! MIN in case ML depth is the ocean depth
566            z1_mlbw(ji,jj) = 1._wp / fsdepw(ji,jj,jk)
567         END DO
568      END DO
569      !
[3294]570      !                                       !==  intialisations to zero  ==!
[2528]571      !
[3294]572      wslp2  (:,:,:)     = 0._wp              ! wslp2 will be cumulated 3D field set to zero
573      triadi_g(:,:,1,:,:) = 0._wp   ;   triadi_g(:,:,jpk,:,:) = 0._wp   ! set surface and bottom slope to zero
[2528]574      triadj_g(:,:,1,:,:) = 0._wp   ;   triadj_g(:,:,jpk,:,:) = 0._wp
[3294]575      !!gm _iso set to zero missing
576      triadi  (:,:,1,:,:) = 0._wp   ;   triadj  (:,:,jpk,:,:) = 0._wp   ! set surface and bottom slope to zero
577      triadj  (:,:,1,:,:) = 0._wp   ;   triadj  (:,:,jpk,:,:) = 0._wp
578
[2528]579      !-------------------------------------!
580      !  Triads just below the Mixed Layer  !
581      !-------------------------------------!
582      !
[3294]583      DO jl = 0, 1                            ! calculate slope of the 4 triads immediately ONE level below mixed-layer base
584         DO kp = 0, 1                         ! with only the slope-max limit   and   MASKED
[2528]585            DO jj = 1, jpjm1
586               DO ji = 1, fs_jpim1
587                  ip = jl   ;   jp = jl
[3845]588                  !
589                  jk = nmln(ji+ip,jj) + 1
590                  IF( jk .GT. mbkt(ji+ip,jj) ) THEN  !ML reaches bottom
591                    zti_mlb(ji+ip,jj   ,1-ip,kp) = 0.0_wp
592                  ELSE
593                    ! Add s-coordinate slope at t-points (do this by *subtracting* gradient of depth)
594                    zti_g_raw = (  zdxrho(ji+ip,jj,jk-kp,1-ip) / zdzrho(ji+ip,jj,jk-kp,kp)      &
595                       &      - ( fsdept(ji+1,jj,jk-kp) - fsdept(ji,jj,jk-kp) ) / e1u(ji,jj)  ) * umask(ji,jj,jk)
596                    zti_mlb(ji+ip,jj   ,1-ip,kp) = SIGN( MIN( rn_slpmax, ABS( zti_g_raw ) ), zti_g_raw )
597                  ENDIF
598                  !
599                  jk = nmln(ji,jj+jp) + 1
600                  IF( jk .GT. mbkt(ji,jj+jp) ) THEN  !ML reaches bottom
601                    ztj_mlb(ji   ,jj+jp,1-jp,kp) = 0.0_wp
602                  ELSE
603                    ztj_g_raw = (  zdyrho(ji,jj+jp,jk-kp,1-jp) / zdzrho(ji,jj+jp,jk-kp,kp)      &
604                       &      - ( fsdept(ji,jj+1,jk-kp) - fsdept(ji,jj,jk-kp) ) / e2v(ji,jj)  ) * vmask(ji,jj,jk)
605                    ztj_mlb(ji   ,jj+jp,1-jp,kp) = SIGN( MIN( rn_slpmax, ABS( ztj_g_raw ) ), ztj_g_raw )
606                  ENDIF
[2528]607               END DO
608            END DO
609         END DO
610      END DO
611
612      !-------------------------------------!
613      !  Triads with surface limits         !
614      !-------------------------------------!
615      !
[3294]616      DO kp = 0, 1                            ! k-index of triads
[2528]617         DO jl = 0, 1
[3294]618            ip = jl   ;   jp = jl             ! i- and j-indices of triads (i-k and j-k planes)
[2528]619            DO jk = 1, jpkm1
[3294]620               ! Must mask contribution to slope from dz/dx at constant s for triads jk=1,kp=0 that poke up though ocean surface
621               znot_thru_surface = REAL( 1-1/(jk+kp), wp )  !jk+kp=1,=0.; otherwise=1.0
[2528]622               DO jj = 1, jpjm1
[3294]623                  DO ji = 1, fs_jpim1         ! vector opt.
[2528]624                     !
625                     ! Calculate slope relative to geopotentials used for GM skew fluxes
[3294]626                     ! Add s-coordinate slope at t-points (do this by *subtracting* gradient of depth)
[2528]627                     ! Limit by slope *relative to geopotentials* by rn_slpmax, and mask by psi-point
628                     ! masked by umask taken at the level of dz(rho)
629                     !
630                     ! raw slopes: unmasked unbounded slopes (relative to geopotential (zti_g) and model surface (zti)
631                     !
632                     zti_raw   = zdxrho(ji+ip,jj   ,jk,1-ip) / zdzrho(ji+ip,jj   ,jk,kp)                   ! unmasked
633                     ztj_raw   = zdyrho(ji   ,jj+jp,jk,1-jp) / zdzrho(ji   ,jj+jp,jk,kp)
[3294]634
635                     ! Must mask contribution to slope for triad jk=1,kp=0 that poke up though ocean surface
636                     zti_coord = znot_thru_surface * ( fsdept(ji+1,jj  ,jk) - fsdept(ji,jj,jk) ) / e1u(ji,jj)
637                     ztj_coord = znot_thru_surface * ( fsdept(ji  ,jj+1,jk) - fsdept(ji,jj,jk) ) / e2v(ji,jj)                  ! unmasked
638                     zti_g_raw = zti_raw - zti_coord      ! ref to geopot surfaces
639                     ztj_g_raw = ztj_raw - ztj_coord
[2528]640                     zti_g_lim = SIGN( MIN( rn_slpmax, ABS( zti_g_raw ) ), zti_g_raw )
641                     ztj_g_lim = SIGN( MIN( rn_slpmax, ABS( ztj_g_raw ) ), ztj_g_raw )
642                     !
[3294]643                     ! Below  ML use limited zti_g as is & mask
644                     ! Inside ML replace by linearly reducing sx_mlb towards surface & mask
[2528]645                     !
646                     zfacti = REAL( 1 - 1/(1 + (jk+kp-1)/nmln(ji+ip,jj)), wp )  ! k index of uppermost point(s) of triad is jk+kp-1
647                     zfactj = REAL( 1 - 1/(1 + (jk+kp-1)/nmln(ji,jj+jp)), wp )  ! must be .ge. nmln(ji,jj) for zfact=1
648                     !                                                          !                   otherwise  zfact=0
[3294]649                     zti_g_lim =          ( zfacti   * zti_g_lim                       &
[2528]650                        &      + ( 1._wp - zfacti ) * zti_mlb(ji+ip,jj,1-ip,kp)   &
[3294]651                        &                           * fsdepw(ji+ip,jj,jk+kp) * z1_mlbw(ji+ip,jj) ) * umask(ji,jj,jk+kp)
652                     ztj_g_lim =          ( zfactj   * ztj_g_lim                       &
[2528]653                        &      + ( 1._wp - zfactj ) * ztj_mlb(ji,jj+jp,1-jp,kp)   &
[3294]654                        &                           * fsdepw(ji,jj+jp,jk+kp) * z1_mlbw(ji,jj+jp) ) * vmask(ji,jj,jk+kp)
[2528]655                     !
[3294]656                     triadi_g(ji+ip,jj   ,jk,1-ip,kp) = zti_g_lim
657                     triadj_g(ji   ,jj+jp,jk,1-jp,kp) = ztj_g_lim
[2528]658                     !
659                     ! Get coefficients of isoneutral diffusion tensor
660                     ! 1. Utilise gradients *relative* to s-coordinate, so add t-point slopes (*subtract* depth gradients)
661                     ! 2. We require that isoneutral diffusion  gives no vertical buoyancy flux
662                     !     i.e. 33 term = (real slope* 31, 13 terms)
663                     ! To do this, retain limited sx**2  in vertical flux, but divide by real slope for 13/31 terms
664                     ! Equivalent to tapering A_iso = sx_limited**2/(real slope)**2
665                     !
[3294]666                     zti_lim  = ( zti_g_lim + zti_coord ) * umask(ji,jj,jk+kp)    ! remove coordinate slope => relative to coordinate surfaces
667                     ztj_lim  = ( ztj_g_lim + ztj_coord ) * vmask(ji,jj,jk+kp)
[2528]668                     !
[3294]669                     IF( ln_triad_iso ) THEN
670                        zti_raw = zti_lim**2 / zti_raw
671                        ztj_raw = ztj_lim**2 / ztj_raw
672                        zti_raw = SIGN( MIN( ABS(zti_lim), ABS( zti_raw ) ), zti_raw )
673                        ztj_raw = SIGN( MIN( ABS(ztj_lim), ABS( ztj_raw ) ), ztj_raw )
674                        zti_lim =           zfacti   * zti_lim                       &
675                        &      + ( 1._wp - zfacti ) * zti_raw
676                        ztj_lim =           zfactj   * ztj_lim                       &
677                        &      + ( 1._wp - zfactj ) * ztj_raw
678                     ENDIF
679                     triadi(ji+ip,jj   ,jk,1-ip,kp) = zti_lim
680                     triadj(ji   ,jj+jp,jk,1-jp,kp) = ztj_lim
681                    !
[2528]682                     zbu = e1u(ji    ,jj) * e2u(ji   ,jj) * fse3u(ji   ,jj,jk   )
683                     zbv = e1v(ji    ,jj) * e2v(ji   ,jj) * fse3v(ji   ,jj,jk   )
684                     zbti = e1t(ji+ip,jj) * e2t(ji+ip,jj) * fse3w(ji+ip,jj,jk+kp)
685                     zbtj = e1t(ji,jj+jp) * e2t(ji,jj+jp) * fse3w(ji,jj+jp,jk+kp)
686                     !
[3294]687                     !!gm this may inhibit vectorization on Vect Computers, and even on scalar computers....  ==> to be checked
688                     wslp2 (ji+ip,jj,jk+kp) = wslp2(ji+ip,jj,jk+kp) + 0.25_wp * zbu / zbti * zti_g_lim**2      ! masked
689                     wslp2 (ji,jj+jp,jk+kp) = wslp2(ji,jj+jp,jk+kp) + 0.25_wp * zbv / zbtj * ztj_g_lim**2
[2528]690                  END DO
691               END DO
692            END DO
693         END DO
694      END DO
695      !
696      wslp2(:,:,1) = 0._wp                ! force the surface wslp to zero
[3294]697
[2528]698      CALL lbc_lnk( wslp2, 'W', 1. )      ! lateral boundary confition on wslp2 only   ==>>> gm : necessary ? to be checked
699      !
[3294]700      CALL wrk_dealloc( jpi,jpj, z1_mlbw )
701      CALL wrk_dealloc( jpi,jpj,jpk,2, zdxrho , zdyrho, zdzrho,              klstart = 0  )
702      CALL wrk_dealloc( jpi,jpj,  2,2, zti_mlb, ztj_mlb,        kkstart = 0, klstart = 0  )
[2715]703      !
[3294]704      IF( nn_timing == 1 )  CALL timing_stop('ldf_slp_grif')
705      !
[2528]706   END SUBROUTINE ldf_slp_grif
707
708
709   SUBROUTINE ldf_slp_mxl( prd, pn2, p_gru, p_grv, p_dzr )
[3]710      !!----------------------------------------------------------------------
711      !!                  ***  ROUTINE ldf_slp_mxl  ***
712      !!
[3294]713      !! ** Purpose :   Compute the slopes of iso-neutral surface just below
[1515]714      !!              the mixed layer.
715      !!
[2528]716      !! ** Method  :   The slope in the i-direction is computed at u- & w-points
717      !!              (uslpml, wslpiml) and the slope in the j-direction is computed
718      !!              at v- and w-points (vslpml, wslpjml) with the same bounds as
719      !!              in ldf_slp.
[3]720      !!
[2389]721      !! ** Action  :   uslpml, wslpiml :  i- &  j-slopes of neutral surfaces
[3294]722      !!                vslpml, wslpjml    just below the mixed layer
[2389]723      !!                omlmask         :  mixed layer mask
[1515]724      !!----------------------------------------------------------------------
[2715]725      REAL(wp), DIMENSION(:,:,:), INTENT(in) ::   prd            ! in situ density
726      REAL(wp), DIMENSION(:,:,:), INTENT(in) ::   pn2            ! Brunt-Vaisala frequency (locally ref.)
727      REAL(wp), DIMENSION(:,:,:), INTENT(in) ::   p_gru, p_grv   ! i- & j-gradient of density (u- & v-pts)
728      REAL(wp), DIMENSION(:,:,:), INTENT(in) ::   p_dzr          ! z-gradient of density      (T-point)
[3]729      !!
[3294]730      INTEGER  ::   ji , jj , jk                   ! dummy loop indices
731      INTEGER  ::   iku, ikv, ik, ikm1             ! local integers
[2528]732      REAL(wp) ::   zeps, zm1_g, zm1_2g            ! local scalars
733      REAL(wp) ::   zci, zfi, zau, zbu, zai, zbi   !   -      -
734      REAL(wp) ::   zcj, zfj, zav, zbv, zaj, zbj   !   -      -
735      REAL(wp) ::   zck, zfk,      zbw             !   -      -
[3]736      !!----------------------------------------------------------------------
[3294]737      !
738      IF( nn_timing == 1 )  CALL timing_start('ldf_slp_mxl')
739      !
[2528]740      zeps   =  1.e-20_wp        !==   Local constant initialization   ==!
741      zm1_g  = -1.0_wp / grav
742      zm1_2g = -0.5_wp / grav
[1515]743      !
[2528]744      uslpml (1,:) = 0._wp      ;      uslpml (jpi,:) = 0._wp
745      vslpml (1,:) = 0._wp      ;      vslpml (jpi,:) = 0._wp
746      wslpiml(1,:) = 0._wp      ;      wslpiml(jpi,:) = 0._wp
747      wslpjml(1,:) = 0._wp      ;      wslpjml(jpi,:) = 0._wp
748      !
[3294]749      !                                            !==   surface mixed layer mask   !
750      DO jk = 1, jpk                               ! =1 inside the mixed layer, =0 otherwise
[3]751         DO jj = 1, jpj
752            DO ji = 1, jpi
753               ik = nmln(ji,jj) - 1
[5600]754               IF( jk <= ik .AND. jk >= mikt(ji,jj) ) THEN
755                  omlmask(ji,jj,jk) = 1._wp
756               ELSE
757                  omlmask(ji,jj,jk) = 0._wp
[3]758               ENDIF
759            END DO
760         END DO
761      END DO
762
763
764      ! Slopes of isopycnal surfaces just before bottom of mixed layer
765      ! --------------------------------------------------------------
[1515]766      ! The slope are computed as in the 3D case.
767      ! A key point here is the definition of the mixed layer at u- and v-points.
768      ! It is assumed to be the maximum of the two neighbouring T-point mixed layer depth.
769      ! Otherwise, a n2 value inside the mixed layer can be involved in the computation
770      ! of the slope, resulting in a too steep diagnosed slope and thus a spurious eddy
771      ! induce velocity field near the base of the mixed layer.
[3]772      !-----------------------------------------------------------------------
[1515]773      !
[3]774      DO jj = 2, jpjm1
775         DO ji = 2, jpim1
[3294]776            !                        !==   Slope at u- & v-points just below the Mixed Layer   ==!
[2528]777            !
[3294]778            !                        !- vertical density gradient for u- and v-slopes (from dzr at T-point)
[5034]779            iku = MIN(  MAX( miku(ji,jj)+1, nmln(ji,jj) , nmln(ji+1,jj) ) , jpkm1  )   ! ML (MAX of T-pts, bound by jpkm1)
780            ikv = MIN(  MAX( mikv(ji,jj)+1, nmln(ji,jj) , nmln(ji,jj+1) ) , jpkm1  )   !
[2528]781            zbu = 0.5_wp * ( p_dzr(ji,jj,iku) + p_dzr(ji+1,jj  ,iku) )
782            zbv = 0.5_wp * ( p_dzr(ji,jj,ikv) + p_dzr(ji  ,jj+1,ikv) )
[3294]783            !                        !- horizontal density gradient at u- & v-points
[2528]784            zau = p_gru(ji,jj,iku) / e1u(ji,jj)
785            zav = p_grv(ji,jj,ikv) / e2v(ji,jj)
[3294]786            !                        !- bound the slopes: abs(zw.)<= 1/100 and zb..<0
787            !                           kxz max= ah slope max =< e1 e3 /(pi**2 2 dt)
[2772]788            zbu = MIN(  zbu , -100._wp* ABS( zau ) , -7.e+3_wp/fse3u(ji,jj,iku)* ABS( zau )  )
789            zbv = MIN(  zbv , -100._wp* ABS( zav ) , -7.e+3_wp/fse3v(ji,jj,ikv)* ABS( zav )  )
[3294]790            !                        !- Slope at u- & v-points (uslpml, vslpml)
[2772]791            uslpml(ji,jj) = zau / ( zbu - zeps ) * umask(ji,jj,iku)
792            vslpml(ji,jj) = zav / ( zbv - zeps ) * vmask(ji,jj,ikv)
[2528]793            !
[3294]794            !                        !==   i- & j-slopes at w-points just below the Mixed Layer   ==!
[2528]795            !
796            ik   = MIN( nmln(ji,jj) + 1, jpk )
797            ikm1 = MAX( 1, ik-1 )
[3294]798            !                        !- vertical density gradient for w-slope (from N^2)
[2528]799            zbw = zm1_2g * pn2 (ji,jj,ik) * ( prd (ji,jj,ik) + prd (ji,jj,ikm1) + 2. )
[3294]800            !                        !- horizontal density i- & j-gradient at w-points
[2528]801            zci = MAX(   umask(ji-1,jj,ik  ) + umask(ji,jj,ik  )           &
[3294]802               &       + umask(ji-1,jj,ikm1) + umask(ji,jj,ikm1) , zeps  ) * e1t(ji,jj)
[2528]803            zcj = MAX(   vmask(ji,jj-1,ik  ) + vmask(ji,jj,ik  )           &
804               &       + vmask(ji,jj-1,ikm1) + vmask(ji,jj,ikm1) , zeps  ) * e2t(ji,jj)
805            zai =    (   p_gru(ji-1,jj,ik  ) + p_gru(ji,jj,ik)           &
806               &       + p_gru(ji-1,jj,ikm1) + p_gru(ji,jj,ikm1  )  ) / zci  * tmask(ji,jj,ik)
807            zaj =    (   p_grv(ji,jj-1,ik  ) + p_grv(ji,jj,ik  )           &
808               &       + p_grv(ji,jj-1,ikm1) + p_grv(ji,jj,ikm1)  ) / zcj  * tmask(ji,jj,ik)
[3294]809            !                        !- bound the slopes: abs(zw.)<= 1/100 and zb..<0.
810            !                           kxz max= ah slope max =< e1 e3 /(pi**2 2 dt)
[2528]811            zbi = MIN(  zbw , -100._wp* ABS( zai ) , -7.e+3_wp/fse3w(ji,jj,ik)* ABS( zai )  )
812            zbj = MIN(  zbw , -100._wp* ABS( zaj ) , -7.e+3_wp/fse3w(ji,jj,ik)* ABS( zaj )  )
[3294]813            !                        !- i- & j-slope at w-points (wslpiml, wslpjml)
[5600]814            wslpiml(ji,jj) = zai / ( zbi - zeps ) * wmask (ji,jj,ik)
815            wslpjml(ji,jj) = zaj / ( zbj - zeps ) * wmask (ji,jj,ik)
[3]816         END DO
817      END DO
[3294]818      !!gm this lbc_lnk should be useless....
[2528]819      CALL lbc_lnk( uslpml , 'U', -1. )   ;   CALL lbc_lnk( vslpml , 'V', -1. )   ! lateral boundary cond. (sign change)
820      CALL lbc_lnk( wslpiml, 'W', -1. )   ;   CALL lbc_lnk( wslpjml, 'W', -1. )   ! lateral boundary conditions
[1515]821      !
[3294]822      IF( nn_timing == 1 )  CALL timing_stop('ldf_slp_mxl')
823      !
[3]824   END SUBROUTINE ldf_slp_mxl
825
826
827   SUBROUTINE ldf_slp_init
828      !!----------------------------------------------------------------------
829      !!                  ***  ROUTINE ldf_slp_init  ***
830      !!
831      !! ** Purpose :   Initialization for the isopycnal slopes computation
832      !!
[3294]833      !! ** Method  :   read the nammbf namelist and check the parameter
834      !!      values called by tra_dmp at the first timestep (nit000)
[3]835      !!----------------------------------------------------------------------
836      INTEGER ::   ji, jj, jk   ! dummy loop indices
[2528]837      INTEGER ::   ierr         ! local integer
[3]838      !!----------------------------------------------------------------------
[3294]839      !
840      IF( nn_timing == 1 )  CALL timing_start('ldf_slp_init')
841      !
842      IF(lwp) THEN
[3]843         WRITE(numout,*)
[2528]844         WRITE(numout,*) 'ldf_slp_init : direction of lateral mixing'
845         WRITE(numout,*) '~~~~~~~~~~~~'
[3]846      ENDIF
[3294]847
[2528]848      IF( ln_traldf_grif ) THEN        ! Griffies operator : triad of slopes
849         ALLOCATE( triadi_g(jpi,jpj,jpk,0:1,0:1) , triadj_g(jpi,jpj,jpk,0:1,0:1) , wslp2(jpi,jpj,jpk) , STAT=ierr )
850         ALLOCATE( triadi  (jpi,jpj,jpk,0:1,0:1) , triadj  (jpi,jpj,jpk,0:1,0:1)                      , STAT=ierr )
[2715]851         IF( ierr > 0             )   CALL ctl_stop( 'STOP', 'ldf_slp_init : unable to allocate Griffies operator slope' )
[2528]852         !
853         IF( ln_dynldf_iso )   CALL ctl_stop( 'ldf_slp_init: Griffies operator on momentum not supported' )
854         !
855      ELSE                             ! Madec operator : slopes at u-, v-, and w-points
856         ALLOCATE( uslp(jpi,jpj,jpk) , vslp(jpi,jpj,jpk) , wslpi(jpi,jpj,jpk) , wslpj(jpi,jpj,jpk) ,                &
857            &   omlmask(jpi,jpj,jpk) , uslpml(jpi,jpj)   , vslpml(jpi,jpj)    , wslpiml(jpi,jpj)   , wslpjml(jpi,jpj) , STAT=ierr )
[2715]858         IF( ierr > 0 )   CALL ctl_stop( 'STOP', 'ldf_slp_init : unable to allocate Madec operator slope ' )
[3]859
[2528]860         ! Direction of lateral diffusion (tracers and/or momentum)
861         ! ------------------------------
862         uslp (:,:,:) = 0._wp   ;   uslpml (:,:) = 0._wp      ! set the slope to zero (even in s-coordinates)
863         vslp (:,:,:) = 0._wp   ;   vslpml (:,:) = 0._wp
864         wslpi(:,:,:) = 0._wp   ;   wslpiml(:,:) = 0._wp
865         wslpj(:,:,:) = 0._wp   ;   wslpjml(:,:) = 0._wp
[3]866
[5034]867         IF(ln_sco .AND.  (ln_traldf_hor .OR. ln_dynldf_hor )) THEN
[2715]868            IF(lwp)   WRITE(numout,*) '          Horizontal mixing in s-coordinate: slope = slope of s-surfaces'
[3]869
[2528]870            ! geopotential diffusion in s-coordinates on tracers and/or momentum
871            ! The slopes of s-surfaces are computed once (no call to ldfslp in step)
872            ! The slopes for momentum diffusion are i- or j- averaged of those on tracers
[3]873
[2528]874            ! set the slope of diffusion to the slope of s-surfaces
875            !      ( c a u t i o n : minus sign as fsdep has positive value )
876            DO jk = 1, jpk
877               DO jj = 2, jpjm1
878                  DO ji = fs_2, fs_jpim1   ! vector opt.
[4488]879                     uslp (ji,jj,jk) = -1./e1u(ji,jj) * ( fsdept_b(ji+1,jj,jk) - fsdept_b(ji ,jj ,jk) ) * umask(ji,jj,jk)
880                     vslp (ji,jj,jk) = -1./e2v(ji,jj) * ( fsdept_b(ji,jj+1,jk) - fsdept_b(ji ,jj ,jk) ) * vmask(ji,jj,jk)
881                     wslpi(ji,jj,jk) = -1./e1t(ji,jj) * ( fsdepw_b(ji+1,jj,jk) - fsdepw_b(ji-1,jj,jk) ) * tmask(ji,jj,jk) * 0.5
882                     wslpj(ji,jj,jk) = -1./e2t(ji,jj) * ( fsdepw_b(ji,jj+1,jk) - fsdepw_b(ji,jj-1,jk) ) * tmask(ji,jj,jk) * 0.5
[2528]883                  END DO
[3]884               END DO
885            END DO
[2715]886            CALL lbc_lnk( uslp , 'U', -1. )   ;   CALL lbc_lnk( vslp , 'V', -1. )      ! Lateral boundary conditions
887            CALL lbc_lnk( wslpi, 'W', -1. )   ;   CALL lbc_lnk( wslpj, 'W', -1. )
[2528]888         ENDIF
[2715]889      ENDIF
890      !
[3294]891      IF( nn_timing == 1 )  CALL timing_stop('ldf_slp_init')
892      !
[3]893   END SUBROUTINE ldf_slp_init
894
895#else
896   !!------------------------------------------------------------------------
897   !!   Dummy module :                 NO Rotation of lateral mixing tensor
898   !!------------------------------------------------------------------------
[32]899   LOGICAL, PUBLIC, PARAMETER ::   lk_ldfslp = .FALSE.    !: slopes flag
[3]900CONTAINS
[3294]901   SUBROUTINE ldf_slp( kt, prd, pn2 )   ! Dummy routine
902      INTEGER, INTENT(in) :: kt
[1515]903      REAL, DIMENSION(:,:,:), INTENT(in) :: prd, pn2
[32]904      WRITE(*,*) 'ldf_slp: You should not have seen this print! error?', kt, prd(1,1,1), pn2(1,1,1)
[3]905   END SUBROUTINE ldf_slp
[2605]906   SUBROUTINE ldf_slp_grif( kt )        ! Dummy routine
907      INTEGER, INTENT(in) :: kt
908      WRITE(*,*) 'ldf_slp_grif: You should not have seen this print! error?', kt
909   END SUBROUTINE ldf_slp_grif
[3294]910   SUBROUTINE ldf_slp_init              ! Dummy routine
[2528]911   END SUBROUTINE ldf_slp_init
[3]912#endif
913
914   !!======================================================================
915END MODULE ldfslp
Note: See TracBrowser for help on using the repository browser.