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_top_sponge.F90 in NEMO/trunk/src/NST – NEMO

source: NEMO/trunk/src/NST/agrif_top_sponge.F90 @ 14162

Last change on this file since 14162 was 14148, checked in by jchanut, 3 years ago

#2385, qco and agrif TOP (missing substitutes)
  • Property svn:keywords set to Id
File size: 11.3 KB
Line 
1#define SPONGE_TOP
2
3MODULE agrif_top_sponge
4   !!======================================================================
5   !!                ***  MODULE agrif_top_sponge  ***
6   !! AGRIF :   sponge layer pakage for passive tracers (TOP)
7   !!======================================================================
8   !! History :  2.0  ! 2006-08  (R. Benshila, L. Debreu)  Original code
9   !!----------------------------------------------------------------------
10#if defined key_agrif && defined key_top
11   !!----------------------------------------------------------------------
12   !!   Agrif_Sponge_trc :
13   !!   interptrn_sponge : 
14   !!----------------------------------------------------------------------
15   USE par_oce
16   USE par_trc
17   USE oce
18   USE trc
19   USE dom_oce
20   USE agrif_oce
21   USE agrif_oce_sponge
22   USE vremap
23   !
24   USE in_out_manager
25   USE lib_mpp
26
27   IMPLICIT NONE
28   PRIVATE
29
30   PUBLIC Agrif_Sponge_trc, interptrn_sponge
31
32   !! * Substitutions
33#  include "domzgr_substitute.h90"
34   !!----------------------------------------------------------------------
35   !! NEMO/NST 4.0 , NEMO Consortium (2018)
36   !! $Id$
37   !! Software governed by the CeCILL license (see ./LICENSE)
38   !!----------------------------------------------------------------------
39CONTAINS
40
41   SUBROUTINE Agrif_Sponge_trc
42      !!----------------------------------------------------------------------
43      !!                   *** ROUTINE Agrif_Sponge_Trc ***
44      !!----------------------------------------------------------------------
45      REAL(wp) ::   zcoef   ! local scalar
46      !!----------------------------------------------------------------------
47      !
48#if defined SPONGE_TOP
49      !! Assume persistence:
50      zcoef = REAL(Agrif_rhot()-1,wp)/REAL(Agrif_rhot())
51
52      Agrif_SpecialValue    = 0._wp
53      Agrif_UseSpecialValue = .TRUE.
54      l_vremap              = ln_vert_remap
55      tabspongedone_trn     = .FALSE.
56      !
57      CALL Agrif_Bc_Variable( trn_sponge_id, calledweight=zcoef, procname=interptrn_sponge )
58      !
59      Agrif_UseSpecialValue = .FALSE.
60      l_vremap              = .FALSE.
61#endif
62      !
63   END SUBROUTINE Agrif_Sponge_Trc
64
65
66   SUBROUTINE interptrn_sponge( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before) 
67      !!----------------------------------------------------------------------
68      !!                 *** ROUTINE interptrn_sponge ***
69      !!----------------------------------------------------------------------
70      INTEGER                                     , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2, n1, n2
71      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) ::   tabres
72      LOGICAL                                     , INTENT(in   ) ::   before
73      !
74      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices
75      INTEGER  ::   iku, ikv
76      REAL(wp) :: ztra, zabe1, zabe2, zbtr, zhtot
77      REAL(wp), DIMENSION(i1-1:i2,j1-1:j2,jpk) :: ztu, ztv
78      REAL(wp), DIMENSION(i1:i2,j1:j2,jpk,n1:n2) ::trbdiff
79      ! vertical interpolation:
80      REAL(wp), DIMENSION(i1:i2,j1:j2,jpk,n1:n2) ::tabres_child
81      REAL(wp), DIMENSION(k1:k2,n1:n2-1) :: tabin, tabin_i
82      REAL(wp), DIMENSION(k1:k2) :: z_in, z_in_i, h_in_i
83      REAL(wp), DIMENSION(1:jpk) :: h_out, z_out
84      INTEGER :: N_in, N_out
85      !!----------------------------------------------------------------------
86      !
87      IF( before ) THEN
88         DO jn = 1, jptra
89            DO jk=k1,k2
90               DO jj=j1,j2
91                  DO ji=i1,i2
92                     tabres(ji,jj,jk,jn) = tr(ji,jj,jk,jn,Kbb_a)
93                  END DO
94               END DO
95            END DO
96         END DO
97
98         IF ( l_vremap.OR.ln_zps ) THEN
99
100            ! Fill cell depths (i.e. gdept) to be interpolated
101            ! Warning: these are masked, hence extrapolated prior interpolation.
102            DO jj=j1,j2
103               DO ji=i1,i2
104                  tabres(ji,jj,k1,jptra+1) = 0.5_wp * tmask(ji,jj,k1) * e3t(ji,jj,k1,Kbb_a)
105                  DO jk=k1+1,k2
106                     tabres(ji,jj,jk,jptra+1) = tmask(ji,jj,jk) * &
107                        & ( tabres(ji,jj,jk-1,jptra+1) + 0.5_wp * (e3t(ji,jj,jk-1,Kbb_a)+e3t(ji,jj,jk,Kbb_a)) )
108                  END DO
109               END DO
110            END DO
111
112            ! Save ssh at last level:
113            IF ( .NOT.ln_linssh ) THEN
114               tabres(i1:i2,j1:j2,k2,jptra+1) = ssh(i1:i2,j1:j2,Kbb_a)*tmask(i1:i2,j1:j2,1) 
115            END IF 
116   
117         END IF
118
119      ELSE 
120         !
121         IF ( l_vremap ) THEN
122
123            IF (ln_linssh) tabres(i1:i2,j1:j2,k2,n2) = 0._wp
124
125            DO jj=j1,j2
126               DO ji=i1,i2
127
128                  tabres_child(ji,jj,:,:) = 0._wp 
129                  ! Build vertical grids:
130                  N_in = mbkt_parent(ji,jj)
131                  ! Input grid (account for partial cells if any):
132                  DO jk=1,N_in
133                     z_in(jk) = tabres(ji,jj,jk,n2) - tabres(ji,jj,k2,n2)
134                     tabin(jk,1:jptra) = tabres(ji,jj,jk,1:jptra)
135                  END DO
136                 
137                  ! Intermediate grid:
138                  DO jk = 1, N_in
139                     h_in_i(jk) = e3t0_parent(ji,jj,jk) * & 
140                       &       (1._wp + tabres(ji,jj,k2,n2)/(ht0_parent(ji,jj)*ssmask(ji,jj) + 1._wp - ssmask(ji,jj)))
141                  END DO
142                  z_in_i(1) = 0.5_wp * h_in_i(1)
143                  DO jk=2,N_in
144                     z_in_i(jk) = z_in_i(jk-1) + 0.5_wp * ( h_in_i(jk) + h_in_i(jk-1) )
145                  END DO
146                  z_in_i(1:N_in) = z_in_i(1:N_in)  - tabres(ji,jj,k2,n2)
147
148                  ! Output (Child) grid:
149                  N_out = mbkt(ji,jj)
150                  DO jk=1,N_out
151                     h_out(jk) = e3t(ji,jj,jk,Kbb_a)
152                  END DO
153                  z_out(1) = 0.5_wp * h_out(1)
154                  DO jk=2,N_out
155                     z_out(jk) = z_out(jk-1) + 0.5_wp * ( h_out(jk)+h_out(jk-1) )
156                  END DO
157                  IF (.NOT.ln_linssh) z_out(1:N_out) = z_out(1:N_out)  - ssh(ji,jj,Kbb_a)
158
159                  ! Account for small differences in the free-surface
160                  IF ( sum(h_out(1:N_out)) > sum(h_in_i(1:N_in) )) THEN
161                     h_out(1) = h_out(1)  - ( sum(h_out(1:N_out))-sum(h_in_i(1:N_in)) )
162                  ELSE
163                     h_in_i(1)= h_in_i(1) - ( sum(h_in_i(1:N_in))-sum(h_out(1:N_out)) )
164                  END IF
165                  IF (N_in*N_out > 0) THEN
166                     CALL remap_linear(tabin(1:N_in,1:jptra),z_in(1:N_in),tabin_i(1:N_in,1:jptra),z_in_i(1:N_in),N_in,N_in,jptra)
167                     CALL reconstructandremap(tabin_i(1:N_in,1:jptra),h_in_i(1:N_in),tabres_child(ji,jj,1:N_out,1:jptra),h_out(1:N_out),N_in,N_out,jptra)
168!                     CALL remap_linear(tabin(1:N_in,1:jptra),z_in(1:N_in),tabres_child(ji,jj,1:N_out,1:jptra),z_out(1:N_in),N_in,N_out,jptra) 
169                  ENDIF
170               END DO
171            END DO
172
173            DO jj=j1,j2
174               DO ji=i1,i2
175                  DO jk=1,jpkm1
176                     trbdiff(ji,jj,jk,1:jptra) = (tr(ji,jj,jk,1:jptra,Kbb_a) - tabres_child(ji,jj,jk,1:jptra)) * tmask(ji,jj,jk)
177                  END DO
178               END DO
179            END DO
180
181         ELSE
182
183            IF ( Agrif_Parent(ln_zps) ) THEN ! Account for partial cells
184
185               DO jj=j1,j2
186                  DO ji=i1,i2
187                     !
188                     N_in  = mbkt(ji,jj) 
189                     N_out = mbkt(ji,jj) 
190                     z_in(1) = tabres(ji,jj,1,n2)
191                     tabin(1,1:jptra) = tabres(ji,jj,1,1:jptra)
192                     DO jk=2, N_in
193                        z_in(jk) = tabres(ji,jj,jk,n2)
194                        tabin(jk,1:jptra) = tabres(ji,jj,jk,1:jptra)
195                     END DO
196                     IF (.NOT.ln_linssh) z_in(1:N_in) = z_in(1:N_in) - tabres(ji,jj,k2,n2)
197
198                     z_out(1) = 0.5_wp * e3t(ji,jj,1,Kbb_a)
199                     DO jk=2, N_out
200                        z_out(jk) = z_out(jk-1) + 0.5_wp * (e3t(ji,jj,jk-1,Kbb_a) + e3t(ji,jj,jk,Kbb_a)) 
201                     END DO
202                     IF (.NOT.ln_linssh) z_out(1:N_out) = z_out(1:N_out) - ssh(ji,jj,Kbb_a)
203
204                     CALL remap_linear(tabin(1:N_in,1:jptra), z_in(1:N_in), tabres(ji,jj,1:N_out,1:jptra), &
205                                         &   z_out(1:N_out), N_in, N_out, jptra)
206                  END DO
207               END DO
208            ENDIF
209
210            DO jj=j1,j2
211               DO ji=i1,i2
212                  DO jk=1,jpkm1
213                     trbdiff(ji,jj,jk,1:jptra) = (tr(ji,jj,jk,1:jptra,Kbb_a) - tabres(ji,jj,jk,1:jptra))*tmask(ji,jj,jk)
214                  END DO
215               END DO
216            END DO
217
218         END IF
219
220         DO jn = 1, jptra           
221            DO jk = 1, jpkm1
222               ztu(i1-1:i2,j1-1:j2,jk) = 0._wp
223               DO jj = j1,j2
224                  DO ji = i1,i2-1
225                     zabe1 = rn_sponge_tra * r1_Dt * umask(ji,jj,jk) * e1e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a)
226                     ztu(ji,jj,jk) = zabe1 * fspu(ji,jj) * ( trbdiff(ji+1,jj  ,jk,jn) - trbdiff(ji,jj,jk,jn) ) 
227                  END DO
228               END DO
229               ztv(i1-1:i2,j1-1:j2,jk) = 0._wp
230               DO ji = i1,i2
231                  DO jj = j1,j2-1
232                     zabe2 = rn_sponge_tra * r1_Dt * vmask(ji,jj,jk) * e1e2v(ji,jj) * e3v(ji,jj,jk,Kmm_a)
233                     ztv(ji,jj,jk) = zabe2 * fspv(ji,jj) * ( trbdiff(ji  ,jj+1,jk,jn) - trbdiff(ji,jj,jk,jn) )
234                  END DO
235               END DO
236               !
237               IF( ln_zps ) THEN      ! set gradient at partial step level
238                  DO jj = j1,j2
239                     DO ji = i1,i2
240                        ! last level
241                        iku = mbku(ji,jj)
242                        ikv = mbkv(ji,jj)
243                        IF( iku == jk )   ztu(ji,jj,jk) = 0._wp
244                        IF( ikv == jk )   ztv(ji,jj,jk) = 0._wp
245                     END DO
246                  END DO
247               ENDIF
248            END DO
249            !
250! JC: there is something wrong with the Laplacian in corners
251            DO jk = 1, jpkm1
252               DO jj = j1,j2
253                  DO ji = i1,i2
254                     IF (.NOT. tabspongedone_trn(ji,jj)) THEN
255                        zbtr = r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm_a)
256                        ! horizontal diffusive trends
257                        ztra = zbtr * ( ztu(ji,jj,jk) - ztu(ji-1,jj,jk)   & 
258                          &           + ztv(ji,jj,jk) - ztv(ji,jj-1,jk) ) &
259                          &   - rn_trelax_tra * r1_Dt * fspt(ji,jj) * trbdiff(ji,jj,jk,jn)
260                        ! add it to the general tracer trends
261                        tr(ji,jj,jk,jn,Krhs_a) = tr(ji,jj,jk,jn,Krhs_a) + ztra
262                     ENDIF
263                  END DO
264               END DO
265
266            END DO
267            !
268         END DO
269         !
270         tabspongedone_trn(i1:i2,j1:j2) = .TRUE.
271         !
272      ENDIF
273      !
274   END SUBROUTINE interptrn_sponge
275
276#else
277   !!----------------------------------------------------------------------
278   !!   Empty module                                           no TOP AGRIF
279   !!----------------------------------------------------------------------
280CONTAINS
281   SUBROUTINE agrif_top_sponge_empty
282      WRITE(*,*)  'agrif_top_sponge : You should not have seen this print! error?'
283   END SUBROUTINE agrif_top_sponge_empty
284#endif
285
286   !!======================================================================
287END MODULE agrif_top_sponge
Note: See TracBrowser for help on using the repository browser.