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.
zdfgls.F90 in branches/UKMO/dev_r7750_GO6_package_oasis_timers/NEMOGCM/NEMO/OPA_SRC/ZDF – NEMO

source: branches/UKMO/dev_r7750_GO6_package_oasis_timers/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfgls.F90 @ 9252

Last change on this file since 9252 was 9252, checked in by andmirek, 6 years ago

#1978 timers for nn_timing 3

File size: 57.9 KB
RevLine 
[2048]1MODULE zdfgls
2   !!======================================================================
3   !!                       ***  MODULE  zdfgls  ***
4   !! Ocean physics:  vertical mixing coefficient computed from the gls
5   !!                 turbulent closure parameterization
6   !!======================================================================
[2397]7   !! History :   3.0  !  2009-09  (G. Reffray)  Original code
8   !!             3.3  !  2010-10  (C. Bricaud)  Add in the reference
[2048]9   !!----------------------------------------------------------------------
10#if defined key_zdfgls   ||   defined key_esopa
11   !!----------------------------------------------------------------------
12   !!   'key_zdfgls'                 Generic Length Scale vertical physics
13   !!----------------------------------------------------------------------
[3625]14   !!   zdf_gls       : update momentum and tracer Kz from a gls scheme
15   !!   zdf_gls_init  : initialization, namelist read, and parameters control
16   !!   gls_rst       : read/write gls restart in ocean restart file
[2048]17   !!----------------------------------------------------------------------
18   USE oce            ! ocean dynamics and active tracers
19   USE dom_oce        ! ocean space and time domain
20   USE domvvl         ! ocean space and time domain : variable volume layer
21   USE zdf_oce        ! ocean vertical physics
[5109]22   USE zdfbfr         ! bottom friction (only for rn_bfrz0)
[2048]23   USE sbc_oce        ! surface boundary condition: ocean
24   USE phycst         ! physical constants
25   USE zdfmxl         ! mixed layer
26   USE lbclnk         ! ocean lateral boundary conditions (or mpp link)
[2715]27   USE lib_mpp        ! MPP manager
[3294]28   USE wrk_nemo       ! work arrays
[2048]29   USE prtctl         ! Print control
30   USE in_out_manager ! I/O manager
31   USE iom            ! I/O manager library
[3294]32   USE timing         ! Timing
[3625]33   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 
[2048]34
35   IMPLICIT NONE
36   PRIVATE
37
[2329]38   PUBLIC   zdf_gls        ! routine called in step module
[2397]39   PUBLIC   zdf_gls_init   ! routine called in opa module
[2329]40   PUBLIC   gls_rst        ! routine called in step module
[2048]41
[2715]42   LOGICAL , PUBLIC, PARAMETER ::   lk_zdfgls = .TRUE.   !: TKE vertical mixing flag
43   !
44   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   mxln    !: now mixing length
45   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   zwall   !: wall function
46   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   ustars2 !: Squared surface velocity scale at T-points
47   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   ustarb2 !: Squared bottom  velocity scale at T-points
[2048]48
[4147]49   !                              !! ** Namelist  namzdf_gls  **
50   LOGICAL  ::   ln_length_lim     ! use limit on the dissipation rate under stable stratification (Galperin et al. 1988)
51   LOGICAL  ::   ln_sigpsi         ! Activate Burchard (2003) modification for k-eps closure & wave breaking mixing
[5109]52   INTEGER  ::   nn_bc_surf        ! surface boundary condition (=0/1)
53   INTEGER  ::   nn_bc_bot         ! bottom boundary condition (=0/1)
54   INTEGER  ::   nn_z0_met         ! Method for surface roughness computation
[4147]55   INTEGER  ::   nn_stab_func      ! stability functions G88, KC or Canuto (=0/1/2)
56   INTEGER  ::   nn_clos           ! closure 0/1/2/3 MY82/k-eps/k-w/gen
57   REAL(wp) ::   rn_clim_galp      ! Holt 2008 value for k-eps: 0.267
58   REAL(wp) ::   rn_epsmin         ! minimum value of dissipation (m2/s3)
59   REAL(wp) ::   rn_emin           ! minimum value of TKE (m2/s2)
60   REAL(wp) ::   rn_charn          ! Charnock constant for surface breaking waves mixing : 1400. (standard) or 2.e5 (Stacey value)
61   REAL(wp) ::   rn_crban          ! Craig and Banner constant for surface breaking waves mixing
[5109]62   REAL(wp) ::   rn_hsro           ! Minimum surface roughness
63   REAL(wp) ::   rn_frac_hs        ! Fraction of wave height as surface roughness (if nn_z0_met > 1)
[2048]64
[2397]65   REAL(wp) ::   rcm_sf        =  0.73_wp     ! Shear free turbulence parameters
66   REAL(wp) ::   ra_sf         = -2.0_wp      ! Must be negative -2 < ra_sf < -1
67   REAL(wp) ::   rl_sf         =  0.2_wp      ! 0 <rl_sf<vkarmn   
68   REAL(wp) ::   rghmin        = -0.28_wp
69   REAL(wp) ::   rgh0          =  0.0329_wp
70   REAL(wp) ::   rghcri        =  0.03_wp
[2299]71   REAL(wp) ::   ra1           =  0.92_wp
72   REAL(wp) ::   ra2           =  0.74_wp
73   REAL(wp) ::   rb1           = 16.60_wp
74   REAL(wp) ::   rb2           = 10.10_wp         
75   REAL(wp) ::   re2           =  1.33_wp         
76   REAL(wp) ::   rl1           =  0.107_wp
77   REAL(wp) ::   rl2           =  0.0032_wp
78   REAL(wp) ::   rl3           =  0.0864_wp
79   REAL(wp) ::   rl4           =  0.12_wp
80   REAL(wp) ::   rl5           = 11.9_wp
81   REAL(wp) ::   rl6           =  0.4_wp
82   REAL(wp) ::   rl7           =  0.0_wp
83   REAL(wp) ::   rl8           =  0.48_wp
84   REAL(wp) ::   rm1           =  0.127_wp
85   REAL(wp) ::   rm2           =  0.00336_wp
86   REAL(wp) ::   rm3           =  0.0906_wp
87   REAL(wp) ::   rm4           =  0.101_wp
88   REAL(wp) ::   rm5           = 11.2_wp
89   REAL(wp) ::   rm6           =  0.4_wp
90   REAL(wp) ::   rm7           =  0.0_wp
91   REAL(wp) ::   rm8           =  0.318_wp
[5109]92   REAL(wp) ::   rtrans        =  0.1_wp
[2397]93   REAL(wp) ::   rc02, rc02r, rc03, rc04                          ! coefficients deduced from above parameters
[5109]94   REAL(wp) ::   rsbc_tke1, rsbc_tke2, rfact_tke                  !     -           -           -        -
95   REAL(wp) ::   rsbc_psi1, rsbc_psi2, rfact_psi                  !     -           -           -        -
96   REAL(wp) ::   rsbc_zs1, rsbc_zs2                               !     -           -           -        -
[2397]97   REAL(wp) ::   rc0, rc2, rc3, rf6, rcff, rc_diff                !     -           -           -        -
98   REAL(wp) ::   rs0, rs1, rs2, rs4, rs5, rs6                     !     -           -           -        -
99   REAL(wp) ::   rd0, rd1, rd2, rd3, rd4, rd5                     !     -           -           -        -
100   REAL(wp) ::   rsc_tke, rsc_psi, rpsi1, rpsi2, rpsi3, rsc_psi0  !     -           -           -        -
101   REAL(wp) ::   rpsi3m, rpsi3p, rpp, rmm, rnn                    !     -           -           -        -
[2299]102
[2048]103   !! * Substitutions
104#  include "domzgr_substitute.h90"
105#  include "vectopt_loop_substitute.h90"
106   !!----------------------------------------------------------------------
[2287]107   !! NEMO/OPA 3.3 , NEMO Consortium (2010)
[2715]108   !! $Id$
[2329]109   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
[2048]110   !!----------------------------------------------------------------------
111CONTAINS
112
[2715]113   INTEGER FUNCTION zdf_gls_alloc()
114      !!----------------------------------------------------------------------
115      !!                ***  FUNCTION zdf_gls_alloc  ***
116      !!----------------------------------------------------------------------
[6487]117      ALLOCATE( mxln(jpi,jpj,jpk), zwall(jpi,jpj,jpk) ,     &
118         &      ustars2(jpi,jpj) , ustarb2(jpi,jpj)   , STAT= zdf_gls_alloc )
[2715]119         !
120      IF( lk_mpp             )   CALL mpp_sum ( zdf_gls_alloc )
121      IF( zdf_gls_alloc /= 0 )   CALL ctl_warn('zdf_gls_alloc: failed to allocate arrays')
122   END FUNCTION zdf_gls_alloc
123
124
[2048]125   SUBROUTINE zdf_gls( kt )
126      !!----------------------------------------------------------------------
127      !!                   ***  ROUTINE zdf_gls  ***
128      !!
129      !! ** Purpose :   Compute the vertical eddy viscosity and diffusivity
[2397]130      !!              coefficients using the GLS turbulent closure scheme.
[2048]131      !!----------------------------------------------------------------------
132      INTEGER, INTENT(in) ::   kt ! ocean time step
133      INTEGER  ::   ji, jj, jk, ibot, ibotm1, dir  ! dummy loop arguments
[2397]134      REAL(wp) ::   zesh2, zsigpsi, zcoef, zex1, zex2   ! local scalars
135      REAL(wp) ::   ztx2, zty2, zup, zdown, zcof        !   -      -
136      REAL(wp) ::   zratio, zrn2, zflxb, sh             !   -      -
137      REAL(wp) ::   prod, buoy, diss, zdiss, sm         !   -      -
138      REAL(wp) ::   gh, gm, shr, dif, zsqen, zav        !   -      -
[3294]139      REAL(wp), POINTER, DIMENSION(:,:  ) ::   zdep
[5109]140      REAL(wp), POINTER, DIMENSION(:,:  ) ::   zkar
[3294]141      REAL(wp), POINTER, DIMENSION(:,:  ) ::   zflxs       ! Turbulence fluxed induced by internal waves
142      REAL(wp), POINTER, DIMENSION(:,:  ) ::   zhsro       ! Surface roughness (surface waves)
143      REAL(wp), POINTER, DIMENSION(:,:,:) ::   eb          ! tke at time before
144      REAL(wp), POINTER, DIMENSION(:,:,:) ::   mxlb        ! mixing length at time before
145      REAL(wp), POINTER, DIMENSION(:,:,:) ::   shear       ! vertical shear
146      REAL(wp), POINTER, DIMENSION(:,:,:) ::   eps         ! dissipation rate
[5109]147      REAL(wp), POINTER, DIMENSION(:,:,:) ::   zwall_psi   ! Wall function use in the wb case (ln_sigpsi)
148      REAL(wp), POINTER, DIMENSION(:,:,:) ::   psi         ! psi at time now
149      REAL(wp), POINTER, DIMENSION(:,:,:) ::   z_elem_a    ! element of the first  matrix diagonal
150      REAL(wp), POINTER, DIMENSION(:,:,:) ::   z_elem_b    ! element of the second matrix diagonal
151      REAL(wp), POINTER, DIMENSION(:,:,:) ::   z_elem_c    ! element of the third  matrix diagonal
[2048]152      !!--------------------------------------------------------------------
[3294]153      !
154      IF( nn_timing == 1 )  CALL timing_start('zdf_gls')
155      !
[5109]156      CALL wrk_alloc( jpi,jpj, zdep, zkar, zflxs, zhsro )
157      CALL wrk_alloc( jpi,jpj,jpk, eb, mxlb, shear, eps, zwall_psi, z_elem_a, z_elem_b, z_elem_c, psi  )
158     
[2048]159      ! Preliminary computing
160
[2397]161      ustars2 = 0._wp   ;   ustarb2 = 0._wp   ;   psi  = 0._wp   ;   zwall_psi = 0._wp
[2048]162
[3798]163      IF( kt /= nit000 ) THEN   ! restore before value to compute tke
164         avt (:,:,:) = avt_k (:,:,:)
165         avm (:,:,:) = avm_k (:,:,:)
166         avmu(:,:,:) = avmu_k(:,:,:)
167         avmv(:,:,:) = avmv_k(:,:,:) 
168      ENDIF
169
[2497]170      ! Compute surface and bottom friction at T-points
[5109]171!CDIR NOVERRCHK         
172      DO jj = 2, jpjm1         
173!CDIR NOVERRCHK         
174         DO ji = fs_2, fs_jpim1   ! vector opt.         
175            !
176            ! surface friction
[3625]177            ustars2(ji,jj) = r1_rau0 * taum(ji,jj) * tmask(ji,jj,1)
[5109]178            !   
179            ! bottom friction (explicit before friction)       
180            ! Note that we chose here not to bound the friction as in dynbfr)   
181            ztx2 = (  bfrua(ji,jj)  * ub(ji,jj,mbku(ji,jj)) + bfrua(ji-1,jj) * ub(ji-1,jj,mbku(ji-1,jj))  )   &         
182               & * ( 1._wp - 0.5_wp * umask(ji,jj,1) * umask(ji-1,jj,1)  )     
183            zty2 = (  bfrva(ji,jj)  * vb(ji,jj,mbkv(ji,jj)) + bfrva(ji,jj-1) * vb(ji,jj-1,mbkv(ji,jj-1))  )   &         
184               & * ( 1._wp - 0.5_wp * vmask(ji,jj,1) * vmask(ji,jj-1,1)  )     
185            ustarb2(ji,jj) = SQRT( ztx2 * ztx2 + zty2 * zty2 ) * tmask(ji,jj,1)         
186         END DO         
187      END DO   
[2048]188
[5109]189      ! Set surface roughness length
190      SELECT CASE ( nn_z0_met )
191      !
192      CASE ( 0 )             ! Constant roughness         
193         zhsro(:,:) = rn_hsro
194      CASE ( 1 )             ! Standard Charnock formula
195         zhsro(:,:) = MAX(rsbc_zs1 * ustars2(:,:), rn_hsro)
196      CASE ( 2 )             ! Roughness formulae according to Rascle et al., Ocean Modelling (2008)
197         zdep(:,:)  = 30.*TANH(2.*0.3/(28.*SQRT(MAX(ustars2(:,:),rsmall))))             ! Wave age (eq. 10)
198         zhsro(:,:) = MAX(rsbc_zs2 * ustars2(:,:) * zdep(:,:)**1.5, rn_hsro) ! zhsro = rn_frac_hs * Hsw (eq. 11)
199      !
200      END SELECT
[2048]201
202      ! Compute shear and dissipation rate
203      DO jk = 2, jpkm1
204         DO jj = 2, jpjm1
205            DO ji = fs_2, fs_jpim1   ! vector opt.
206               avmu(ji,jj,jk) = avmu(ji,jj,jk) * ( un(ji,jj,jk-1) - un(ji,jj,jk) )   &
207                  &                            * ( ub(ji,jj,jk-1) - ub(ji,jj,jk) )   &
208                  &                            / (  fse3uw_n(ji,jj,jk)               &
209                  &                            *    fse3uw_b(ji,jj,jk) )
210               avmv(ji,jj,jk) = avmv(ji,jj,jk) * ( vn(ji,jj,jk-1) - vn(ji,jj,jk) )   &
211                  &                            * ( vb(ji,jj,jk-1) - vb(ji,jj,jk) )   &
212                  &                            / (  fse3vw_n(ji,jj,jk)               &
213                  &                            *    fse3vw_b(ji,jj,jk) )
[2299]214               eps(ji,jj,jk)  = rc03 * en(ji,jj,jk) * SQRT(en(ji,jj,jk)) / mxln(ji,jj,jk)
[2397]215            END DO
216         END DO
217      END DO
[2048]218      !
219      ! Lateral boundary conditions (avmu,avmv) (sign unchanged)
[2397]220      CALL lbc_lnk( avmu, 'U', 1. )   ;   CALL lbc_lnk( avmv, 'V', 1. )
[2048]221
222      ! Save tke at before time step
223      eb  (:,:,:) = en  (:,:,:)
224      mxlb(:,:,:) = mxln(:,:,:)
225
[2397]226      IF( nn_clos == 0 ) THEN    ! Mellor-Yamada
[2048]227         DO jk = 2, jpkm1
228            DO jj = 2, jpjm1 
229               DO ji = fs_2, fs_jpim1   ! vector opt.
[2450]230                  zup   = mxln(ji,jj,jk) * fsdepw(ji,jj,mbkt(ji,jj)+1)
231                  zdown = vkarmn * fsdepw(ji,jj,jk) * ( -fsdepw(ji,jj,jk) + fsdepw(ji,jj,mbkt(ji,jj)+1) )
[2397]232                  zcoef = ( zup / MAX( zdown, rsmall ) )
233                  zwall (ji,jj,jk) = ( 1._wp + re2 * zcoef*zcoef ) * tmask(ji,jj,jk)
234               END DO
235            END DO
236         END DO
[2048]237      ENDIF
238
239      !!---------------------------------!!
240      !!   Equation to prognostic k      !!
241      !!---------------------------------!!
242      !
243      ! Now Turbulent kinetic energy (output in en)
244      ! -------------------------------
245      ! Resolution of a tridiagonal linear system by a "methode de chasse"
246      ! computation from level 2 to jpkm1  (e(1) computed after and e(jpk)=0 ).
247      ! The surface boundary condition are set after
248      ! The bottom boundary condition are also set after. In standard e(bottom)=0.
249      ! z_elem_b : diagonal z_elem_c : upper diagonal z_elem_a : lower diagonal
250      ! Warning : after this step, en : right hand side of the matrix
251
252      DO jk = 2, jpkm1
253         DO jj = 2, jpjm1
254            DO ji = fs_2, fs_jpim1   ! vector opt.
255               !
256               ! shear prod. at w-point weightened by mask
257               shear(ji,jj,jk) =  ( avmu(ji-1,jj,jk) + avmu(ji,jj,jk) ) / MAX( 1.e0 , umask(ji-1,jj,jk) + umask(ji,jj,jk) )   &
258                  &             + ( avmv(ji,jj-1,jk) + avmv(ji,jj,jk) ) / MAX( 1.e0 , vmask(ji,jj-1,jk) + vmask(ji,jj,jk) )
259               !
260               ! stratif. destruction
261               buoy = - avt(ji,jj,jk) * rn2(ji,jj,jk)
262               !
263               ! shear prod. - stratif. destruction
264               diss = eps(ji,jj,jk)
265               !
[2397]266               dir = 0.5_wp + SIGN( 0.5_wp, shear(ji,jj,jk) + buoy )   ! dir =1(=0) if shear(ji,jj,jk)+buoy >0(<0)
[2048]267               !
[2397]268               zesh2 = dir*(shear(ji,jj,jk)+buoy)+(1._wp-dir)*shear(ji,jj,jk)          ! production term
269               zdiss = dir*(diss/en(ji,jj,jk))   +(1._wp-dir)*(diss-buoy)/en(ji,jj,jk) ! dissipation term
[2048]270               !
[2299]271               ! Compute a wall function from 1. to rsc_psi*zwall/rsc_psi0
[2048]272               ! Note that as long that Dirichlet boundary conditions are NOT set at the first and last levels (GOTM style)
273               ! there is no need to set a boundary condition for zwall_psi at the top and bottom boundaries.
[2299]274               ! Otherwise, this should be rsc_psi/rsc_psi0
[2397]275               IF( ln_sigpsi ) THEN
276                  zsigpsi = MIN( 1._wp, zesh2 / eps(ji,jj,jk) )     ! 0. <= zsigpsi <= 1.
[3294]277                  zwall_psi(ji,jj,jk) = rsc_psi /   & 
278                     &     (  zsigpsi * rsc_psi + (1._wp-zsigpsi) * rsc_psi0 / MAX( zwall(ji,jj,jk), 1._wp )  )
[2048]279               ELSE
[2397]280                  zwall_psi(ji,jj,jk) = 1._wp
[2048]281               ENDIF
282               !
283               ! building the matrix
[2299]284               zcof = rfact_tke * tmask(ji,jj,jk)
[2048]285               !
286               ! lower diagonal
287               z_elem_a(ji,jj,jk) = zcof * ( avm  (ji,jj,jk  ) + avm  (ji,jj,jk-1) )   &
288                  &                      / ( fse3t(ji,jj,jk-1) * fse3w(ji,jj,jk  ) )
289               !
290               ! upper diagonal
291               z_elem_c(ji,jj,jk) = zcof * ( avm  (ji,jj,jk+1) + avm  (ji,jj,jk  ) )   &
292                  &                      / ( fse3t(ji,jj,jk  ) * fse3w(ji,jj,jk) )
293               !
294               ! diagonal
[2397]295               z_elem_b(ji,jj,jk) = 1._wp - z_elem_a(ji,jj,jk) - z_elem_c(ji,jj,jk)  &
296                  &                       + rdt * zdiss * tmask(ji,jj,jk) 
[2048]297               !
298               ! right hand side in en
299               en(ji,jj,jk) = en(ji,jj,jk) + rdt * zesh2 * tmask(ji,jj,jk)
300            END DO
301         END DO
302      END DO
303      !
[2397]304      z_elem_b(:,:,jpk) = 1._wp
[2048]305      !
306      ! Set surface condition on zwall_psi (1 at the bottom)
[5109]307      zwall_psi(:,:,1) = zwall_psi(:,:,2)
308      zwall_psi(:,:,jpk) = 1.
309      !
[2048]310      ! Surface boundary condition on tke
311      ! ---------------------------------
312      !
[5109]313      SELECT CASE ( nn_bc_surf )
[2048]314      !
315      CASE ( 0 )             ! Dirichlet case
[5109]316      ! First level
317      en(:,:,1) = rc02r * ustars2(:,:) * (1._wp + rsbc_tke1)**(2._wp/3._wp)
318      en(:,:,1) = MAX(en(:,:,1), rn_emin) 
319      z_elem_a(:,:,1) = en(:,:,1)
320      z_elem_c(:,:,1) = 0._wp
321      z_elem_b(:,:,1) = 1._wp
322      !
323      ! One level below
[6487]324      en(:,:,2) = rc02r * ustars2(:,:) * (1._wp + rsbc_tke1 * ((zhsro(:,:)+fsdepw(:,:,2)) &
325          &            / zhsro(:,:) )**(1.5_wp*ra_sf))**(2._wp/3._wp)
[5109]326      en(:,:,2) = MAX(en(:,:,2), rn_emin )
327      z_elem_a(:,:,2) = 0._wp 
328      z_elem_c(:,:,2) = 0._wp
329      z_elem_b(:,:,2) = 1._wp
330      !
331      !
[2048]332      CASE ( 1 )             ! Neumann boundary condition on d(e)/dz
[5109]333      !
334      ! Dirichlet conditions at k=1
335      en(:,:,1)       = rc02r * ustars2(:,:) * (1._wp + rsbc_tke1)**(2._wp/3._wp)
336      en(:,:,1)       = MAX(en(:,:,1), rn_emin)     
337      z_elem_a(:,:,1) = en(:,:,1)
338      z_elem_c(:,:,1) = 0._wp
339      z_elem_b(:,:,1) = 1._wp
340      !
341      ! at k=2, set de/dz=Fw
342      !cbr
343      z_elem_b(:,:,2) = z_elem_b(:,:,2) +  z_elem_a(:,:,2) ! Remove z_elem_a from z_elem_b
344      z_elem_a(:,:,2) = 0._wp
345      zkar(:,:)       = (rl_sf + (vkarmn-rl_sf)*(1.-exp(-rtrans*fsdept(:,:,1)/zhsro(:,:)) ))
[6487]346      zflxs(:,:)      = rsbc_tke2 * ustars2(:,:)**1.5_wp * zkar(:,:) &
347           &                      * ((zhsro(:,:)+fsdept(:,:,1))/zhsro(:,:) )**(1.5_wp*ra_sf)
[5109]348
349      en(:,:,2) = en(:,:,2) + zflxs(:,:)/fse3w(:,:,2)
350      !
351      !
[2048]352      END SELECT
353
354      ! Bottom boundary condition on tke
355      ! --------------------------------
356      !
[5109]357      SELECT CASE ( nn_bc_bot )
[2048]358      !
359      CASE ( 0 )             ! Dirichlet
[2397]360         !                      ! en(ibot) = u*^2 / Co2 and mxln(ibot) = rn_lmin
361         !                      ! Balance between the production and the dissipation terms
[2048]362!CDIR NOVERRCHK
[2397]363         DO jj = 2, jpjm1
[2048]364!CDIR NOVERRCHK
[2397]365            DO ji = fs_2, fs_jpim1   ! vector opt.
[2450]366               ibot   = mbkt(ji,jj) + 1      ! k   bottom level of w-point
367               ibotm1 = mbkt(ji,jj)          ! k-1 bottom level of w-point but >=1
[2397]368               !
369               ! Bottom level Dirichlet condition:
370               z_elem_a(ji,jj,ibot  ) = 0._wp
371               z_elem_c(ji,jj,ibot  ) = 0._wp
372               z_elem_b(ji,jj,ibot  ) = 1._wp
373               en(ji,jj,ibot  ) = MAX( rc02r * ustarb2(ji,jj), rn_emin )
374               !
375               ! Just above last level, Dirichlet condition again
376               z_elem_a(ji,jj,ibotm1) = 0._wp
377               z_elem_c(ji,jj,ibotm1) = 0._wp
378               z_elem_b(ji,jj,ibotm1) = 1._wp
379               en(ji,jj,ibotm1) = MAX( rc02r * ustarb2(ji,jj), rn_emin ) 
380            END DO
[2048]381         END DO
[2397]382         !
[2048]383      CASE ( 1 )             ! Neumman boundary condition
[2397]384         !                     
[2048]385!CDIR NOVERRCHK
[2397]386         DO jj = 2, jpjm1
[2048]387!CDIR NOVERRCHK
[2397]388            DO ji = fs_2, fs_jpim1   ! vector opt.
[2450]389               ibot   = mbkt(ji,jj) + 1      ! k   bottom level of w-point
390               ibotm1 = mbkt(ji,jj)          ! k-1 bottom level of w-point but >=1
[2397]391               !
392               ! Bottom level Dirichlet condition:
393               z_elem_a(ji,jj,ibot) = 0._wp
394               z_elem_c(ji,jj,ibot) = 0._wp
395               z_elem_b(ji,jj,ibot) = 1._wp
396               en(ji,jj,ibot) = MAX( rc02r * ustarb2(ji,jj), rn_emin )
397               !
398               ! Just above last level: Neumann condition
399               z_elem_b(ji,jj,ibotm1) = z_elem_b(ji,jj,ibotm1) + z_elem_c(ji,jj,ibotm1)   ! Remove z_elem_c from z_elem_b
400               z_elem_c(ji,jj,ibotm1) = 0._wp
401            END DO
[2048]402         END DO
[2397]403         !
[2048]404      END SELECT
405
406      ! Matrix inversion (en prescribed at surface and the bottom)
407      ! ----------------------------------------------------------
408      !
409      DO jk = 2, jpkm1                             ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1
410         DO jj = 2, jpjm1
411            DO ji = fs_2, fs_jpim1    ! vector opt.
412               z_elem_b(ji,jj,jk) = z_elem_b(ji,jj,jk) - z_elem_a(ji,jj,jk) * z_elem_c(ji,jj,jk-1) / z_elem_b(ji,jj,jk-1)
413            END DO
414         END DO
415      END DO
416      DO jk = 2, jpk                               ! Second recurrence : Lk = RHSk - Lk / Dk-1 * Lk-1
417         DO jj = 2, jpjm1
418            DO ji = fs_2, fs_jpim1    ! vector opt.
419               z_elem_a(ji,jj,jk) = en(ji,jj,jk) - z_elem_a(ji,jj,jk) / z_elem_b(ji,jj,jk-1) * z_elem_a(ji,jj,jk-1)
420            END DO
421         END DO
422      END DO
423      DO jk = jpk-1, 2, -1                         ! thrid recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk
424         DO jj = 2, jpjm1
425            DO ji = fs_2, fs_jpim1    ! vector opt.
426               en(ji,jj,jk) = ( z_elem_a(ji,jj,jk) - z_elem_c(ji,jj,jk) * en(ji,jj,jk+1) ) / z_elem_b(ji,jj,jk)
427            END DO
428         END DO
429      END DO
[2397]430      !                                            ! set the minimum value of tke
[2048]431      en(:,:,:) = MAX( en(:,:,:), rn_emin )
[5109]432
[2048]433      !!----------------------------------------!!
434      !!   Solve prognostic equation for psi    !!
435      !!----------------------------------------!!
436
437      ! Set psi to previous time step value
438      !
439      SELECT CASE ( nn_clos )
440      !
441      CASE( 0 )               ! k-kl  (Mellor-Yamada)
[2397]442         DO jk = 2, jpkm1
443            DO jj = 2, jpjm1
444               DO ji = fs_2, fs_jpim1   ! vector opt.
[3294]445                  psi(ji,jj,jk)  = eb(ji,jj,jk) * mxlb(ji,jj,jk)
[2397]446               END DO
447            END DO
448         END DO
449         !
[2048]450      CASE( 1 )               ! k-eps
[2397]451         DO jk = 2, jpkm1
452            DO jj = 2, jpjm1
453               DO ji = fs_2, fs_jpim1   ! vector opt.
454                  psi(ji,jj,jk)  = eps(ji,jj,jk)
455               END DO
456            END DO
457         END DO
458         !
[2048]459      CASE( 2 )               ! k-w
[2397]460         DO jk = 2, jpkm1
461            DO jj = 2, jpjm1
462               DO ji = fs_2, fs_jpim1   ! vector opt.
[3294]463                  psi(ji,jj,jk)  = SQRT( eb(ji,jj,jk) ) / ( rc0 * mxlb(ji,jj,jk) )
[2397]464               END DO
465            END DO
466         END DO
467         !
468      CASE( 3 )               ! generic
469         DO jk = 2, jpkm1
470            DO jj = 2, jpjm1
471               DO ji = fs_2, fs_jpim1   ! vector opt.
[3294]472                  psi(ji,jj,jk)  = rc02 * eb(ji,jj,jk) * mxlb(ji,jj,jk)**rnn 
[2397]473               END DO
474            END DO
475         END DO
476         !
[2048]477      END SELECT
478      !
479      ! Now gls (output in psi)
480      ! -------------------------------
481      ! Resolution of a tridiagonal linear system by a "methode de chasse"
482      ! computation from level 2 to jpkm1  (e(1) already computed and e(jpk)=0 ).
483      ! z_elem_b : diagonal z_elem_c : upper diagonal z_elem_a : lower diagonal
484      ! Warning : after this step, en : right hand side of the matrix
485
486      DO jk = 2, jpkm1
487         DO jj = 2, jpjm1
488            DO ji = fs_2, fs_jpim1   ! vector opt.
489               !
490               ! psi / k
491               zratio = psi(ji,jj,jk) / eb(ji,jj,jk) 
492               !
493               ! psi3+ : stable : B=-KhN²<0 => N²>0 if rn2>0 dir = 1 (stable) otherwise dir = 0 (unstable)
[2397]494               dir = 0.5_wp + SIGN( 0.5_wp, rn2(ji,jj,jk) )
[2048]495               !
[2397]496               rpsi3 = dir * rpsi3m + ( 1._wp - dir ) * rpsi3p
[2048]497               !
498               ! shear prod. - stratif. destruction
[2299]499               prod = rpsi1 * zratio * shear(ji,jj,jk)
[2048]500               !
501               ! stratif. destruction
[2397]502               buoy = rpsi3 * zratio * (- avt(ji,jj,jk) * rn2(ji,jj,jk) )
[2048]503               !
504               ! shear prod. - stratif. destruction
[2299]505               diss = rpsi2 * zratio * zwall(ji,jj,jk) * eps(ji,jj,jk)
[2048]506               !
[2397]507               dir = 0.5_wp + SIGN( 0.5_wp, prod + buoy )   ! dir =1(=0) if shear(ji,jj,jk)+buoy >0(<0)
[2048]508               !
[2397]509               zesh2 = dir * ( prod + buoy )          + (1._wp - dir ) * prod                        ! production term
510               zdiss = dir * ( diss / psi(ji,jj,jk) ) + (1._wp - dir ) * (diss-buoy) / psi(ji,jj,jk) ! dissipation term
[2048]511               !                                                       
512               ! building the matrix
[2299]513               zcof = rfact_psi * zwall_psi(ji,jj,jk) * tmask(ji,jj,jk)
[2048]514               ! lower diagonal
515               z_elem_a(ji,jj,jk) = zcof * ( avm  (ji,jj,jk  ) + avm  (ji,jj,jk-1) )   &
516                  &                      / ( fse3t(ji,jj,jk-1) * fse3w(ji,jj,jk  ) )
517               ! upper diagonal
518               z_elem_c(ji,jj,jk) = zcof * ( avm  (ji,jj,jk+1) + avm  (ji,jj,jk  ) )   &
519                  &                      / ( fse3t(ji,jj,jk  ) * fse3w(ji,jj,jk) )
520               ! diagonal
[2397]521               z_elem_b(ji,jj,jk) = 1._wp - z_elem_a(ji,jj,jk) - z_elem_c(ji,jj,jk)  &
522                  &                       + rdt * zdiss * tmask(ji,jj,jk)
[2048]523               !
524               ! right hand side in psi
525               psi(ji,jj,jk) = psi(ji,jj,jk) + rdt * zesh2 * tmask(ji,jj,jk)
526            END DO
527         END DO
528      END DO
529      !
[2397]530      z_elem_b(:,:,jpk) = 1._wp
[2048]531
532      ! Surface boundary condition on psi
533      ! ---------------------------------
534      !
[5109]535      SELECT CASE ( nn_bc_surf )
[2048]536      !
537      CASE ( 0 )             ! Dirichlet boundary conditions
[5109]538      !
539      ! Surface value
540      zdep(:,:)       = zhsro(:,:) * rl_sf ! Cosmetic
541      psi (:,:,1)     = rc0**rpp * en(:,:,1)**rmm * zdep(:,:)**rnn * tmask(:,:,1)
542      z_elem_a(:,:,1) = psi(:,:,1)
543      z_elem_c(:,:,1) = 0._wp
544      z_elem_b(:,:,1) = 1._wp
545      !
546      ! One level below
547      zkar(:,:)       = (rl_sf + (vkarmn-rl_sf)*(1._wp-exp(-rtrans*fsdepw(:,:,2)/zhsro(:,:) )))
548      zdep(:,:)       = (zhsro(:,:) + fsdepw(:,:,2)) * zkar(:,:)
549      psi (:,:,2)     = rc0**rpp * en(:,:,2)**rmm * zdep(:,:)**rnn * tmask(:,:,1)
550      z_elem_a(:,:,2) = 0._wp
551      z_elem_c(:,:,2) = 0._wp
552      z_elem_b(:,:,2) = 1._wp
553      !
554      !
[2048]555      CASE ( 1 )             ! Neumann boundary condition on d(psi)/dz
[5109]556      !
557      ! Surface value: Dirichlet
558      zdep(:,:)       = zhsro(:,:) * rl_sf
559      psi (:,:,1)     = rc0**rpp * en(:,:,1)**rmm * zdep(:,:)**rnn * tmask(:,:,1)
560      z_elem_a(:,:,1) = psi(:,:,1)
561      z_elem_c(:,:,1) = 0._wp
562      z_elem_b(:,:,1) = 1._wp
563      !
564      ! Neumann condition at k=2
565      z_elem_b(:,:,2) = z_elem_b(:,:,2) +  z_elem_a(:,:,2) ! Remove z_elem_a from z_elem_b
566      z_elem_a(:,:,2) = 0._wp
567      !
568      ! Set psi vertical flux at the surface:
569      zkar(:,:) = rl_sf + (vkarmn-rl_sf)*(1._wp-exp(-rtrans*fsdept(:,:,1)/zhsro(:,:) )) ! Lengh scale slope
570      zdep(:,:) = ((zhsro(:,:) + fsdept(:,:,1)) / zhsro(:,:))**(rmm*ra_sf)
571      zflxs(:,:) = (rnn + rsbc_tke1 * (rnn + rmm*ra_sf) * zdep(:,:))*(1._wp + rsbc_tke1*zdep(:,:))**(2._wp*rmm/3._wp-1_wp)
572      zdep(:,:) =  rsbc_psi1 * (zwall_psi(:,:,1)*avm(:,:,1)+zwall_psi(:,:,2)*avm(:,:,2)) * &
573             & ustars2(:,:)**rmm * zkar(:,:)**rnn * (zhsro(:,:) + fsdept(:,:,1))**(rnn-1.)
574      zflxs(:,:) = zdep(:,:) * zflxs(:,:)
575      psi(:,:,2) = psi(:,:,2) + zflxs(:,:) / fse3w(:,:,2)
576
577      !   
578      !
[2048]579      END SELECT
580
581      ! Bottom boundary condition on psi
582      ! --------------------------------
583      !
[5109]584      SELECT CASE ( nn_bc_bot )
[2048]585      !
[5109]586      !
[2048]587      CASE ( 0 )             ! Dirichlet
[5109]588         !                      ! en(ibot) = u*^2 / Co2 and mxln(ibot) = vkarmn * rn_bfrz0
[2397]589         !                      ! Balance between the production and the dissipation terms
[2048]590!CDIR NOVERRCHK
[2397]591         DO jj = 2, jpjm1
[2048]592!CDIR NOVERRCHK
[2397]593            DO ji = fs_2, fs_jpim1   ! vector opt.
[2450]594               ibot   = mbkt(ji,jj) + 1      ! k   bottom level of w-point
595               ibotm1 = mbkt(ji,jj)          ! k-1 bottom level of w-point but >=1
[5109]596               zdep(ji,jj) = vkarmn * rn_bfrz0
[2397]597               psi (ji,jj,ibot) = rc0**rpp * en(ji,jj,ibot)**rmm * zdep(ji,jj)**rnn
598               z_elem_a(ji,jj,ibot) = 0._wp
599               z_elem_c(ji,jj,ibot) = 0._wp
600               z_elem_b(ji,jj,ibot) = 1._wp
601               !
602               ! Just above last level, Dirichlet condition again (GOTM like)
[5109]603               zdep(ji,jj) = vkarmn * ( rn_bfrz0 + fse3t(ji,jj,ibotm1) )
[2397]604               psi (ji,jj,ibotm1) = rc0**rpp * en(ji,jj,ibot  )**rmm * zdep(ji,jj)**rnn
605               z_elem_a(ji,jj,ibotm1) = 0._wp
606               z_elem_c(ji,jj,ibotm1) = 0._wp
607               z_elem_b(ji,jj,ibotm1) = 1._wp
608            END DO
[2048]609         END DO
[2397]610         !
[2048]611      CASE ( 1 )             ! Neumman boundary condition
[2397]612         !                     
[2048]613!CDIR NOVERRCHK
[2397]614         DO jj = 2, jpjm1
[2048]615!CDIR NOVERRCHK
[2397]616            DO ji = fs_2, fs_jpim1   ! vector opt.
[2450]617               ibot   = mbkt(ji,jj) + 1      ! k   bottom level of w-point
618               ibotm1 = mbkt(ji,jj)          ! k-1 bottom level of w-point but >=1
[2397]619               !
620               ! Bottom level Dirichlet condition:
[5109]621               zdep(ji,jj) = vkarmn * rn_bfrz0
[2397]622               psi (ji,jj,ibot) = rc0**rpp * en(ji,jj,ibot)**rmm * zdep(ji,jj)**rnn
623               !
624               z_elem_a(ji,jj,ibot) = 0._wp
625               z_elem_c(ji,jj,ibot) = 0._wp
626               z_elem_b(ji,jj,ibot) = 1._wp
627               !
628               ! Just above last level: Neumann condition with flux injection
629               z_elem_b(ji,jj,ibotm1) = z_elem_b(ji,jj,ibotm1) + z_elem_c(ji,jj,ibotm1) ! Remove z_elem_c from z_elem_b
630               z_elem_c(ji,jj,ibotm1) = 0.
631               !
632               ! Set psi vertical flux at the bottom:
[5109]633               zdep(ji,jj) = rn_bfrz0 + 0.5_wp*fse3t(ji,jj,ibotm1)
[2397]634               zflxb = rsbc_psi2 * ( avm(ji,jj,ibot) + avm(ji,jj,ibotm1) )   &
635                  &  * (0.5_wp*(en(ji,jj,ibot)+en(ji,jj,ibotm1)))**rmm * zdep(ji,jj)**(rnn-1._wp)
636               psi(ji,jj,ibotm1) = psi(ji,jj,ibotm1) + zflxb / fse3w(ji,jj,ibotm1)
637            END DO
[2048]638         END DO
[2397]639         !
[2048]640      END SELECT
641
642      ! Matrix inversion
643      ! ----------------
644      !
645      DO jk = 2, jpkm1                             ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1
646         DO jj = 2, jpjm1
647            DO ji = fs_2, fs_jpim1    ! vector opt.
648               z_elem_b(ji,jj,jk) = z_elem_b(ji,jj,jk) - z_elem_a(ji,jj,jk) * z_elem_c(ji,jj,jk-1) / z_elem_b(ji,jj,jk-1)
649            END DO
650         END DO
651      END DO
652      DO jk = 2, jpk                               ! Second recurrence : Lk = RHSk - Lk / Dk-1 * Lk-1
653         DO jj = 2, jpjm1
654            DO ji = fs_2, fs_jpim1    ! vector opt.
655               z_elem_a(ji,jj,jk) = psi(ji,jj,jk) - z_elem_a(ji,jj,jk) / z_elem_b(ji,jj,jk-1) * z_elem_a(ji,jj,jk-1)
656            END DO
657         END DO
658      END DO
659      DO jk = jpk-1, 2, -1                         ! Third recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk
660         DO jj = 2, jpjm1
661            DO ji = fs_2, fs_jpim1    ! vector opt.
662               psi(ji,jj,jk) = ( z_elem_a(ji,jj,jk) - z_elem_c(ji,jj,jk) * psi(ji,jj,jk+1) ) / z_elem_b(ji,jj,jk)
663            END DO
664         END DO
665      END DO
666
667      ! Set dissipation
668      !----------------
669
670      SELECT CASE ( nn_clos )
671      !
672      CASE( 0 )               ! k-kl  (Mellor-Yamada)
[2397]673         DO jk = 1, jpkm1
674            DO jj = 2, jpjm1
675               DO ji = fs_2, fs_jpim1   ! vector opt.
[5109]676                  eps(ji,jj,jk) = rc03 * en(ji,jj,jk) * en(ji,jj,jk) * SQRT( en(ji,jj,jk) ) / MAX( psi(ji,jj,jk), rn_epsmin)
[2397]677               END DO
678            END DO
679         END DO
680         !
[2048]681      CASE( 1 )               ! k-eps
[2397]682         DO jk = 1, jpkm1
683            DO jj = 2, jpjm1
684               DO ji = fs_2, fs_jpim1   ! vector opt.
685                  eps(ji,jj,jk) = psi(ji,jj,jk)
686               END DO
687            END DO
688         END DO
689         !
[2048]690      CASE( 2 )               ! k-w
[2397]691         DO jk = 1, jpkm1
692            DO jj = 2, jpjm1
693               DO ji = fs_2, fs_jpim1   ! vector opt.
694                  eps(ji,jj,jk) = rc04 * en(ji,jj,jk) * psi(ji,jj,jk) 
695               END DO
696            END DO
697         END DO
698         !
699      CASE( 3 )               ! generic
700         zcoef = rc0**( 3._wp  + rpp/rnn )
701         zex1  =      ( 1.5_wp + rmm/rnn )
702         zex2  = -1._wp / rnn
703         DO jk = 1, jpkm1
704            DO jj = 2, jpjm1
705               DO ji = fs_2, fs_jpim1   ! vector opt.
706                  eps(ji,jj,jk) = zcoef * en(ji,jj,jk)**zex1 * psi(ji,jj,jk)**zex2
707               END DO
708            END DO
709         END DO
710         !
[2048]711      END SELECT
712
713      ! Limit dissipation rate under stable stratification
714      ! --------------------------------------------------
715      DO jk = 1, jpkm1 ! Note that this set boundary conditions on mxln at the same time
716         DO jj = 2, jpjm1
717            DO ji = fs_2, fs_jpim1    ! vector opt.
718               ! limitation
719               eps(ji,jj,jk)  = MAX( eps(ji,jj,jk), rn_epsmin )
[2397]720               mxln(ji,jj,jk)  = rc03 * en(ji,jj,jk) * SQRT( en(ji,jj,jk) ) / eps(ji,jj,jk)
[2048]721               ! Galperin criterium (NOTE : Not required if the proper value of C3 in stable cases is calculated)
722               zrn2 = MAX( rn2(ji,jj,jk), rsmall )
[5109]723               IF (ln_length_lim) mxln(ji,jj,jk) = MIN(  rn_clim_galp * SQRT( 2._wp * en(ji,jj,jk) / zrn2 ), mxln(ji,jj,jk) )
[2048]724            END DO
725         END DO
726      END DO 
727
728      !
729      ! Stability function and vertical viscosity and diffusivity
730      ! ---------------------------------------------------------
731      !
732      SELECT CASE ( nn_stab_func )
733      !
734      CASE ( 0 , 1 )             ! Galperin or Kantha-Clayson stability functions
[2397]735         DO jk = 2, jpkm1
736            DO jj = 2, jpjm1
737               DO ji = fs_2, fs_jpim1   ! vector opt.
738                  ! zcof =  l²/q²
739                  zcof = mxlb(ji,jj,jk) * mxlb(ji,jj,jk) / ( 2._wp*eb(ji,jj,jk) )
740                  ! Gh = -N²l²/q²
741                  gh = - rn2(ji,jj,jk) * zcof
742                  gh = MIN( gh, rgh0   )
743                  gh = MAX( gh, rghmin )
744                  ! Stability functions from Kantha and Clayson (if C2=C3=0 => Galperin)
745                  sh = ra2*( 1._wp-6._wp*ra1/rb1 ) / ( 1.-3.*ra2*gh*(6.*ra1+rb2*( 1._wp-rc3 ) ) )
746                  sm = ( rb1**(-1._wp/3._wp) + ( 18._wp*ra1*ra1 + 9._wp*ra1*ra2*(1._wp-rc2) )*sh*gh ) / (1._wp-9._wp*ra1*ra2*gh)
747                  !
748                  ! Store stability function in avmu and avmv
749                  avmu(ji,jj,jk) = rc_diff * sh * tmask(ji,jj,jk)
750                  avmv(ji,jj,jk) = rc_diff * sm * tmask(ji,jj,jk)
751               END DO
[2048]752            END DO
753         END DO
[2397]754         !
[2048]755      CASE ( 2, 3 )               ! Canuto stability functions
[2397]756         DO jk = 2, jpkm1
757            DO jj = 2, jpjm1
758               DO ji = fs_2, fs_jpim1   ! vector opt.
759                  ! zcof =  l²/q²
760                  zcof = mxlb(ji,jj,jk)*mxlb(ji,jj,jk) / ( 2._wp * eb(ji,jj,jk) )
761                  ! Gh = -N²l²/q²
762                  gh = - rn2(ji,jj,jk) * zcof
763                  gh = MIN( gh, rgh0   )
764                  gh = MAX( gh, rghmin )
765                  gh = gh * rf6
766                  ! Gm =  M²l²/q² Shear number
767                  shr = shear(ji,jj,jk) / MAX( avm(ji,jj,jk), rsmall )
768                  gm = MAX( shr * zcof , 1.e-10 )
769                  gm = gm * rf6
770                  gm = MIN ( (rd0 - rd1*gh + rd3*gh*gh) / (rd2-rd4*gh) , gm )
771                  ! Stability functions from Canuto
772                  rcff = rd0 - rd1*gh +rd2*gm + rd3*gh*gh - rd4*gh*gm + rd5*gm*gm
773                  sm = (rs0 - rs1*gh + rs2*gm) / rcff
774                  sh = (rs4 - rs5*gh + rs6*gm) / rcff
775                  !
776                  ! Store stability function in avmu and avmv
777                  avmu(ji,jj,jk) = rc_diff * sh * tmask(ji,jj,jk)
778                  avmv(ji,jj,jk) = rc_diff * sm * tmask(ji,jj,jk)
779               END DO
[2048]780            END DO
781         END DO
[2397]782         !
[2048]783      END SELECT
784
785      ! Boundary conditions on stability functions for momentum (Neumann):
786      ! Lines below are useless if GOTM style Dirichlet conditions are used
[5109]787
788      avmv(:,:,1) = avmv(:,:,2)
789
[2048]790      DO jj = 2, jpjm1
791         DO ji = fs_2, fs_jpim1   ! vector opt.
[5109]792            avmv(ji,jj,mbkt(ji,jj)+1) = avmv(ji,jj,mbkt(ji,jj))
[2048]793         END DO
794      END DO
795
796      ! Compute diffusivities/viscosities
797      ! The computation below could be restrained to jk=2 to jpkm1 if GOTM style Dirichlet conditions are used
798      DO jk = 1, jpk
799         DO jj = 2, jpjm1
800            DO ji = fs_2, fs_jpim1   ! vector opt.
[2397]801               zsqen         = SQRT( 2._wp * en(ji,jj,jk) ) * mxln(ji,jj,jk)
802               zav           = zsqen * avmu(ji,jj,jk)
803               avt(ji,jj,jk) = MAX( zav, avtb(jk) )*tmask(ji,jj,jk) ! apply mask for zdfmxl routine
804               zav           = zsqen * avmv(ji,jj,jk)
805               avm(ji,jj,jk) = MAX( zav, avmb(jk) ) ! Note that avm is not masked at the surface and the bottom
[2048]806            END DO
807         END DO
808      END DO
809      !
810      ! Lateral boundary conditions (sign unchanged)
[2397]811      avt(:,:,1)  = 0._wp
[2048]812      CALL lbc_lnk( avm, 'W', 1. )   ;   CALL lbc_lnk( avt, 'W', 1. )
813
814      DO jk = 2, jpkm1            !* vertical eddy viscosity at u- and v-points
815         DO jj = 2, jpjm1
816            DO ji = fs_2, fs_jpim1   ! vector opt.
[2397]817               avmu(ji,jj,jk) = 0.5 * ( avm(ji,jj,jk) + avm(ji+1,jj  ,jk) ) * umask(ji,jj,jk)
818               avmv(ji,jj,jk) = 0.5 * ( avm(ji,jj,jk) + avm(ji  ,jj+1,jk) ) * vmask(ji,jj,jk)
[2048]819            END DO
820         END DO
821      END DO
[2397]822      avmu(:,:,1) = 0._wp             ;   avmv(:,:,1) = 0._wp                 ! set surface to zero
823      CALL lbc_lnk( avmu, 'U', 1. )   ;   CALL lbc_lnk( avmv, 'V', 1. )       ! Lateral boundary conditions
[2048]824
825      IF(ln_ctl) THEN
826         CALL prt_ctl( tab3d_1=en  , clinfo1=' gls  - e: ', tab3d_2=avt, clinfo2=' t: ', ovlap=1, kdim=jpk)
827         CALL prt_ctl( tab3d_1=avmu, clinfo1=' gls  - u: ', mask1=umask,                   &
828            &          tab3d_2=avmv, clinfo2=       ' v: ', mask2=vmask, ovlap=1, kdim=jpk )
829      ENDIF
830      !
[3798]831      avt_k (:,:,:) = avt (:,:,:)
832      avm_k (:,:,:) = avm (:,:,:)
833      avmu_k(:,:,:) = avmu(:,:,:)
834      avmv_k(:,:,:) = avmv(:,:,:)
835      !
[5109]836      CALL wrk_dealloc( jpi,jpj, zdep, zkar, zflxs, zhsro )
[3294]837      CALL wrk_dealloc( jpi,jpj,jpk, eb, mxlb, shear, eps, zwall_psi, z_elem_a, z_elem_b, z_elem_c, psi )
[2715]838      !
[3294]839      IF( nn_timing == 1 )  CALL timing_stop('zdf_gls')
840      !
841      !
[2048]842   END SUBROUTINE zdf_gls
843
[2329]844
[2048]845   SUBROUTINE zdf_gls_init
846      !!----------------------------------------------------------------------
847      !!                  ***  ROUTINE zdf_gls_init  ***
848      !!                     
849      !! ** Purpose :   Initialization of the vertical eddy diffivity and
850      !!      viscosity when using a gls turbulent closure scheme
851      !!
852      !! ** Method  :   Read the namzdf_gls namelist and check the parameters
853      !!      called at the first timestep (nit000)
854      !!
855      !! ** input   :   Namlist namzdf_gls
856      !!
857      !! ** Action  :   Increase by 1 the nstop flag is setting problem encounter
858      !!
859      !!----------------------------------------------------------------------
[2397]860      USE dynzdf_exp
861      USE trazdf_exp
862      !
[2329]863      INTEGER ::   jk    ! dummy loop indices
[4147]864      INTEGER ::   ios   ! Local integer output status for namelist read
[2329]865      REAL(wp)::   zcr   ! local scalar
[2048]866      !!
867      NAMELIST/namzdf_gls/rn_emin, rn_epsmin, ln_length_lim, &
[5109]868         &            rn_clim_galp, ln_sigpsi, rn_hsro,      &
869         &            rn_crban, rn_charn, rn_frac_hs,        &
870         &            nn_bc_surf, nn_bc_bot, nn_z0_met,      &
[2048]871         &            nn_stab_func, nn_clos
872      !!----------------------------------------------------------
[3294]873      !
874      IF( nn_timing == 1 )  CALL timing_start('zdf_gls_init')
875      !
[4147]876      REWIND( numnam_ref )              ! Namelist namzdf_gls in reference namelist : Vertical eddy diffivity and viscosity using gls turbulent closure scheme
877      READ  ( numnam_ref, namzdf_gls, IOSTAT = ios, ERR = 901)
878901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_gls in reference namelist', lwp )
[2048]879
[4147]880      REWIND( numnam_cfg )              ! Namelist namzdf_gls in configuration namelist : Vertical eddy diffivity and viscosity using gls turbulent closure scheme
881      READ  ( numnam_cfg, namzdf_gls, IOSTAT = ios, ERR = 902 )
882902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_gls in configuration namelist', lwp )
[4624]883      IF(lwm) WRITE ( numond, namzdf_gls )
[4147]884
[2397]885      IF(lwp) THEN                     !* Control print
[2048]886         WRITE(numout,*)
887         WRITE(numout,*) 'zdf_gls_init : gls turbulent closure scheme'
888         WRITE(numout,*) '~~~~~~~~~~~~'
[2397]889         WRITE(numout,*) '   Namelist namzdf_gls : set gls mixing parameters'
[5109]890         WRITE(numout,*) '      minimum value of en                           rn_emin        = ', rn_emin
891         WRITE(numout,*) '      minimum value of eps                          rn_epsmin      = ', rn_epsmin
892         WRITE(numout,*) '      Limit dissipation rate under stable stratif.  ln_length_lim  = ', ln_length_lim
893         WRITE(numout,*) '      Galperin limit (Standard: 0.53, Holt: 0.26)   rn_clim_galp   = ', rn_clim_galp
894         WRITE(numout,*) '      TKE Surface boundary condition                nn_bc_surf     = ', nn_bc_surf
895         WRITE(numout,*) '      TKE Bottom boundary condition                 nn_bc_bot      = ', nn_bc_bot
896         WRITE(numout,*) '      Modify psi Schmidt number (wb case)           ln_sigpsi      = ', ln_sigpsi
[2397]897         WRITE(numout,*) '      Craig and Banner coefficient                  rn_crban       = ', rn_crban
898         WRITE(numout,*) '      Charnock coefficient                          rn_charn       = ', rn_charn
[5109]899         WRITE(numout,*) '      Surface roughness formula                     nn_z0_met      = ', nn_z0_met
900         WRITE(numout,*) '      Wave height frac. (used if nn_z0_met=2)       rn_frac_hs     = ', rn_frac_hs
[2397]901         WRITE(numout,*) '      Stability functions                           nn_stab_func   = ', nn_stab_func
902         WRITE(numout,*) '      Type of closure                               nn_clos        = ', nn_clos
[5109]903         WRITE(numout,*) '      Surface roughness (m)                         rn_hsro        = ', rn_hsro
904         WRITE(numout,*) '      Bottom roughness (m) (nambfr namelist)        rn_bfrz0       = ', rn_bfrz0
[2048]905      ENDIF
906
[2715]907      !                                !* allocate gls arrays
908      IF( zdf_gls_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'zdf_gls_init : unable to allocate arrays' )
909
[2397]910      !                                !* Check of some namelist values
[5109]911      IF( nn_bc_surf < 0 .OR. nn_bc_surf > 1 ) CALL ctl_stop( 'bad flag: nn_bc_surf is 0 or 1' )
912      IF( nn_bc_surf < 0 .OR. nn_bc_surf > 1 ) CALL ctl_stop( 'bad flag: nn_bc_surf is 0 or 1' )
913      IF( nn_z0_met < 0 .OR. nn_z0_met > 2 ) CALL ctl_stop( 'bad flag: nn_z0_met is 0, 1 or 2' )
[2397]914      IF( nn_stab_func  < 0 .OR. nn_stab_func  > 3 ) CALL ctl_stop( 'bad flag: nn_stab_func is 0, 1, 2 and 3' )
915      IF( nn_clos       < 0 .OR. nn_clos       > 3 ) CALL ctl_stop( 'bad flag: nn_clos is 0, 1, 2 or 3' )
[2048]916
[2715]917      SELECT CASE ( nn_clos )          !* set the parameters for the chosen closure
[2048]918      !
[2715]919      CASE( 0 )                              ! k-kl  (Mellor-Yamada)
[2397]920         !
921         IF(lwp) WRITE(numout,*) 'The choosen closure is k-kl closed to the classical Mellor-Yamada'
922         rpp     = 0._wp
923         rmm     = 1._wp
924         rnn     = 1._wp
925         rsc_tke = 1.96_wp
926         rsc_psi = 1.96_wp
927         rpsi1   = 0.9_wp
928         rpsi3p  = 1._wp
929         rpsi2   = 0.5_wp
930         !
[2048]931         SELECT CASE ( nn_stab_func )
[2397]932         CASE( 0, 1 )   ;   rpsi3m = 2.53_wp       ! G88 or KC stability functions
[5109]933         CASE( 2 )      ;   rpsi3m = 2.62_wp       ! Canuto A stability functions
[2397]934         CASE( 3 )      ;   rpsi3m = 2.38          ! Canuto B stability functions (caution : constant not identified)
935         END SELECT
[2048]936         !
[2715]937      CASE( 1 )                              ! k-eps
[2397]938         !
939         IF(lwp) WRITE(numout,*) 'The choosen closure is k-eps'
940         rpp     =  3._wp
941         rmm     =  1.5_wp
942         rnn     = -1._wp
943         rsc_tke =  1._wp
[5109]944         rsc_psi =  1.2_wp  ! Schmidt number for psi
[2397]945         rpsi1   =  1.44_wp
946         rpsi3p  =  1._wp
947         rpsi2   =  1.92_wp
948         !
949         SELECT CASE ( nn_stab_func )
950         CASE( 0, 1 )   ;   rpsi3m = -0.52_wp      ! G88 or KC stability functions
951         CASE( 2 )      ;   rpsi3m = -0.629_wp     ! Canuto A stability functions
952         CASE( 3 )      ;   rpsi3m = -0.566        ! Canuto B stability functions
[2048]953         END SELECT
[2397]954         !
[2715]955      CASE( 2 )                              ! k-omega
[2397]956         !
957         IF(lwp) WRITE(numout,*) 'The choosen closure is k-omega'
958         rpp     = -1._wp
959         rmm     =  0.5_wp
960         rnn     = -1._wp
961         rsc_tke =  2._wp
962         rsc_psi =  2._wp
963         rpsi1   =  0.555_wp
964         rpsi3p  =  1._wp
965         rpsi2   =  0.833_wp
966         !
967         SELECT CASE ( nn_stab_func )
968         CASE( 0, 1 )   ;   rpsi3m = -0.58_wp       ! G88 or KC stability functions
969         CASE( 2 )      ;   rpsi3m = -0.64_wp       ! Canuto A stability functions
970         CASE( 3 )      ;   rpsi3m = -0.64_wp       ! Canuto B stability functions caution : constant not identified)
971         END SELECT
972         !
[2715]973      CASE( 3 )                              ! generic
[2397]974         !
975         IF(lwp) WRITE(numout,*) 'The choosen closure is generic'
976         rpp     = 2._wp
977         rmm     = 1._wp
978         rnn     = -0.67_wp
979         rsc_tke = 0.8_wp
980         rsc_psi = 1.07_wp
981         rpsi1   = 1._wp
982         rpsi3p  = 1._wp
983         rpsi2   = 1.22_wp
984         !
985         SELECT CASE ( nn_stab_func )
986         CASE( 0, 1 )   ;   rpsi3m = 0.1_wp         ! G88 or KC stability functions
987         CASE( 2 )      ;   rpsi3m = 0.05_wp        ! Canuto A stability functions
988         CASE( 3 )      ;   rpsi3m = 0.05_wp        ! Canuto B stability functions caution : constant not identified)
989         END SELECT
990         !
[2048]991      END SELECT
992
993      !
[2715]994      SELECT CASE ( nn_stab_func )     !* set the parameters of the stability functions
[2048]995      !
[2715]996      CASE ( 0 )                             ! Galperin stability functions
[2397]997         !
998         IF(lwp) WRITE(numout,*) 'Stability functions from Galperin'
999         rc2     =  0._wp
1000         rc3     =  0._wp
1001         rc_diff =  1._wp
1002         rc0     =  0.5544_wp
1003         rcm_sf  =  0.9884_wp
1004         rghmin  = -0.28_wp
1005         rgh0    =  0.0233_wp
1006         rghcri  =  0.02_wp
1007         !
[2715]1008      CASE ( 1 )                             ! Kantha-Clayson stability functions
[2397]1009         !
1010         IF(lwp) WRITE(numout,*) 'Stability functions from Kantha-Clayson'
1011         rc2     =  0.7_wp
1012         rc3     =  0.2_wp
1013         rc_diff =  1._wp
1014         rc0     =  0.5544_wp
1015         rcm_sf  =  0.9884_wp
1016         rghmin  = -0.28_wp
1017         rgh0    =  0.0233_wp
1018         rghcri  =  0.02_wp
1019         !
[2715]1020      CASE ( 2 )                             ! Canuto A stability functions
[2397]1021         !
1022         IF(lwp) WRITE(numout,*) 'Stability functions from Canuto A'
1023         rs0 = 1.5_wp * rl1 * rl5*rl5
1024         rs1 = -rl4*(rl6+rl7) + 2._wp*rl4*rl5*(rl1-(1._wp/3._wp)*rl2-rl3) + 1.5_wp*rl1*rl5*rl8
1025         rs2 = -(3._wp/8._wp) * rl1*(rl6*rl6-rl7*rl7)
1026         rs4 = 2._wp * rl5
1027         rs5 = 2._wp * rl4
1028         rs6 = (2._wp/3._wp) * rl5 * ( 3._wp*rl3*rl3 - rl2*rl2 ) - 0.5_wp * rl5*rl1 * (3._wp*rl3-rl2)   &
1029            &                                                    + 0.75_wp * rl1 * ( rl6 - rl7 )
1030         rd0 = 3._wp * rl5*rl5
1031         rd1 = rl5 * ( 7._wp*rl4 + 3._wp*rl8 )
1032         rd2 = rl5*rl5 * ( 3._wp*rl3*rl3 - rl2*rl2 ) - 0.75_wp*(rl6*rl6 - rl7*rl7 )
1033         rd3 = rl4 * ( 4._wp*rl4 + 3._wp*rl8)
1034         rd4 = rl4 * ( rl2 * rl6 - 3._wp*rl3*rl7 - rl5*(rl2*rl2 - rl3*rl3 ) ) + rl5*rl8 * ( 3._wp*rl3*rl3 - rl2*rl2 )
1035         rd5 = 0.25_wp * ( rl2*rl2 - 3._wp *rl3*rl3 ) * ( rl6*rl6 - rl7*rl7 )
1036         rc0 = 0.5268_wp
1037         rf6 = 8._wp / (rc0**6._wp)
1038         rc_diff = SQRT(2._wp) / (rc0**3._wp)
1039         rcm_sf  =  0.7310_wp
1040         rghmin  = -0.28_wp
1041         rgh0    =  0.0329_wp
1042         rghcri  =  0.03_wp
1043         !
[2715]1044      CASE ( 3 )                             ! Canuto B stability functions
[2397]1045         !
1046         IF(lwp) WRITE(numout,*) 'Stability functions from Canuto B'
1047         rs0 = 1.5_wp * rm1 * rm5*rm5
1048         rs1 = -rm4 * (rm6+rm7) + 2._wp * rm4*rm5*(rm1-(1._wp/3._wp)*rm2-rm3) + 1.5_wp * rm1*rm5*rm8
1049         rs2 = -(3._wp/8._wp) * rm1 * (rm6*rm6-rm7*rm7 )
1050         rs4 = 2._wp * rm5
1051         rs5 = 2._wp * rm4
1052         rs6 = (2._wp/3._wp) * rm5 * (3._wp*rm3*rm3-rm2*rm2) - 0.5_wp * rm5*rm1*(3._wp*rm3-rm2) + 0.75_wp * rm1*(rm6-rm7)
1053         rd0 = 3._wp * rm5*rm5
1054         rd1 = rm5 * (7._wp*rm4 + 3._wp*rm8)
1055         rd2 = rm5*rm5 * (3._wp*rm3*rm3 - rm2*rm2) - 0.75_wp * (rm6*rm6 - rm7*rm7)
1056         rd3 = rm4 * ( 4._wp*rm4 + 3._wp*rm8 )
1057         rd4 = rm4 * ( rm2*rm6 -3._wp*rm3*rm7 - rm5*(rm2*rm2 - rm3*rm3) ) + rm5 * rm8 * ( 3._wp*rm3*rm3 - rm2*rm2 )
1058         rd5 = 0.25_wp * ( rm2*rm2 - 3._wp*rm3*rm3 ) * ( rm6*rm6 - rm7*rm7 )
1059         rc0 = 0.5268_wp            !!       rc0 = 0.5540_wp (Warner ...) to verify !
1060         rf6 = 8._wp / ( rc0**6._wp )
1061         rc_diff = SQRT(2._wp)/(rc0**3.)
1062         rcm_sf  =  0.7470_wp
1063         rghmin  = -0.28_wp
1064         rgh0    =  0.0444_wp
1065         rghcri  =  0.0414_wp
1066         !
[2048]1067      END SELECT
1068   
[2715]1069      !                                !* Set Schmidt number for psi diffusion in the wave breaking case
1070      !                                     ! See Eq. (13) of Carniel et al, OM, 30, 225-239, 2009
1071      !                                     !  or Eq. (17) of Burchard, JPO, 31, 3133-3145, 2001
[5109]1072      IF( ln_sigpsi ) THEN
1073         ra_sf = -1.5 ! Set kinetic energy slope, then deduce rsc_psi and rl_sf
1074         ! Verification: retrieve Burchard (2001) results by uncomenting the line below:
1075         ! Note that the results depend on the value of rn_cm_sf which is constant (=rc0) in his work
1076         ! ra_sf = -SQRT(2./3.*rc0**3./rn_cm_sf*rn_sc_tke)/vkarmn
1077         rsc_psi0 = rsc_tke/(24.*rpsi2)*(-1.+(4.*rnn + ra_sf*(1.+4.*rmm))**2./(ra_sf**2.))
[2048]1078      ELSE
[2299]1079         rsc_psi0 = rsc_psi
[2048]1080      ENDIF
1081 
[2715]1082      !                                !* Shear free turbulence parameters
[2048]1083      !
[5109]1084      ra_sf  = -4._wp*rnn*SQRT(rsc_tke) / ( (1._wp+4._wp*rmm)*SQRT(rsc_tke) &
1085               &                              - SQRT(rsc_tke + 24._wp*rsc_psi0*rpsi2 ) )
[2048]1086
[5109]1087      IF ( rn_crban==0._wp ) THEN
1088         rl_sf = vkarmn
1089      ELSE
1090         rl_sf = rc0 * SQRT(rc0/rcm_sf) * SQRT( ( (1._wp + 4._wp*rmm + 8._wp*rmm**2_wp)*rsc_tke          &
1091                 &                                       + 12._wp * rsc_psi0*rpsi2 - (1._wp + 4._wp*rmm) &
1092                 &                                                *SQRT(rsc_tke*(rsc_tke                 &
1093                 &                                                   + 24._wp*rsc_psi0*rpsi2)) )         &
1094                 &                                         /(12._wp*rnn**2.)                             &
1095                 &                                       )
1096      ENDIF
1097
[2048]1098      !
[2715]1099      IF(lwp) THEN                     !* Control print
[2048]1100         WRITE(numout,*)
1101         WRITE(numout,*) 'Limit values'
1102         WRITE(numout,*) '~~~~~~~~~~~~'
[2299]1103         WRITE(numout,*) 'Parameter  m = ',rmm
1104         WRITE(numout,*) 'Parameter  n = ',rnn
1105         WRITE(numout,*) 'Parameter  p = ',rpp
1106         WRITE(numout,*) 'rpsi1   = ',rpsi1
1107         WRITE(numout,*) 'rpsi2   = ',rpsi2
1108         WRITE(numout,*) 'rpsi3m  = ',rpsi3m
1109         WRITE(numout,*) 'rpsi3p  = ',rpsi3p
1110         WRITE(numout,*) 'rsc_tke = ',rsc_tke
1111         WRITE(numout,*) 'rsc_psi = ',rsc_psi
1112         WRITE(numout,*) 'rsc_psi0 = ',rsc_psi0
1113         WRITE(numout,*) 'rc0     = ',rc0
[2048]1114         WRITE(numout,*)
1115         WRITE(numout,*) 'Shear free turbulence parameters:'
[2299]1116         WRITE(numout,*) 'rcm_sf  = ',rcm_sf
1117         WRITE(numout,*) 'ra_sf   = ',ra_sf
1118         WRITE(numout,*) 'rl_sf   = ',rl_sf
[2048]1119         WRITE(numout,*)
1120      ENDIF
1121
[2715]1122      !                                !* Constants initialization
[2397]1123      rc02  = rc0  * rc0   ;   rc02r = 1. / rc02
1124      rc03  = rc02 * rc0
1125      rc04  = rc03 * rc0
[5109]1126      rsbc_tke1 = -3._wp/2._wp*rn_crban*ra_sf*rl_sf                      ! Dirichlet + Wave breaking
1127      rsbc_tke2 = rdt * rn_crban / rl_sf                                 ! Neumann + Wave breaking
1128      zcr = MAX(rsmall, rsbc_tke1**(1./(-ra_sf*3._wp/2._wp))-1._wp )
1129      rtrans = 0.2_wp / zcr                                              ! Ad. inverse transition length between log and wave layer
1130      rsbc_zs1  = rn_charn/grav                                          ! Charnock formula for surface roughness
1131      rsbc_zs2  = rn_frac_hs / 0.85_wp / grav * 665._wp                  ! Rascle formula for surface roughness
1132      rsbc_psi1 = -0.5_wp * rdt * rc0**(rpp-2._wp*rmm) / rsc_psi
1133      rsbc_psi2 = -0.5_wp * rdt * rc0**rpp * rnn * vkarmn**rnn / rsc_psi ! Neumann + NO Wave breaking
[2048]1134
[5109]1135      rfact_tke = -0.5_wp / rsc_tke * rdt                                ! Cst used for the Diffusion term of tke
1136      rfact_psi = -0.5_wp / rsc_psi * rdt                                ! Cst used for the Diffusion term of tke
1137
[2397]1138      !                                !* Wall proximity function
[2048]1139      zwall (:,:,:) = 1._wp * tmask(:,:,:)
1140
[2397]1141      !                                !* set vertical eddy coef. to the background value
[2048]1142      DO jk = 1, jpk
1143         avt (:,:,jk) = avtb(jk) * tmask(:,:,jk)
1144         avm (:,:,jk) = avmb(jk) * tmask(:,:,jk)
1145         avmu(:,:,jk) = avmb(jk) * umask(:,:,jk)
1146         avmv(:,:,jk) = avmb(jk) * vmask(:,:,jk)
1147      END DO
[2715]1148      !                             
1149      CALL gls_rst( nit000, 'READ' )   !* read or initialize all required files
[2048]1150      !
[3294]1151      IF( nn_timing == 1 )  CALL timing_stop('zdf_gls_init')
1152      !
[2048]1153   END SUBROUTINE zdf_gls_init
1154
[2329]1155
[2048]1156   SUBROUTINE gls_rst( kt, cdrw )
[2452]1157      !!---------------------------------------------------------------------
1158      !!                   ***  ROUTINE ts_rst  ***
1159      !!                     
1160      !! ** Purpose :   Read or write TKE file (en) in restart file
1161      !!
1162      !! ** Method  :   use of IOM library
1163      !!                if the restart does not contain TKE, en is either
1164      !!                set to rn_emin or recomputed (nn_igls/=0)
1165      !!----------------------------------------------------------------------
1166      INTEGER         , INTENT(in) ::   kt         ! ocean time-step
1167      CHARACTER(len=*), INTENT(in) ::   cdrw       ! "READ"/"WRITE" flag
1168      !
1169      INTEGER ::   jit, jk   ! dummy loop indices
[3294]1170      INTEGER ::   id1, id2, id3, id4, id5, id6
[2452]1171      INTEGER ::   ji, jj, ikbu, ikbv
1172      REAL(wp)::   cbx, cby
1173      !!----------------------------------------------------------------------
1174      !
1175      IF( TRIM(cdrw) == 'READ' ) THEN        ! Read/initialise
1176         !                                   ! ---------------
1177         IF( ln_rstart ) THEN                   !* Read the restart file
1178            id1 = iom_varid( numror, 'en'   , ldstop = .FALSE. )
1179            id2 = iom_varid( numror, 'avt'  , ldstop = .FALSE. )
1180            id3 = iom_varid( numror, 'avm'  , ldstop = .FALSE. )
1181            id4 = iom_varid( numror, 'avmu' , ldstop = .FALSE. )
1182            id5 = iom_varid( numror, 'avmv' , ldstop = .FALSE. )
1183            id6 = iom_varid( numror, 'mxln' , ldstop = .FALSE. )
1184            !
[3294]1185            IF( MIN( id1, id2, id3, id4, id5, id6 ) > 0 ) THEN        ! all required arrays exist
[2452]1186               CALL iom_get( numror, jpdom_autoglo, 'en'    , en     )
1187               CALL iom_get( numror, jpdom_autoglo, 'avt'   , avt    )
1188               CALL iom_get( numror, jpdom_autoglo, 'avm'   , avm    )
1189               CALL iom_get( numror, jpdom_autoglo, 'avmu'  , avmu   )
1190               CALL iom_get( numror, jpdom_autoglo, 'avmv'  , avmv   )
1191               CALL iom_get( numror, jpdom_autoglo, 'mxln'  , mxln   )
1192            ELSE                       
1193               IF(lwp) WRITE(numout,*) ' ===>>>> : previous run without gls scheme, en and mxln computed by iterative loop'
1194               en  (:,:,:) = rn_emin
[5109]1195               mxln(:,:,:) = 0.05       
[4839]1196               avt_k (:,:,:) = avt (:,:,:)
1197               avm_k (:,:,:) = avm (:,:,:)
1198               avmu_k(:,:,:) = avmu(:,:,:)
1199               avmv_k(:,:,:) = avmv(:,:,:)
[2452]1200               DO jit = nit000 + 1, nit000 + 10   ;   CALL zdf_gls( jit )   ;   END DO
1201            ENDIF
1202         ELSE                                   !* Start from rest
1203            IF(lwp) WRITE(numout,*) ' ===>>>> : Initialisation of en and mxln by background values'
1204            en  (:,:,:) = rn_emin
[5109]1205            mxln(:,:,:) = 0.05       
[2452]1206         ENDIF
1207         !
1208      ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN   ! Create restart file
1209         !                                   ! -------------------
1210         IF(lwp) WRITE(numout,*) '---- gls-rst ----'
[9252]1211         IF(nn_timing == 3)  CALL timing_start('rst_put')
[5109]1212         CALL iom_rstput( kt, nitrst, numrow, 'en'   , en     ) 
[3798]1213         CALL iom_rstput( kt, nitrst, numrow, 'avt'  , avt_k  )
1214         CALL iom_rstput( kt, nitrst, numrow, 'avm'  , avm_k  )
[5109]1215         CALL iom_rstput( kt, nitrst, numrow, 'avmu' , avmu_k ) 
[3798]1216         CALL iom_rstput( kt, nitrst, numrow, 'avmv' , avmv_k )
1217         CALL iom_rstput( kt, nitrst, numrow, 'mxln' , mxln   )
[9252]1218         IF(nn_timing == 3)  CALL timing_stop('rst_put')
[2452]1219         !
1220      ENDIF
1221      !
[2048]1222   END SUBROUTINE gls_rst
1223
1224#else
1225   !!----------------------------------------------------------------------
1226   !!   Dummy module :                                        NO TKE scheme
1227   !!----------------------------------------------------------------------
1228   LOGICAL, PUBLIC, PARAMETER ::   lk_zdfgls = .FALSE.   !: TKE flag
1229CONTAINS
[2409]1230   SUBROUTINE zdf_gls_init           ! Empty routine
1231      WRITE(*,*) 'zdf_gls_init: You should not have seen this print! error?'
1232   END SUBROUTINE zdf_gls_init
[2048]1233   SUBROUTINE zdf_gls( kt )          ! Empty routine
1234      WRITE(*,*) 'zdf_gls: You should not have seen this print! error?', kt
1235   END SUBROUTINE zdf_gls
[2397]1236   SUBROUTINE gls_rst( kt, cdrw )          ! Empty routine
[2264]1237      INTEGER         , INTENT(in) ::   kt         ! ocean time-step
1238      CHARACTER(len=*), INTENT(in) ::   cdrw       ! "READ"/"WRITE" flag
[2397]1239      WRITE(*,*) 'gls_rst: You should not have seen this print! error?', kt, cdrw
[2264]1240   END SUBROUTINE gls_rst
[2048]1241#endif
1242
1243   !!======================================================================
1244END MODULE zdfgls
[2397]1245
Note: See TracBrowser for help on using the repository browser.