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.
agrif_oce_sponge.F90 in NEMO/branches/2019/dev_r10973_AGRIF-01_jchanut_small_jpi_jpj/src/NST – NEMO

source: NEMO/branches/2019/dev_r10973_AGRIF-01_jchanut_small_jpi_jpj/src/NST/agrif_oce_sponge.F90 @ 11205

Last change on this file since 11205 was 11205, checked in by jchanut, 4 years ago

#2199
1) Make sponge independent of sub-domain size. Partially masked open boundary segments are not taken into account anymore. To do so, sponge coefficients should be read in a file for realistic applications (then nesting tools need to be modified accordingly).
2) Replace East-West-North-South barotropic data arrays by a global 2d array. Then apply barotropic open boundary conditions thanks to mi0/mi1, mj0/mj1 indexes.
3) Call AGRIF bdy update one more time in dynspg_ts during extrapolation phase. This removes a dozen lines of code in dynspg_ts routine.

  • Property svn:keywords set to Id
File size: 23.1 KB
Line 
1#define SPONGE && define SPONGE_TOP
2
3MODULE agrif_oce_sponge
4   !!======================================================================
5   !!                   ***  MODULE  agrif_oce_interp  ***
6   !! AGRIF: sponge package for the ocean dynamics (OPA)
7   !!======================================================================
8   !! History :  2.0  !  2002-06  (XXX)  Original cade
9   !!             -   !  2005-11  (XXX)
10   !!            3.2  !  2009-04  (R. Benshila)
11   !!            3.6  !  2014-09  (R. Benshila)
12   !!----------------------------------------------------------------------
13#if defined key_agrif
14   !!----------------------------------------------------------------------
15   !!   'key_agrif'                                              AGRIF zoom
16   !!----------------------------------------------------------------------
17   USE par_oce
18   USE oce
19   USE dom_oce
20   !
21   USE in_out_manager
22   USE agrif_oce
23   USE lbclnk          ! ocean lateral boundary conditions (or mpp link)
24
25   IMPLICIT NONE
26   PRIVATE
27
28   PUBLIC Agrif_Sponge, Agrif_Sponge_Tra, Agrif_Sponge_Dyn
29   PUBLIC interptsn_sponge, interpun_sponge, interpvn_sponge
30
31   !!----------------------------------------------------------------------
32   !! NEMO/NST 4.0 , NEMO Consortium (2018)
33   !! $Id$
34   !! Software governed by the CeCILL license (see ./LICENSE)
35   !!----------------------------------------------------------------------
36CONTAINS
37
38   SUBROUTINE Agrif_Sponge_Tra
39      !!----------------------------------------------------------------------
40      !!                 *** ROUTINE Agrif_Sponge_Tra ***
41      !!----------------------------------------------------------------------
42      REAL(wp) ::   zcoef   ! local scalar
43     
44      !!----------------------------------------------------------------------
45      !
46#if defined SPONGE
47      !! Assume persistence:
48      zcoef = REAL(Agrif_rhot()-1,wp)/REAL(Agrif_rhot())
49
50      CALL Agrif_Sponge
51      Agrif_SpecialValue    = 0._wp
52      Agrif_UseSpecialValue = .TRUE.
53      tabspongedone_tsn     = .FALSE.
54      !
55      CALL Agrif_Bc_Variable( tsn_sponge_id, calledweight=zcoef, procname=interptsn_sponge )
56      !
57      Agrif_UseSpecialValue = .FALSE.
58#endif
59      !
60   END SUBROUTINE Agrif_Sponge_Tra
61
62
63   SUBROUTINE Agrif_Sponge_dyn
64      !!----------------------------------------------------------------------
65      !!                 *** ROUTINE Agrif_Sponge_dyn ***
66      !!----------------------------------------------------------------------
67      REAL(wp) ::   zcoef   ! local scalar
68      !!----------------------------------------------------------------------
69      !
70#if defined SPONGE
71      zcoef = REAL(Agrif_rhot()-1,wp)/REAL(Agrif_rhot())
72
73      Agrif_SpecialValue=0.
74      Agrif_UseSpecialValue = ln_spc_dyn
75      !
76      tabspongedone_u = .FALSE.
77      tabspongedone_v = .FALSE.         
78      CALL Agrif_Bc_Variable( un_sponge_id, calledweight=zcoef, procname=interpun_sponge )
79      !
80      tabspongedone_u = .FALSE.
81      tabspongedone_v = .FALSE.
82      CALL Agrif_Bc_Variable( vn_sponge_id, calledweight=zcoef, procname=interpvn_sponge )
83      !
84      Agrif_UseSpecialValue = .FALSE.
85#endif
86      !
87   END SUBROUTINE Agrif_Sponge_dyn
88
89
90   SUBROUTINE Agrif_Sponge
91      !!----------------------------------------------------------------------
92      !!                 *** ROUTINE  Agrif_Sponge ***
93      !!----------------------------------------------------------------------
94      INTEGER  ::   ji, jj, ind1, ind2
95      INTEGER  ::   ispongearea, jspongearea
96      REAL(wp) ::   z1_ispongearea, z1_jspongearea
97      REAL(wp), DIMENSION(jpi,jpj) :: ztabramp
98      !!----------------------------------------------------------------------
99      !
100#if defined SPONGE || defined SPONGE_TOP
101      IF (( .NOT. spongedoneT ).OR.( .NOT. spongedoneU )) THEN
102         ! Define ramp from boundaries towards domain interior at T-points
103         ! Store it in ztabramp
104
105         ispongearea  = 1 + nn_sponge_len * Agrif_irhox()
106         z1_ispongearea = 1._wp / REAL( ispongearea )
107         jspongearea  = 1 + nn_sponge_len * Agrif_irhoy()
108         z1_jspongearea = 1._wp / REAL( jspongearea )
109         
110         ztabramp(:,:) = 0._wp
111
112         ! --- West --- !
113         ind1 = 1+nbghostcells
114         ind2 = 1+nbghostcells + ispongearea 
115         DO ji = mi0(ind1), mi1(ind2)   
116            DO jj = 1, jpj               
117               ztabramp(ji,jj) = REAL( ind2 - mig(ji) ) * z1_ispongearea
118            END DO
119         END DO
120
121         ! --- East --- !
122         ind1 = jpiglo - nbghostcells - ispongearea
123         ind2 = jpiglo - nbghostcells
124         DO ji = mi0(ind1), mi1(ind2)
125            DO jj = 1, jpj
126               ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL( mig(ji) - ind1 ) * z1_ispongearea)
127            ENDDO
128         END DO
129
130         ! --- South --- !
131         ind1 = 1+nbghostcells
132         ind2 = 1+nbghostcells + jspongearea
133         DO jj = mj0(ind1), mj1(ind2) 
134            DO ji = 1, jpi
135               ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL( ind2 - mjg(jj) ) * z1_jspongearea)
136            END DO
137         END DO
138
139         ! --- North --- !
140         ind1 = jpjglo - nbghostcells - jspongearea
141         ind2 = jpjglo - nbghostcells
142         DO jj = mj0(ind1), mj1(ind2)
143            DO ji = 1, jpi
144               ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL( mjg(jj) - ind1 ) * z1_jspongearea)
145            END DO
146         END DO
147
148      ENDIF
149
150      ! Tracers
151      IF( .NOT. spongedoneT ) THEN
152         fsaht_spu(:,:) = 0._wp
153         fsaht_spv(:,:) = 0._wp
154         DO jj = 2, jpjm1
155            DO ji = 2, jpim1   ! vector opt.
156               fsaht_spu(ji,jj) = 0.5_wp * visc_tra * ( ztabramp(ji,jj) + ztabramp(ji+1,jj  ) )
157               fsaht_spv(ji,jj) = 0.5_wp * visc_tra * ( ztabramp(ji,jj) + ztabramp(ji  ,jj+1) )
158            END DO
159         END DO
160         CALL lbc_lnk( 'agrif_oce_sponge', fsaht_spu, 'U', 1. )   ! Lateral boundary conditions
161         CALL lbc_lnk( 'agrif_oce_sponge', fsaht_spv, 'V', 1. )
162         
163         spongedoneT = .TRUE.
164      ENDIF
165
166      ! Dynamics
167      IF( .NOT. spongedoneU ) THEN
168         fsahm_spt(:,:) = 0._wp
169         fsahm_spf(:,:) = 0._wp
170         DO jj = 2, jpjm1
171            DO ji = 2, jpim1   ! vector opt.
172               fsahm_spt(ji,jj) = visc_dyn * ztabramp(ji,jj)
173               fsahm_spf(ji,jj) = 0.25_wp * visc_dyn * ( ztabramp(ji  ,jj  ) + ztabramp(ji  ,jj+1) &
174                                                     &  +ztabramp(ji+1,jj+1) + ztabramp(ji+1,jj  ) )
175            END DO
176         END DO
177         CALL lbc_lnk( 'agrif_oce_sponge', fsahm_spt, 'T', 1. )   ! Lateral boundary conditions
178         CALL lbc_lnk( 'agrif_oce_sponge', fsahm_spf, 'F', 1. )
179         
180         spongedoneU = .TRUE.
181      ENDIF
182      !
183#endif
184      !
185   END SUBROUTINE Agrif_Sponge
186
187   SUBROUTINE interptsn_sponge( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before )
188      !!----------------------------------------------------------------------
189      !!                 *** ROUTINE interptsn_sponge ***
190      !!----------------------------------------------------------------------
191      INTEGER                                     , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2, n1, n2
192      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) ::   tabres
193      LOGICAL                                     , INTENT(in   ) ::   before
194      !
195      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices
196      INTEGER  ::   iku, ikv
197      REAL(wp) :: ztsa, zabe1, zabe2, zbtr
198      REAL(wp), DIMENSION(i1:i2,j1:j2,jpk) :: ztu, ztv
199      REAL(wp), DIMENSION(i1:i2,j1:j2,jpk,n1:n2) ::tsbdiff
200      ! vertical interpolation:
201      REAL(wp), DIMENSION(i1:i2,j1:j2,jpk,n1:n2) ::tabres_child
202      REAL(wp), DIMENSION(k1:k2,n1:n2-1) :: tabin
203      REAL(wp), DIMENSION(k1:k2) :: h_in
204      REAL(wp), DIMENSION(1:jpk) :: h_out
205      INTEGER :: N_in, N_out
206      REAL(wp) :: h_diff
207      !!----------------------------------------------------------------------
208      !
209      IF( before ) THEN
210         DO jn = 1, jpts
211            DO jk=k1,k2
212               DO jj=j1,j2
213                  DO ji=i1,i2
214                     tabres(ji,jj,jk,jn) = tsb(ji,jj,jk,jn)
215                  END DO
216               END DO
217            END DO
218         END DO
219
220# if defined key_vertical
221         DO jk=k1,k2
222            DO jj=j1,j2
223               DO ji=i1,i2
224                  tabres(ji,jj,jk,jpts+1) = tmask(ji,jj,jk) * e3t_n(ji,jj,jk) 
225               END DO
226            END DO
227         END DO
228# endif
229
230      ELSE   
231         !
232# if defined key_vertical
233         tabres_child(:,:,:,:) = 0.
234         DO jj=j1,j2
235            DO ji=i1,i2
236               N_in = 0
237               DO jk=k1,k2 !k2 = jpk of parent grid
238                  IF (tabres(ji,jj,jk,n2) == 0) EXIT
239                  N_in = N_in + 1
240                  tabin(jk,:) = tabres(ji,jj,jk,n1:n2-1)
241                  h_in(N_in) = tabres(ji,jj,jk,n2)
242               END DO
243               N_out = 0
244               DO jk=1,jpk ! jpk of child grid
245                  IF (tmask(ji,jj,jk) == 0) EXIT
246                  N_out = N_out + 1
247                  h_out(jk) = e3t_n(ji,jj,jk) !Child grid scale factors. Could multiply by e1e2t here instead of division above
248               ENDDO
249               IF (N_in > 0) THEN
250                  h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in))
251                  tabres(ji,jj,k2,:) = tabres(ji,jj,k2-1,:) !what is this line for?????
252                  DO jn=1,jpts
253                     call reconstructandremap(tabin(1:N_in,jn),h_in,tabres_child(ji,jj,1:N_out,jn),h_out,N_in,N_out)
254                  ENDDO
255               ENDIF
256            ENDDO
257         ENDDO
258# endif
259
260         DO jj=j1,j2
261            DO ji=i1,i2
262               DO jk=1,jpkm1
263# if defined key_vertical
264                  tsbdiff(ji,jj,jk,1:jpts) = tsb(ji,jj,jk,1:jpts) - tabres_child(ji,jj,jk,1:jpts)
265# else
266                  tsbdiff(ji,jj,jk,1:jpts) = tsb(ji,jj,jk,1:jpts) - tabres(ji,jj,jk,1:jpts)
267# endif
268               ENDDO
269            ENDDO
270         ENDDO
271
272         DO jn = 1, jpts           
273            DO jk = 1, jpkm1
274               ztu(i1:i2,j1:j2,jk) = 0._wp
275               DO jj = j1,j2
276                  DO ji = i1,i2-1
277                     zabe1 = fsaht_spu(ji,jj) * umask(ji,jj,jk) * e2_e1u(ji,jj) * e3u_n(ji,jj,jk)
278                     ztu(ji,jj,jk) = zabe1 * ( tsbdiff(ji+1,jj  ,jk,jn) - tsbdiff(ji,jj,jk,jn) ) 
279                  END DO
280               END DO
281               ztv(i1:i2,j1:j2,jk) = 0._wp
282               DO ji = i1,i2
283                  DO jj = j1,j2-1
284                     zabe2 = fsaht_spv(ji,jj) * vmask(ji,jj,jk) * e1_e2v(ji,jj) * e3v_n(ji,jj,jk)
285                     ztv(ji,jj,jk) = zabe2 * ( tsbdiff(ji  ,jj+1,jk,jn) - tsbdiff(ji,jj,jk,jn) )
286                  END DO
287               END DO
288               !
289               IF( ln_zps ) THEN      ! set gradient at partial step level
290                  DO jj = j1,j2
291                     DO ji = i1,i2
292                        ! last level
293                        iku = mbku(ji,jj)
294                        ikv = mbkv(ji,jj)
295                        IF( iku == jk )   ztu(ji,jj,jk) = 0._wp
296                        IF( ikv == jk )   ztv(ji,jj,jk) = 0._wp
297                     END DO
298                  END DO
299               ENDIF
300            END DO
301            !
302            DO jk = 1, jpkm1
303               DO jj = j1+1,j2-1
304                  DO ji = i1+1,i2-1
305                     IF (.NOT. tabspongedone_tsn(ji,jj)) THEN
306                        zbtr = r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk)
307                        ! horizontal diffusive trends
308                        ztsa = zbtr * (  ztu(ji,jj,jk) - ztu(ji-1,jj,jk) + ztv(ji,jj,jk) - ztv(ji,jj-1,jk)  )
309                        ! add it to the general tracer trends
310                        tsa(ji,jj,jk,jn) = tsa(ji,jj,jk,jn) + ztsa
311                     ENDIF
312                  END DO
313               END DO
314            END DO
315            !
316         END DO
317         !
318         tabspongedone_tsn(i1+1:i2-1,j1+1:j2-1) = .TRUE.
319         !
320      ENDIF
321      !
322   END SUBROUTINE interptsn_sponge
323
324   SUBROUTINE interpun_sponge(tabres,i1,i2,j1,j2,k1,k2,m1,m2, before)
325      !!---------------------------------------------
326      !!   *** ROUTINE interpun_sponge ***
327      !!---------------------------------------------   
328      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,m1,m2
329      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) :: tabres
330      LOGICAL, INTENT(in) :: before
331
332      INTEGER :: ji,jj,jk,jmax
333
334      ! sponge parameters
335      REAL(wp) :: ze2u, ze1v, zua, zva, zbtr, h_diff
336      REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: ubdiff
337      REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: rotdiff, hdivdiff
338      ! vertical interpolation:
339      REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: tabres_child
340      REAL(wp), DIMENSION(k1:k2) :: tabin, h_in
341      REAL(wp), DIMENSION(1:jpk) :: h_out
342      INTEGER ::N_in,N_out
343      !!---------------------------------------------   
344      !
345      IF( before ) THEN
346         DO jk=1,jpkm1
347            DO jj=j1,j2
348               DO ji=i1,i2
349                  tabres(ji,jj,jk,m1) = ub(ji,jj,jk)
350# if defined key_vertical
351                  tabres(ji,jj,jk,m2) = e3u_n(ji,jj,jk)*umask(ji,jj,jk)
352# endif
353               END DO
354            END DO
355         END DO
356
357      ELSE
358
359# if defined key_vertical
360         tabres_child(:,:,:) = 0._wp
361         DO jj=j1,j2
362            DO ji=i1,i2
363               N_in = 0
364               DO jk=k1,k2
365                  IF (tabres(ji,jj,jk,m2) == 0) EXIT
366                  N_in = N_in + 1
367                  tabin(jk) = tabres(ji,jj,jk,m1)
368                  h_in(N_in) = tabres(ji,jj,jk,m2)
369              ENDDO
370              !
371              IF (N_in == 0) THEN
372                 tabres_child(ji,jj,:) = 0.
373                 CYCLE
374              ENDIF
375         
376              N_out = 0
377              DO jk=1,jpk
378                 if (umask(ji,jj,jk) == 0) EXIT
379                 N_out = N_out + 1
380                 h_out(N_out) = e3u_n(ji,jj,jk)
381              ENDDO
382         
383              IF (N_out == 0) THEN
384                 tabres_child(ji,jj,:) = 0.
385                 CYCLE
386              ENDIF
387         
388              IF (N_in * N_out > 0) THEN
389                 h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in))
390                 if (h_diff < -1.e4) then
391                    print *,'CHECK YOUR BATHY ...', h_diff, sum(h_out(1:N_out)), sum(h_in(1:N_in))
392                 endif
393              ENDIF
394              call reconstructandremap(tabin(1:N_in),h_in(1:N_in),tabres_child(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out)
395         
396            ENDDO
397         ENDDO
398
399         ubdiff(i1:i2,j1:j2,:) = (ub(i1:i2,j1:j2,:) - tabres_child(i1:i2,j1:j2,:))*umask(i1:i2,j1:j2,:)
400#else
401         ubdiff(i1:i2,j1:j2,:) = (ub(i1:i2,j1:j2,:) - tabres(i1:i2,j1:j2,:,1))*umask(i1:i2,j1:j2,:)
402#endif
403         !
404         DO jk = 1, jpkm1                                 ! Horizontal slab
405            !                                             ! ===============
406
407            !                                             ! --------
408            ! Horizontal divergence                       !   div
409            !                                             ! --------
410            DO jj = j1,j2
411               DO ji = i1+1,i2   ! vector opt.
412                  zbtr = r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) * fsahm_spt(ji,jj)
413                  hdivdiff(ji,jj,jk) = (  e2u(ji  ,jj)*e3u_n(ji  ,jj,jk) * ubdiff(ji  ,jj,jk) &
414                                     &   -e2u(ji-1,jj)*e3u_n(ji-1,jj,jk) * ubdiff(ji-1,jj,jk) ) * zbtr
415               END DO
416            END DO
417
418            DO jj = j1,j2-1
419               DO ji = i1,i2   ! vector opt.
420                  zbtr = r1_e1e2f(ji,jj) * e3f_n(ji,jj,jk) * fsahm_spf(ji,jj)
421                  rotdiff(ji,jj,jk) = ( -e1u(ji,jj+1) * ubdiff(ji,jj+1,jk)   &
422                                    &   +e1u(ji,jj  ) * ubdiff(ji,jj  ,jk) ) * fmask(ji,jj,jk) * zbtr 
423               END DO
424            END DO
425         END DO
426         !
427         DO jj = j1+1, j2-1
428            DO ji = i1+1, i2-1   ! vector opt.
429
430               IF (.NOT. tabspongedone_u(ji,jj)) THEN
431                  DO jk = 1, jpkm1                                 ! Horizontal slab
432                     ze2u = rotdiff (ji,jj,jk)
433                     ze1v = hdivdiff(ji,jj,jk)
434                     ! horizontal diffusive trends
435                     zua = - ( ze2u - rotdiff (ji,jj-1,jk) ) / ( e2u(ji,jj) * e3u_n(ji,jj,jk) )   &
436                           + ( hdivdiff(ji+1,jj,jk) - ze1v ) * r1_e1u(ji,jj)
437
438                     ! add it to the general momentum trends
439                     ua(ji,jj,jk) = ua(ji,jj,jk) + zua
440
441                  END DO
442               ENDIF
443
444            END DO
445         END DO
446
447         tabspongedone_u(i1+1:i2-1,j1+1:j2-1) = .TRUE.
448
449         jmax = j2-1
450         IF ((nbondj == 1).OR.(nbondj == 2)) jmax = MIN(jmax,nlcj-nbghostcells-2)   ! North
451
452         DO jj = j1+1, jmax
453            DO ji = i1+1, i2   ! vector opt.
454
455               IF (.NOT. tabspongedone_v(ji,jj)) THEN
456                  DO jk = 1, jpkm1                                 ! Horizontal slab
457                     ze2u = rotdiff (ji,jj,jk)
458                     ze1v = hdivdiff(ji,jj,jk)
459
460                     ! horizontal diffusive trends
461                     zva = + ( ze2u - rotdiff (ji-1,jj,jk) ) / ( e1v(ji,jj) * e3v_n(ji,jj,jk) )   &
462                           + ( hdivdiff(ji,jj+1,jk) - ze1v ) * r1_e2v(ji,jj)
463
464                     ! add it to the general momentum trends
465                     va(ji,jj,jk) = va(ji,jj,jk) + zva
466                  END DO
467               ENDIF
468               !
469            END DO
470         END DO
471         !
472         tabspongedone_v(i1+1:i2,j1+1:jmax) = .TRUE.
473         !
474      ENDIF
475      !
476   END SUBROUTINE interpun_sponge
477
478   SUBROUTINE interpvn_sponge(tabres,i1,i2,j1,j2,k1,k2,m1,m2, before,nb,ndir)
479      !!---------------------------------------------
480      !!   *** ROUTINE interpvn_sponge ***
481      !!---------------------------------------------
482      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,m1,m2
483      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) :: tabres
484      LOGICAL, INTENT(in) :: before
485      INTEGER, INTENT(in) :: nb , ndir
486      !
487      INTEGER  ::   ji, jj, jk, imax
488      REAL(wp) ::   ze2u, ze1v, zua, zva, zbtr, h_diff
489      REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: vbdiff
490      REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: rotdiff, hdivdiff
491      ! vertical interpolation:
492      REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: tabres_child
493      REAL(wp), DIMENSION(k1:k2) :: tabin, h_in
494      REAL(wp), DIMENSION(1:jpk) :: h_out
495      INTEGER :: N_in, N_out
496      !!---------------------------------------------
497     
498      IF( before ) THEN
499         DO jk=1,jpkm1
500            DO jj=j1,j2
501               DO ji=i1,i2
502                  tabres(ji,jj,jk,m1) = vb(ji,jj,jk)
503# if defined key_vertical
504                  tabres(ji,jj,jk,m2) = vmask(ji,jj,jk) * e3v_n(ji,jj,jk)
505# endif
506               END DO
507            END DO
508         END DO
509      ELSE
510
511# if defined key_vertical
512         tabres_child(:,:,:) = 0._wp
513         DO jj=j1,j2
514            DO ji=i1,i2
515               N_in = 0
516               DO jk=k1,k2
517                  IF (tabres(ji,jj,jk,m2) == 0) EXIT
518                  N_in = N_in + 1
519                  tabin(jk) = tabres(ji,jj,jk,m1)
520                  h_in(N_in) = tabres(ji,jj,jk,m2)
521              ENDDO
522         
523              IF (N_in == 0) THEN
524                 tabres_child(ji,jj,:) = 0.
525                 CYCLE
526              ENDIF
527         
528              N_out = 0
529              DO jk=1,jpk
530                 if (vmask(ji,jj,jk) == 0) EXIT
531                 N_out = N_out + 1
532                 h_out(N_out) = e3v_n(ji,jj,jk)
533              ENDDO
534         
535              IF (N_in * N_out > 0) THEN
536                 h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in))
537                 if (h_diff < -1.e4) then
538                    print *,'CHECK YOUR BATHY ...', h_diff, sum(h_out(1:N_out)), sum(h_in(1:N_in))
539                 endif
540              ENDIF
541              call reconstructandremap(tabin(1:N_in),h_in(1:N_in),tabres_child(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out)
542            ENDDO
543         ENDDO
544
545         vbdiff(i1:i2,j1:j2,:) = (vb(i1:i2,j1:j2,:) - tabres_child(i1:i2,j1:j2,:))*vmask(i1:i2,j1:j2,:) 
546# else
547         vbdiff(i1:i2,j1:j2,:) = (vb(i1:i2,j1:j2,:) - tabres(i1:i2,j1:j2,:,1))*vmask(i1:i2,j1:j2,:)
548# endif
549         !
550         DO jk = 1, jpkm1                                 ! Horizontal slab
551            !                                             ! ===============
552
553            !                                             ! --------
554            ! Horizontal divergence                       !   div
555            !                                             ! --------
556            DO jj = j1+1,j2
557               DO ji = i1,i2   ! vector opt.
558                  zbtr = r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) * fsahm_spt(ji,jj)
559                  hdivdiff(ji,jj,jk) = ( e1v(ji,jj  ) * e3v_n(ji,jj  ,jk) * vbdiff(ji,jj  ,jk)  &
560                                     &  -e1v(ji,jj-1) * e3v_n(ji,jj-1,jk) * vbdiff(ji,jj-1,jk)  ) * zbtr
561               END DO
562            END DO
563            DO jj = j1,j2
564               DO ji = i1,i2-1   ! vector opt.
565                  zbtr = r1_e1e2f(ji,jj) * e3f_n(ji,jj,jk) * fsahm_spf(ji,jj)
566                  rotdiff(ji,jj,jk) = ( e2v(ji+1,jj) * vbdiff(ji+1,jj,jk) & 
567                                    &  -e2v(ji  ,jj) * vbdiff(ji  ,jj,jk)  ) * fmask(ji,jj,jk) * zbtr
568               END DO
569            END DO
570         END DO
571
572         !                                                ! ===============
573         !                                               
574
575         imax = i2 - 1
576         IF ((nbondi == 1).OR.(nbondi == 2))   imax = MIN(imax,nlci-nbghostcells-2)   ! East
577
578         DO jj = j1+1, j2
579            DO ji = i1+1, imax   ! vector opt.
580               IF( .NOT. tabspongedone_u(ji,jj) ) THEN
581                  DO jk = 1, jpkm1
582                     ua(ji,jj,jk) = ua(ji,jj,jk)                                                               &
583                        & - ( rotdiff (ji  ,jj,jk) - rotdiff (ji,jj-1,jk)) / ( e2u(ji,jj) * e3u_n(ji,jj,jk) )  &
584                        & + ( hdivdiff(ji+1,jj,jk) - hdivdiff(ji,jj  ,jk)) * r1_e1u(ji,jj)
585                  END DO
586               ENDIF
587            END DO
588         END DO
589         !
590         tabspongedone_u(i1+1:imax,j1+1:j2) = .TRUE.
591         !
592         DO jj = j1+1, j2-1
593            DO ji = i1+1, i2-1   ! vector opt.
594               IF( .NOT. tabspongedone_v(ji,jj) ) THEN
595                  DO jk = 1, jpkm1
596                     va(ji,jj,jk) = va(ji,jj,jk)                                                                  &
597                        &  + ( rotdiff (ji,jj  ,jk) - rotdiff (ji-1,jj,jk) ) / ( e1v(ji,jj) * e3v_n(ji,jj,jk) )   &
598                        &  + ( hdivdiff(ji,jj+1,jk) - hdivdiff(ji  ,jj,jk) ) * r1_e2v(ji,jj)
599                  END DO
600               ENDIF
601            END DO
602         END DO
603         tabspongedone_v(i1+1:i2-1,j1+1:j2-1) = .TRUE.
604      ENDIF
605      !
606   END SUBROUTINE interpvn_sponge
607
608#else
609   !!----------------------------------------------------------------------
610   !!   Empty module                                          no AGRIF zoom
611   !!----------------------------------------------------------------------
612CONTAINS
613   SUBROUTINE agrif_oce_sponge_empty
614      WRITE(*,*)  'agrif_oce_sponge : You should not have seen this print! error?'
615   END SUBROUTINE agrif_oce_sponge_empty
616#endif
617
618   !!======================================================================
619END MODULE agrif_oce_sponge
Note: See TracBrowser for help on using the repository browser.