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.
icedyn_adv_umx.F90 in branches/2017/dev_merge_2017/NEMOGCM/NEMO/LIM_SRC_3 – NEMO

source: branches/2017/dev_merge_2017/NEMOGCM/NEMO/LIM_SRC_3/icedyn_adv_umx.F90 @ 9119

Last change on this file since 9119 was 9019, checked in by timgraham, 6 years ago

Merge of dev_CNRS_2017 into branch

File size: 33.3 KB
Line 
1MODULE icedyn_adv_umx
2   !!==============================================================================
3   !!                       ***  MODULE  icedyn_adv_umx  ***
4   !! sea-ice : advection using the ULTIMATE-MACHO scheme
5   !!==============================================================================
6   !! History :  3.6  !  2014-11  (C. Rousset, G. Madec)  Original code
7   !!----------------------------------------------------------------------
8#if defined key_lim3
9   !!----------------------------------------------------------------------
10   !!   'key_lim3'                                       ESIM sea-ice model
11   !!----------------------------------------------------------------------
12   !!   ice_dyn_adv_umx   : update the tracer trend with the 3D advection trends using a TVD scheme
13   !!   ultimate_x(_y)    : compute a tracer value at velocity points using ULTIMATE scheme at various orders
14   !!   macho             : ???
15   !!   nonosc_2d         : compute monotonic tracer fluxes by a non-oscillatory algorithm
16   !!----------------------------------------------------------------------
17   USE phycst         ! physical constant
18   USE dom_oce        ! ocean domain
19   USE sbc_oce , ONLY : nn_fsbc   ! update frequency of surface boundary condition
20   USE ice            ! sea-ice variables
21   !
22   USE in_out_manager ! I/O manager
23   USE lib_mpp        ! MPP library
24   USE lib_fortran    ! fortran utilities (glob_sum + no signed zero)
25   USE lbclnk         ! lateral boundary conditions (or mpp links)
26
27   IMPLICIT NONE
28   PRIVATE
29
30   PUBLIC   ice_dyn_adv_umx   ! called by icedyn_adv.F90
31     
32   REAL(wp) ::   z1_6   = 1._wp /   6._wp   ! =1/6
33   REAL(wp) ::   z1_120 = 1._wp / 120._wp   ! =1/120
34
35   !! * Substitutions
36#  include "vectopt_loop_substitute.h90"
37   !!----------------------------------------------------------------------
38   !! NEMO/ICE 4.0 , NEMO Consortium (2017)
39   !! $Id: icedyn_adv_umx.F90 4499 2014-02-18 15:14:31Z timgraham $
40   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
41   !!----------------------------------------------------------------------
42CONTAINS
43
44   SUBROUTINE ice_dyn_adv_umx( k_order, kt, pu_ice, pv_ice,  &
45      &                    pato_i, pv_i, pv_s, psv_i, poa_i, pa_i, pa_ip, pv_ip, pe_s, pe_i )
46      !!----------------------------------------------------------------------
47      !!                  ***  ROUTINE ice_dyn_adv_umx  ***
48      !!
49      !! **  Purpose :   Compute the now trend due to total advection of
50      !!                 tracers and add it to the general trend of tracer equations
51      !!                 using an "Ultimate-Macho" scheme
52      !!
53      !! Reference : Leonard, B.P., 1991, Comput. Methods Appl. Mech. Eng., 88, 17-74.
54      !!----------------------------------------------------------------------
55      INTEGER                     , INTENT(in   ) ::   k_order    ! order of the scheme (1-5 or 20)
56      INTEGER                     , INTENT(in   ) ::   kt         ! time step
57      REAL(wp), DIMENSION(:,:)    , INTENT(in   ) ::   pu_ice     ! ice i-velocity
58      REAL(wp), DIMENSION(:,:)    , INTENT(in   ) ::   pv_ice     ! ice j-velocity
59      REAL(wp), DIMENSION(:,:)    , INTENT(inout) ::   pato_i     ! open water area
60      REAL(wp), DIMENSION(:,:,:)  , INTENT(inout) ::   pv_i       ! ice volume
61      REAL(wp), DIMENSION(:,:,:)  , INTENT(inout) ::   pv_s       ! snw volume
62      REAL(wp), DIMENSION(:,:,:)  , INTENT(inout) ::   psv_i      ! salt content
63      REAL(wp), DIMENSION(:,:,:)  , INTENT(inout) ::   poa_i      ! age content
64      REAL(wp), DIMENSION(:,:,:)  , INTENT(inout) ::   pa_i       ! ice concentration
65      REAL(wp), DIMENSION(:,:,:)  , INTENT(inout) ::   pa_ip      ! melt pond fraction
66      REAL(wp), DIMENSION(:,:,:)  , INTENT(inout) ::   pv_ip      ! melt pond volume
67      REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) ::   pe_s       ! snw heat content
68      REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) ::   pe_i       ! ice heat content
69      !
70      INTEGER  ::   ji, jj, jk, jl, jt      ! dummy loop indices
71      INTEGER  ::   initad                  ! number of sub-timestep for the advection
72      REAL(wp) ::   zcfl , zusnit, zdt      !   -      -
73      REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   zudy, zvdx, zcu_box, zcv_box
74      !!----------------------------------------------------------------------
75      !
76      IF( kt == nit000 .AND. lwp )   WRITE(numout,*) '-- ice_dyn_adv_umx: Ultimate-Macho advection scheme'
77      !
78      ALLOCATE( zudy(jpi,jpj) , zvdx(jpi,jpj) , zcu_box(jpi,jpj) , zcv_box(jpi,jpj) )
79      !
80      ! --- If ice drift field is too fast, use an appropriate time step for advection (CFL test for stability) --- !       
81      zcfl  =            MAXVAL( ABS( pu_ice(:,:) ) * rdt_ice * r1_e1u(:,:) )
82      zcfl  = MAX( zcfl, MAXVAL( ABS( pv_ice(:,:) ) * rdt_ice * r1_e2v(:,:) ) )
83      IF( lk_mpp )   CALL mpp_max( zcfl )
84
85      IF( zcfl > 0.5 ) THEN   ;   initad = 2   ;   zusnit = 0.5_wp
86      ELSE                    ;   initad = 1   ;   zusnit = 1.0_wp
87      ENDIF
88
89      zdt = rdt_ice / REAL(initad)
90
91      ! --- transport --- !
92      zudy(:,:) = pu_ice(:,:) * e2u(:,:)
93      zvdx(:,:) = pv_ice(:,:) * e1v(:,:)
94
95      ! --- define velocity for advection: u*grad(H) --- !
96      DO jj = 2, jpjm1
97         DO ji = fs_2, fs_jpim1
98            IF    ( pu_ice(ji,jj) * pu_ice(ji-1,jj) <= 0._wp ) THEN   ;   zcu_box(ji,jj) = 0._wp
99            ELSEIF( pu_ice(ji,jj)                   >  0._wp ) THEN   ;   zcu_box(ji,jj) = pu_ice(ji-1,jj)
100            ELSE                                                      ;   zcu_box(ji,jj) = pu_ice(ji  ,jj)
101            ENDIF
102
103            IF    ( pv_ice(ji,jj) * pv_ice(ji,jj-1) <= 0._wp ) THEN   ;   zcv_box(ji,jj) = 0._wp
104            ELSEIF( pv_ice(ji,jj)                   >  0._wp ) THEN   ;   zcv_box(ji,jj) = pv_ice(ji,jj-1)
105            ELSE                                                      ;   zcv_box(ji,jj) = pv_ice(ji,jj  )
106            ENDIF
107         END DO
108      END DO
109
110      !---------------!
111      !== advection ==!
112      !---------------!
113      DO jt = 1, initad
114         CALL adv_umx( k_order, kt, zdt, zudy, zvdx, zcu_box, zcv_box, pato_i(:,:) )             ! Open water area
115         DO jl = 1, jpl
116            CALL adv_umx( k_order, kt, zdt, zudy, zvdx, zcu_box, zcv_box, pa_i(:,:,jl) )         ! Ice area
117            CALL adv_umx( k_order, kt, zdt, zudy, zvdx, zcu_box, zcv_box, pv_i(:,:,jl) )         ! Ice  volume
118            CALL adv_umx( k_order, kt, zdt, zudy, zvdx, zcu_box, zcv_box, psv_i(:,:,jl) )        ! Salt content
119            CALL adv_umx( k_order, kt, zdt, zudy, zvdx, zcu_box, zcv_box, poa_i(:,:,jl) )        ! Age content
120            DO jk = 1, nlay_i
121               CALL adv_umx( k_order, kt, zdt, zudy, zvdx, zcu_box, zcv_box, pe_i(:,:,jk,jl) )   ! Ice  heat content
122            END DO
123            CALL adv_umx( k_order, kt, zdt, zudy, zvdx, zcu_box, zcv_box, pv_s(:,:,jl) )         ! Snow volume
124            CALL adv_umx( k_order, kt, zdt, zudy, zvdx, zcu_box, zcv_box, pe_s(:,:,1,jl) )       ! Snow heat content
125            IF ( ln_pnd_H12 ) THEN
126               CALL adv_umx( k_order, kt, zdt, zudy, zvdx, zcu_box, zcv_box, pa_ip(:,:,jl) )     ! Melt pond fraction
127               CALL adv_umx( k_order, kt, zdt, zudy, zvdx, zcu_box, zcv_box, pv_ip(:,:,jl) )     ! Melt pond volume
128            ENDIF
129         END DO
130      END DO
131      !
132      DEALLOCATE( zudy, zvdx, zcu_box, zcv_box )
133      !
134   END SUBROUTINE ice_dyn_adv_umx
135   
136   SUBROUTINE adv_umx( k_order, kt, pdt, puc, pvc, pubox, pvbox, ptc )
137      !!----------------------------------------------------------------------
138      !!                  ***  ROUTINE adv_umx  ***
139      !!
140      !! **  Purpose :   Compute the now trend due to total advection of
141      !!       tracers and add it to the general trend of tracer equations
142      !!
143      !! **  Method  :   TVD scheme, i.e. 2nd order centered scheme with
144      !!       corrected flux (monotonic correction)
145      !!       note: - this advection scheme needs a leap-frog time scheme
146      !!
147      !! ** Action : - pt  the after advective tracer
148      !!----------------------------------------------------------------------
149      INTEGER                     , INTENT(in   ) ::   k_order        ! order of the ULTIMATE scheme
150      INTEGER                     , INTENT(in   ) ::   kt             ! number of iteration
151      REAL(wp)                    , INTENT(in   ) ::   pdt            ! tracer time-step
152      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) ::   puc  , pvc     ! 2 ice velocity components => u*e2
153      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) ::   pubox, pvbox   ! upstream velocity
154      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   ptc            ! tracer content field
155      !
156      INTEGER  ::   ji, jj           ! dummy loop indices 
157      REAL(wp) ::   ztra             ! local scalar
158      REAL(wp) ::   zfp_ui, zfp_vj   !   -      -
159      REAL(wp) ::   zfm_ui, zfm_vj   !   -      -
160      REAL(wp), DIMENSION(jpi,jpj) ::   zfu_ups, zfu_ho, zt_u, zt_ups
161      REAL(wp), DIMENSION(jpi,jpj) ::   zfv_ups, zfv_ho, zt_v, ztrd
162      !!----------------------------------------------------------------------
163      !
164      !  upstream advection with initial mass fluxes & intermediate update
165      ! --------------------------------------------------------------------
166      DO jj = 1, jpjm1         ! upstream tracer flux in the i and j direction
167         DO ji = 1, fs_jpim1   ! vector opt.
168            zfp_ui = puc(ji,jj) + ABS( puc(ji,jj) )
169            zfm_ui = puc(ji,jj) - ABS( puc(ji,jj) )
170            zfp_vj = pvc(ji,jj) + ABS( pvc(ji,jj) )
171            zfm_vj = pvc(ji,jj) - ABS( pvc(ji,jj) )
172            zfu_ups(ji,jj) = 0.5_wp * ( zfp_ui * ptc(ji,jj) + zfm_ui * ptc(ji+1,jj  ) )
173            zfv_ups(ji,jj) = 0.5_wp * ( zfp_vj * ptc(ji,jj) + zfm_vj * ptc(ji  ,jj+1) )
174         END DO
175      END DO
176     
177      DO jj = 2, jpjm1            ! total intermediate advective trends
178         DO ji = fs_2, fs_jpim1   ! vector opt.
179            ztra = - (   zfu_ups(ji,jj) - zfu_ups(ji-1,jj  )   &
180               &       + zfv_ups(ji,jj) - zfv_ups(ji  ,jj-1)   ) * r1_e1e2t(ji,jj)
181            !
182            ztrd(ji,jj) =                         ztra                         ! upstream trend [ -div(uh) or -div(uhT) ] 
183            zt_ups (ji,jj) = ( ptc(ji,jj) + pdt * ztra ) * tmask(ji,jj,1)      ! guess after content field with monotonic scheme
184         END DO
185      END DO
186      CALL lbc_lnk( zt_ups, 'T', 1. )        ! Lateral boundary conditions   (unchanged sign)
187     
188      ! High order (_ho) fluxes
189      ! -----------------------
190      SELECT CASE( k_order )
191      CASE ( 20 )                          ! centered second order
192         DO jj = 1, jpjm1
193            DO ji = 1, fs_jpim1   ! vector opt.
194               zfu_ho(ji,jj) = 0.5 * puc(ji,jj) * ( ptc(ji,jj) + ptc(ji+1,jj) )
195               zfv_ho(ji,jj) = 0.5 * pvc(ji,jj) * ( ptc(ji,jj) + ptc(ji,jj+1) )
196            END DO
197         END DO
198         !
199      CASE ( 1:5 )                      ! 1st to 5th order ULTIMATE-MACHO scheme
200         CALL macho( k_order, kt, pdt, ptc, puc, pvc, pubox, pvbox, zt_u, zt_v )
201         !
202         DO jj = 1, jpjm1
203            DO ji = 1, fs_jpim1   ! vector opt.
204               zfu_ho(ji,jj) = puc(ji,jj) * zt_u(ji,jj)
205               zfv_ho(ji,jj) = pvc(ji,jj) * zt_v(ji,jj)
206            END DO
207         END DO
208         !
209      END SELECT
210         
211      ! antidiffusive flux : high order minus low order
212      ! --------------------------------------------------
213      DO jj = 1, jpjm1
214         DO ji = 1, fs_jpim1   ! vector opt.
215            zfu_ho(ji,jj) = zfu_ho(ji,jj) - zfu_ups(ji,jj)
216            zfv_ho(ji,jj) = zfv_ho(ji,jj) - zfv_ups(ji,jj)
217         END DO
218      END DO
219     
220      ! monotonicity algorithm
221      ! -------------------------
222      CALL nonosc_2d( ptc, zfu_ho, zfv_ho, zt_ups, pdt )
223     
224      ! final trend with corrected fluxes
225      ! ------------------------------------
226      DO jj = 2, jpjm1
227         DO ji = fs_2, fs_jpim1   ! vector opt. 
228            ztra       = ztrd(ji,jj)  - (  zfu_ho(ji,jj) - zfu_ho(ji-1,jj  )   &
229               &                         + zfv_ho(ji,jj) - zfv_ho(ji  ,jj-1) ) * r1_e1e2t(ji,jj) 
230            ptc(ji,jj) = ptc(ji,jj) + pdt * ztra
231         END DO
232      END DO
233      CALL lbc_lnk( ptc(:,:) , 'T',  1. )
234      !
235   END SUBROUTINE adv_umx
236
237
238   SUBROUTINE macho( k_order, kt, pdt, ptc, puc, pvc, pubox, pvbox, pt_u, pt_v )
239      !!---------------------------------------------------------------------
240      !!                    ***  ROUTINE ultimate_x  ***
241      !!     
242      !! **  Purpose :   compute 
243      !!
244      !! **  Method  :   ... ???
245      !!                 TIM = transient interpolation Modeling
246      !!
247      !! Reference : Leonard, B.P., 1991, Comput. Methods Appl. Mech. Eng., 88, 17-74.
248      !!----------------------------------------------------------------------
249      INTEGER                     , INTENT(in   ) ::   k_order    ! order of the ULTIMATE scheme
250      INTEGER                     , INTENT(in   ) ::   kt         ! number of iteration
251      REAL(wp)                    , INTENT(in   ) ::   pdt        ! tracer time-step
252      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) ::   ptc        ! tracer fields
253      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) ::   puc, pvc   ! 2 ice velocity components
254      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) ::   pubox, pvbox   ! upstream velocity
255      REAL(wp), DIMENSION(jpi,jpj), INTENT(  out) ::   pt_u, pt_v ! tracer at u- and v-points
256      !
257      INTEGER  ::   ji, jj    ! dummy loop indices
258      REAL(wp) ::   zc_box    !   -      -
259      REAL(wp), DIMENSION(jpi,jpj) :: zzt
260      !!----------------------------------------------------------------------
261      !
262      IF( MOD( (kt - 1) / nn_fsbc , 2 ) == 0 ) THEN         !==  odd ice time step:  adv_x then adv_y  ==!
263         !
264         !                                                           !--  ultimate interpolation of pt at u-point  --!
265         CALL ultimate_x( k_order, pdt, ptc, puc, pt_u )
266         !
267         !                                                           !--  advective form update in zzt  --!
268         DO jj = 2, jpjm1
269            DO ji = fs_2, fs_jpim1   ! vector opt.
270               zzt(ji,jj) = ptc(ji,jj) - pubox(ji,jj) * pdt * ( pt_u(ji,jj) - pt_u(ji-1,jj) ) * r1_e1t(ji,jj)  &
271                  &                    - ptc  (ji,jj) * pdt * ( puc (ji,jj) - puc (ji-1,jj) ) * r1_e1e2t(ji,jj)
272               zzt(ji,jj) = zzt(ji,jj) * tmask(ji,jj,1)
273            END DO
274         END DO
275         CALL lbc_lnk( zzt, 'T', 1. )
276         !
277         !                                                           !--  ultimate interpolation of pt at v-point  --!
278         CALL ultimate_y( k_order, pdt, zzt, pvc, pt_v )
279         !
280      ELSE                                                  !==  even ice time step:  adv_y then adv_x  ==!
281         !
282         !                                                           !--  ultimate interpolation of pt at v-point  --!
283         CALL ultimate_y( k_order, pdt, ptc, pvc, pt_v )
284         !
285         !                                                           !--  advective form update in zzt  --!
286         DO jj = 2, jpjm1
287            DO ji = fs_2, fs_jpim1
288               zzt(ji,jj) = ptc(ji,jj) - pvbox(ji,jj) * pdt * ( pt_v(ji,jj) - pt_v(ji,jj-1) ) * r1_e2t(ji,jj)  &
289                  &                    - ptc  (ji,jj) * pdt * ( pvc (ji,jj) - pvc (ji,jj-1) ) * r1_e1e2t(ji,jj)
290               zzt(ji,jj) = zzt(ji,jj) * tmask(ji,jj,1)
291            END DO
292         END DO
293         CALL lbc_lnk( zzt, 'T', 1. )
294         !
295         !                                                           !--  ultimate interpolation of pt at u-point  --!
296         CALL ultimate_x( k_order, pdt, zzt, puc, pt_u )
297         !     
298      ENDIF     
299      !
300   END SUBROUTINE macho
301
302
303   SUBROUTINE ultimate_x( k_order, pdt, pt, puc, pt_u )
304      !!---------------------------------------------------------------------
305      !!                    ***  ROUTINE ultimate_x  ***
306      !!     
307      !! **  Purpose :   compute 
308      !!
309      !! **  Method  :   ... ???
310      !!                 TIM = transient interpolation Modeling
311      !!
312      !! Reference : Leonard, B.P., 1991, Comput. Methods Appl. Mech. Eng., 88, 17-74.
313      !!----------------------------------------------------------------------
314      INTEGER                     , INTENT(in   ) ::   k_order   ! ocean time-step index
315      REAL(wp)                    , INTENT(in   ) ::   pdt       ! tracer time-step
316      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) ::   puc       ! ice i-velocity component
317      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) ::   pt        ! tracer fields
318      REAL(wp), DIMENSION(jpi,jpj), INTENT(  out) ::   pt_u      ! tracer at u-point
319      !
320      INTEGER  ::   ji, jj       ! dummy loop indices
321      REAL(wp) ::   zcu, zdx2, zdx4    !   -      -
322      REAL(wp), DIMENSION(jpi,jpj) :: ztu1, ztu2, ztu3, ztu4
323      !!----------------------------------------------------------------------
324      !
325      !                                                     !--  Laplacian in i-direction  --!
326      DO jj = 2, jpjm1         ! First derivative (gradient)
327         DO ji = 1, fs_jpim1
328            ztu1(ji,jj) = ( pt(ji+1,jj) - pt(ji,jj) ) * r1_e1u(ji,jj) * umask(ji,jj,1)
329         END DO
330         !                     ! Second derivative (Laplacian)
331         DO ji = fs_2, fs_jpim1
332            ztu2(ji,jj) = ( ztu1(ji,jj) - ztu1(ji-1,jj) ) * r1_e1t(ji,jj)
333         END DO
334      END DO
335      CALL lbc_lnk( ztu2, 'T', 1. )
336      !
337      !                                                     !--  BiLaplacian in i-direction  --!
338      DO jj = 2, jpjm1         ! Third derivative
339         DO ji = 1, fs_jpim1
340            ztu3(ji,jj) = ( ztu2(ji+1,jj) - ztu2(ji,jj) ) * r1_e1u(ji,jj) * umask(ji,jj,1)
341         END DO
342         !                     ! Fourth derivative
343         DO ji = fs_2, fs_jpim1
344            ztu4(ji,jj) = ( ztu3(ji,jj) - ztu3(ji-1,jj) ) * r1_e1t(ji,jj)
345         END DO
346      END DO
347      CALL lbc_lnk( ztu4, 'T', 1. )
348      !
349      !
350      SELECT CASE (k_order )
351      !
352      CASE( 1 )                                                   !==  1st order central TIM  ==! (Eq. 21)
353         !       
354         DO jj = 2, jpjm1
355            DO ji = 1, fs_jpim1   ! vector opt.
356               pt_u(ji,jj) = 0.5_wp * umask(ji,jj,1) * (                               pt(ji+1,jj) + pt(ji,jj)   &
357                  &                                    - SIGN( 1._wp, puc(ji,jj) ) * ( pt(ji+1,jj) - pt(ji,jj) ) )
358            END DO
359         END DO
360         !
361      CASE( 2 )                                                   !==  2nd order central TIM  ==! (Eq. 23)
362         !
363         DO jj = 2, jpjm1
364            DO ji = 1, fs_jpim1   ! vector opt.
365               zcu  = puc(ji,jj) * r1_e2u(ji,jj) * pdt * r1_e1u(ji,jj)
366               pt_u(ji,jj) = 0.5_wp * umask(ji,jj,1) * (                                   pt(ji+1,jj) + pt(ji,jj)   &
367                  &                                               -              zcu   * ( pt(ji+1,jj) - pt(ji,jj) ) ) 
368            END DO
369         END DO
370         
371      CASE( 3 )                                                   !==  3rd order central TIM  ==! (Eq. 24)
372         !
373         DO jj = 2, jpjm1
374            DO ji = 1, fs_jpim1   ! vector opt.
375               zcu  = puc(ji,jj) * r1_e2u(ji,jj) * pdt * r1_e1u(ji,jj)
376               zdx2 = e1u(ji,jj) * e1u(ji,jj)
377!!rachid       zdx2 = e1u(ji,jj) * e1t(ji,jj)
378               pt_u(ji,jj) = 0.5_wp * umask(ji,jj,1) * (         (                         pt  (ji+1,jj) + pt  (ji,jj)        &
379                  &                                               -              zcu   * ( pt  (ji+1,jj) - pt  (ji,jj) )  )   &
380                  &        + z1_6 * zdx2 * ( zcu*zcu - 1._wp ) * (                         ztu2(ji+1,jj) + ztu2(ji,jj)        &
381                  &                                               - SIGN( 1._wp, zcu ) * ( ztu2(ji+1,jj) - ztu2(ji,jj) )  )   )
382            END DO
383         END DO
384         !
385      CASE( 4 )                                                   !==  4th order central TIM  ==! (Eq. 27)
386         !
387         DO jj = 2, jpjm1
388            DO ji = 1, fs_jpim1   ! vector opt.
389               zcu  = puc(ji,jj) * r1_e2u(ji,jj) * pdt * r1_e1u(ji,jj)
390               zdx2 = e1u(ji,jj) * e1u(ji,jj)
391!!rachid       zdx2 = e1u(ji,jj) * e1t(ji,jj)
392               pt_u(ji,jj) = 0.5_wp * umask(ji,jj,1) * (         (                   pt  (ji+1,jj) + pt  (ji,jj)        &
393                  &                                               -          zcu * ( pt  (ji+1,jj) - pt  (ji,jj) )  )   &
394                  &        + z1_6 * zdx2 * ( zcu*zcu - 1._wp ) * (                   ztu2(ji+1,jj) + ztu2(ji,jj)        &
395                  &                                               - 0.5_wp * zcu * ( ztu2(ji+1,jj) - ztu2(ji,jj) )  )   )
396            END DO
397         END DO
398         !
399      CASE( 5 )                                                   !==  5th order central TIM  ==! (Eq. 29)
400         !
401         DO jj = 2, jpjm1
402            DO ji = 1, fs_jpim1   ! vector opt.
403               zcu  = puc(ji,jj) * r1_e2u(ji,jj) * pdt * r1_e1u(ji,jj)
404               zdx2 = e1u(ji,jj) * e1u(ji,jj)
405!!rachid       zdx2 = e1u(ji,jj) * e1t(ji,jj)
406               zdx4 = zdx2 * zdx2
407               pt_u(ji,jj) = 0.5_wp * umask(ji,jj,1) * (               (                   pt  (ji+1,jj) + pt  (ji,jj)       &
408                  &                                                     -          zcu * ( pt  (ji+1,jj) - pt  (ji,jj) ) )   &
409                  &        + z1_6   * zdx2 * ( zcu*zcu - 1._wp ) *     (                   ztu2(ji+1,jj) + ztu2(ji,jj)       &
410                  &                                                     - 0.5_wp * zcu * ( ztu2(ji+1,jj) - ztu2(ji,jj) ) )   &
411                  &        + z1_120 * zdx4 * ( zcu*zcu - 1._wp ) * ( zcu*zcu - 4._wp ) * ( ztu4(ji+1,jj) + ztu4(ji,jj)       &
412                  &                                               - SIGN( 1._wp, zcu ) * ( ztu4(ji+1,jj) - ztu4(ji,jj) ) ) )
413            END DO
414         END DO
415         !
416      END SELECT
417      !
418   END SUBROUTINE ultimate_x
419   
420 
421   SUBROUTINE ultimate_y( k_order, pdt, pt, pvc, pt_v )
422      !!---------------------------------------------------------------------
423      !!                    ***  ROUTINE ultimate_y  ***
424      !!     
425      !! **  Purpose :   compute 
426      !!
427      !! **  Method  :   ... ???
428      !!                 TIM = transient interpolation Modeling
429      !!
430      !! Reference : Leonard, B.P., 1991, Comput. Methods Appl. Mech. Eng., 88, 17-74.
431      !!----------------------------------------------------------------------
432      INTEGER                     , INTENT(in   ) ::   k_order   ! ocean time-step index
433      REAL(wp)                    , INTENT(in   ) ::   pdt       ! tracer time-step
434      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) ::   pvc       ! ice j-velocity component
435      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) ::   pt        ! tracer fields
436      REAL(wp), DIMENSION(jpi,jpj), INTENT(  out) ::   pt_v      ! tracer at v-point
437      !
438      INTEGER  ::   ji, jj       ! dummy loop indices
439      REAL(wp) ::   zcv, zdy2, zdy4    !   -      -
440      REAL(wp), DIMENSION(jpi,jpj) :: ztv1, ztv2, ztv3, ztv4
441      !!----------------------------------------------------------------------
442      !
443      !                                                     !--  Laplacian in j-direction  --!
444      DO jj = 1, jpjm1         ! First derivative (gradient)
445         DO ji = fs_2, fs_jpim1
446            ztv1(ji,jj) = ( pt(ji,jj+1) - pt(ji,jj) ) * r1_e2v(ji,jj) * vmask(ji,jj,1)
447         END DO
448      END DO
449      DO jj = 2, jpjm1         ! Second derivative (Laplacian)
450         DO ji = fs_2, fs_jpim1
451            ztv2(ji,jj) = ( ztv1(ji,jj) - ztv1(ji,jj-1) ) * r1_e2t(ji,jj)
452         END DO
453      END DO
454      CALL lbc_lnk( ztv2, 'T', 1. )
455      !
456      !                                                     !--  BiLaplacian in j-direction  --!
457      DO jj = 1, jpjm1         ! First derivative
458         DO ji = fs_2, fs_jpim1
459            ztv3(ji,jj) = ( ztv2(ji,jj+1) - ztv2(ji,jj) ) * r1_e2v(ji,jj) * vmask(ji,jj,1)
460         END DO
461      END DO
462      DO jj = 2, jpjm1         ! Second derivative
463         DO ji = fs_2, fs_jpim1
464            ztv4(ji,jj) = ( ztv3(ji,jj) - ztv3(ji,jj-1) ) * r1_e2t(ji,jj)
465         END DO
466      END DO
467      CALL lbc_lnk( ztv4, 'T', 1. )
468      !
469      !
470      SELECT CASE (k_order )
471      !
472      CASE( 1 )                                                !==  1st order central TIM  ==! (Eq. 21)
473         DO jj = 1, jpjm1
474            DO ji = fs_2, fs_jpim1
475               pt_v(ji,jj) = 0.5_wp * vmask(ji,jj,1) * (                              ( pt(ji,jj+1) + pt(ji,jj) )  &
476                  &                                     - SIGN( 1._wp, pvc(ji,jj) ) * ( pt(ji,jj+1) - pt(ji,jj) ) )
477            END DO
478         END DO
479         !
480      CASE( 2 )                                                !==  2nd order central TIM  ==! (Eq. 23)
481         DO jj = 1, jpjm1
482            DO ji = fs_2, fs_jpim1
483               zcv  = pvc(ji,jj) * r1_e1v(ji,jj) * pdt * r1_e2v(ji,jj)
484               pt_v(ji,jj) = 0.5_wp * vmask(ji,jj,1) * (        ( pt(ji,jj+1) + pt(ji,jj) )  &
485                  &                                     - zcv * ( pt(ji,jj+1) - pt(ji,jj) ) )
486            END DO
487         END DO
488         CALL lbc_lnk( pt_v(:,:) , 'V',  1. )
489         !
490      CASE( 3 )                                                !==  3rd order central TIM  ==! (Eq. 24)
491         DO jj = 1, jpjm1
492            DO ji = fs_2, fs_jpim1
493               zcv  = pvc(ji,jj) * r1_e1v(ji,jj) * pdt * r1_e2v(ji,jj)
494               zdy2 = e2v(ji,jj) * e2v(ji,jj)
495!!rachid       zdy2 = e2v(ji,jj) * e2t(ji,jj)
496               pt_v(ji,jj) = 0.5_wp * vmask(ji,jj,1) * (                                 ( pt  (ji,jj+1) + pt  (ji,jj)       &
497                  &                                     -                        zcv   * ( pt  (ji,jj+1) - pt  (ji,jj) ) )   &
498                  &        + z1_6 * zdy2 * ( zcv*zcv - 1._wp ) * (                         ztv2(ji,jj+1) + ztv2(ji,jj)       &
499                  &                                               - SIGN( 1._wp, zcv ) * ( ztv2(ji,jj+1) - ztv2(ji,jj) ) ) )
500            END DO
501         END DO
502         !
503      CASE( 4 )                                                !==  4th order central TIM  ==! (Eq. 27)
504         DO jj = 1, jpjm1
505            DO ji = fs_2, fs_jpim1
506               zcv  = pvc(ji,jj) * r1_e1v(ji,jj) * pdt * r1_e2v(ji,jj)
507               zdy2 = e2v(ji,jj) * e2v(ji,jj)
508!!rachid       zdy2 = e2v(ji,jj) * e2t(ji,jj)
509               pt_v(ji,jj) = 0.5_wp * vmask(ji,jj,1) * (                           ( pt  (ji,jj+1) + pt  (ji,jj)       &
510                  &                                               -          zcv * ( pt  (ji,jj+1) - pt  (ji,jj) ) )   &
511                  &        + z1_6 * zdy2 * ( zcv*zcv - 1._wp ) * (                   ztv2(ji,jj+1) + ztv2(ji,jj)       &
512                  &                                               - 0.5_wp * zcv * ( ztv2(ji,jj+1) - ztv2(ji,jj) ) ) )
513            END DO
514         END DO
515         !
516      CASE( 5 )                                                !==  5th order central TIM  ==! (Eq. 29)
517         DO jj = 1, jpjm1
518            DO ji = fs_2, fs_jpim1
519               zcv  = pvc(ji,jj) * r1_e1v(ji,jj) * pdt * r1_e2v(ji,jj)
520               zdy2 = e2v(ji,jj) * e2v(ji,jj)
521!!rachid       zdy2 = e2v(ji,jj) * e2t(ji,jj)
522               zdy4 = zdy2 * zdy2
523               pt_v(ji,jj) = 0.5_wp * vmask(ji,jj,1) * (                                 ( pt  (ji,jj+1) + pt  (ji,jj)      &
524                  &                                                     -          zcv * ( pt  (ji,jj+1) - pt  (ji,jj) ) )  &
525                  &        + z1_6   * zdy2 * ( zcv*zcv - 1._wp ) *     (                   ztv2(ji,jj+1) + ztv2(ji,jj)      &
526                  &                                                     - 0.5_wp * zcv * ( ztv2(ji,jj+1) - ztv2(ji,jj) ) )  &
527                  &        + z1_120 * zdy4 * ( zcv*zcv - 1._wp ) * ( zcv*zcv - 4._wp ) * ( ztv4(ji,jj+1) + ztv4(ji,jj)      &
528                  &                                               - SIGN( 1._wp, zcv ) * ( ztv4(ji,jj+1) - ztv4(ji,jj) ) ) )
529            END DO
530         END DO
531         !
532      END SELECT
533      !
534   END SUBROUTINE ultimate_y
535   
536 
537   SUBROUTINE nonosc_2d( pbef, paa, pbb, paft, pdt )
538      !!---------------------------------------------------------------------
539      !!                    ***  ROUTINE nonosc  ***
540      !!     
541      !! **  Purpose :   compute monotonic tracer fluxes from the upstream
542      !!       scheme and the before field by a nonoscillatory algorithm
543      !!
544      !! **  Method  :   ... ???
545      !!       warning : pbef and paft must be masked, but the boundaries
546      !!       conditions on the fluxes are not necessary zalezak (1979)
547      !!       drange (1995) multi-dimensional forward-in-time and upstream-
548      !!       in-space based differencing for fluid
549      !!----------------------------------------------------------------------
550      REAL(wp)                     , INTENT(in   ) ::   pdt          ! tracer time-step
551      REAL(wp), DIMENSION (jpi,jpj), INTENT(in   ) ::   pbef, paft   ! before & after field
552      REAL(wp), DIMENSION (jpi,jpj), INTENT(inout) ::   paa, pbb     ! monotonic fluxes in the 2 directions
553      !
554      INTEGER  ::   ji, jj    ! dummy loop indices
555      INTEGER  ::   ikm1      ! local integer
556      REAL(wp) ::   zpos, zneg, zbt, za, zb, zc, zbig, zsml, z1_dt   ! local scalars
557      REAL(wp) ::   zau, zbu, zcu, zav, zbv, zcv, zup, zdo            !   -      -
558      REAL(wp), DIMENSION(jpi,jpj) :: zbetup, zbetdo, zbup, zbdo, zmsk, zdiv
559      !!----------------------------------------------------------------------
560      !
561      zbig = 1.e+40_wp
562      zsml = 1.e-15_wp
563
564      ! test on divergence
565      DO jj = 2, jpjm1
566         DO ji = fs_2, fs_jpim1   ! vector opt. 
567            zdiv(ji,jj) =  - (  paa(ji,jj) - paa(ji-1,jj  )   &
568               &              + pbb(ji,jj) - pbb(ji  ,jj-1) ) 
569         END DO
570      END DO
571      CALL lbc_lnk( zdiv, 'T', 1. )        ! Lateral boundary conditions   (unchanged sign)
572
573      ! Determine ice masks for before and after tracers
574      WHERE( pbef(:,:) == 0._wp .AND. paft(:,:) == 0._wp .AND. zdiv(:,:) == 0._wp )   ;   zmsk(:,:) = 0._wp
575      ELSEWHERE                                                                       ;   zmsk(:,:) = 1._wp * tmask(:,:,1)
576      END WHERE
577
578      ! Search local extrema
579      ! --------------------
580      ! max/min of pbef & paft with large negative/positive value (-/+zbig) inside land
581!      zbup(:,:) = MAX( pbef(:,:) * tmask(:,:,1) - zbig * ( 1.e0 - tmask(:,:,1) ),   &
582!         &             paft(:,:) * tmask(:,:,1) - zbig * ( 1.e0 - tmask(:,:,1) )  )
583!      zbdo(:,:) = MIN( pbef(:,:) * tmask(:,:,1) + zbig * ( 1.e0 - tmask(:,:,1) ),   &
584!         &             paft(:,:) * tmask(:,:,1) + zbig * ( 1.e0 - tmask(:,:,1) )  )
585      zbup(:,:) = MAX( pbef(:,:) * zmsk(:,:) - zbig * ( 1.e0 - zmsk(:,:) ),   &
586         &             paft(:,:) * zmsk(:,:) - zbig * ( 1.e0 - zmsk(:,:) )  )
587      zbdo(:,:) = MIN( pbef(:,:) * zmsk(:,:) + zbig * ( 1.e0 - zmsk(:,:) ),   &
588         &             paft(:,:) * zmsk(:,:) + zbig * ( 1.e0 - zmsk(:,:) )  )
589
590      z1_dt = 1._wp / pdt
591      DO jj = 2, jpjm1
592         DO ji = fs_2, fs_jpim1   ! vector opt.
593            !
594            zup  = MAX(   zbup(ji,jj), zbup(ji-1,jj  ), zbup(ji+1,jj  ),   &        ! search max/min in neighbourhood
595               &                       zbup(ji  ,jj-1), zbup(ji  ,jj+1)    )
596            zdo  = MIN(   zbdo(ji,jj), zbdo(ji-1,jj  ), zbdo(ji+1,jj  ),   &
597               &                       zbdo(ji  ,jj-1), zbdo(ji  ,jj+1)    )
598               !
599            zpos = MAX( 0., paa(ji-1,jj  ) ) - MIN( 0., paa(ji  ,jj  ) )   &        ! positive/negative  part of the flux
600               & + MAX( 0., pbb(ji  ,jj-1) ) - MIN( 0., pbb(ji  ,jj  ) )
601            zneg = MAX( 0., paa(ji  ,jj  ) ) - MIN( 0., paa(ji-1,jj  ) )   &
602               & + MAX( 0., pbb(ji  ,jj  ) ) - MIN( 0., pbb(ji  ,jj-1) )
603               !
604            zbt = e1e2t(ji,jj) * z1_dt                                   ! up & down beta terms
605            zbetup(ji,jj) = ( zup         - paft(ji,jj) ) / ( zpos + zsml ) * zbt
606            zbetdo(ji,jj) = ( paft(ji,jj) - zdo         ) / ( zneg + zsml ) * zbt
607         END DO
608      END DO
609      CALL lbc_lnk_multi( zbetup, 'T', 1., zbetdo, 'T', 1. )   ! lateral boundary cond. (unchanged sign)
610
611      ! monotonic flux in the i & j direction (paa & pbb)
612      ! -------------------------------------
613      DO jj = 2, jpjm1
614         DO ji = 1, fs_jpim1   ! vector opt.
615            zau = MIN( 1._wp , zbetdo(ji,jj) , zbetup(ji+1,jj) )
616            zbu = MIN( 1._wp , zbetup(ji,jj) , zbetdo(ji+1,jj) )
617            zcu = 0.5  + SIGN( 0.5 , paa(ji,jj) )
618            !
619            paa(ji,jj) = paa(ji,jj) * ( zcu * zau + ( 1._wp - zcu) * zbu )
620         END DO
621      END DO
622      !
623      DO jj = 1, jpjm1
624         DO ji = fs_2, fs_jpim1   ! vector opt.
625            zav = MIN( 1._wp , zbetdo(ji,jj) , zbetup(ji,jj+1) )
626            zbv = MIN( 1._wp , zbetup(ji,jj) , zbetdo(ji,jj+1) )
627            zcv = 0.5  + SIGN( 0.5 , pbb(ji,jj) )
628            !
629            pbb(ji,jj) = pbb(ji,jj) * ( zcv * zav + ( 1._wp - zcv) * zbv )
630         END DO
631      END DO
632      !
633   END SUBROUTINE nonosc_2d
634
635#else
636   !!----------------------------------------------------------------------
637   !!   Default option           Dummy module         NO ESIM sea-ice model
638   !!----------------------------------------------------------------------
639#endif
640
641   !!======================================================================
642END MODULE icedyn_adv_umx
Note: See TracBrowser for help on using the repository browser.