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/branches/2020/dev_r13333_TOP-05_Ethe_Agrif/src/NST – NEMO

source: NEMO/branches/2020/dev_r13333_TOP-05_Ethe_Agrif/src/NST/agrif_top_sponge.F90 @ 13373

Last change on this file since 13373 was 13373, checked in by cetlod, 4 years ago

TOP-05_Ethe_Agrif : 1st step of changes to successfully compile, see ticket #2508
  • Property svn:keywords set to Id
File size: 7.6 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   !!----------------------------------------------------------------------
33   !! NEMO/NST 4.0 , NEMO Consortium (2018)
34   !! $Id$
35   !! Software governed by the CeCILL license (see ./LICENSE)
36   !!----------------------------------------------------------------------
37CONTAINS
38
39   SUBROUTINE Agrif_Sponge_trc
40      !!----------------------------------------------------------------------
41      !!                   *** ROUTINE Agrif_Sponge_Trc ***
42      !!----------------------------------------------------------------------
43      REAL(wp) ::   zcoef   ! local scalar
44      !!----------------------------------------------------------------------
45      !
46#if defined SPONGE_TOP
47!! Assume persistence
48      zcoef = REAL(Agrif_rhot()-1,wp)/REAL(Agrif_rhot())
49      CALL Agrif_sponge
50      Agrif_SpecialValue    = 0._wp
51      Agrif_UseSpecialValue = .TRUE.
52      tabspongedone_trn     = .FALSE.
53      CALL Agrif_Bc_Variable( trn_sponge_id, calledweight=zcoef, procname=interptrn_sponge )
54      Agrif_UseSpecialValue = .FALSE.
55#endif
56      !
57   END SUBROUTINE Agrif_Sponge_Trc
58
59
60   SUBROUTINE interptrn_sponge( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before )
61      !!----------------------------------------------------------------------
62      !!                   *** ROUTINE interptrn_sponge ***
63      !!----------------------------------------------------------------------
64      INTEGER                                     , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2, n1, n2
65      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) ::   tabres
66      LOGICAL                                     , INTENT(in   ) ::   before
67      !
68      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices
69      INTEGER  ::   iku, ikv
70      REAL(wp) ::   ztra, zabe1, zabe2, zbtr
71      REAL(wp), DIMENSION(i1:i2,j1:j2,jpk)  ::   ztu, ztv
72      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2) ::   trbdiff
73      ! vertical interpolation:
74      REAL(wp), DIMENSION(i1:i2,j1:j2,jpk,n1:n2) ::tabres_child
75      REAL(wp), DIMENSION(k1:k2,1:jptra) :: tabin
76      REAL(wp), DIMENSION(k1:k2) :: h_in
77      REAL(wp), DIMENSION(1:jpk) :: h_out
78      INTEGER :: N_in, N_out
79      !!----------------------------------------------------------------------
80      !
81      IF( before ) THEN
82         DO jn = 1, jptra
83            DO jk=k1,k2
84               DO jj=j1,j2
85                  DO ji=i1,i2
86                     tabres(ji,jj,jk,jn) = tr(ji,jj,jk,jn,Kbb_a)
87                  END DO
88               END DO
89            END DO
90         END DO
91
92# if defined key_vertical
93         DO jk=k1,k2
94            DO jj=j1,j2
95               DO ji=i1,i2
96                  tabres(ji,jj,jk,jpts+1) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kbb_a)
97               END DO
98            END DO
99         END DO
100# endif
101      ELSE     
102# if defined key_vertical
103         tabres_child(:,:,:,:) = 0.
104         DO jj=j1,j2
105            DO ji=i1,i2
106               N_in = 0
107               DO jk=k1,k2 !k2 = jpk of parent grid
108                  IF (tabres(ji,jj,jk,n2) == 0) EXIT
109                  N_in = N_in + 1
110                  tabin(jk,:) = tabres(ji,jj,jk,n1:n2-1)
111                  h_in(N_in) = tabres(ji,jj,jk,n2)
112               END DO
113               N_out = 0
114               DO jk=1,jpk ! jpk of child grid
115                  IF (tmask(ji,jj,jk) == 0) EXIT
116                  N_out = N_out + 1
117                  h_out(jk) = e3t(ji,jj,jk,Kbb_a) !Child grid scale factors. Could multiply by e1e2t here instead of division above
118               ENDDO
119               IF (N_in > 0) THEN
120                  CALL reconstructandremap(tabin(1:N_in,1:jptra),h_in,tabres_child(ji,jj,1:N_out,1:jptra),h_out,N_in,N_out,jptra)
121               ENDIF
122            ENDDO
123         ENDDO
124# endif
125
126         DO jj=j1,j2
127            DO ji=i1,i2
128               DO jk=1,jpkm1
129# if defined key_vertical
130                  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)
131# else
132                  trbdiff(ji,jj,jk,1:jptra) = ( tr(ji,jj,jk,1:jptra,Kbb_a) - tabres(ji,jj,jk,1:jptra)) * tmask(ji,jj,jk)
133# endif
134               ENDDO
135            ENDDO
136         ENDDO
137
138         DO jn = 1, jptra
139            DO jk = 1, jpkm1
140               ztu(i1:i2,j1:j2,jk) = 0._wp
141               DO jj = j1,j2
142                  DO ji = i1,i2-1
143                     zabe1 = rn_sponge_tra * r1_Dt * fspu(ji,jj) * umask(ji,jj,jk) * e2_e1u(ji,jj) * e3u(ji,jj,jk,Kmm_a)
144                     ztu(ji,jj,jk) = zabe1 * ( trbdiff(ji+1,jj,jk,jn) - trbdiff(ji,jj,jk,jn) )
145                  END DO
146               END DO
147               ztv(i1:i2,j1:j2,jk) = 0._wp
148               DO ji = i1,i2
149                  DO jj = j1,j2-1
150                     zabe2 = rn_sponge_tra * r1_Dt * fspv(ji,jj) * vmask(ji,jj,jk) * e1_e2v(ji,jj) * e3v(ji,jj,jk,Kmm_a)
151                     ztv(ji,jj,jk) = zabe2 * ( trbdiff(ji,jj+1,jk,jn) - trbdiff(ji,jj,jk,jn) )
152                  END DO
153               END DO
154               !
155               IF( ln_zps ) THEN      ! set gradient at partial step level
156                  DO jj = j1,j2
157                     DO ji = i1,i2
158                        ! last level
159                        iku = mbku(ji,jj)
160                        ikv = mbkv(ji,jj)
161                        IF( iku == jk )   ztu(ji,jj,jk) = 0._wp
162                        IF( ikv == jk )   ztv(ji,jj,jk) = 0._wp
163                     END DO
164                  END DO
165               ENDIF
166            END DO
167            !
168            DO jk = 1, jpkm1
169               DO jj = j1+1,j2-1
170                  DO ji = i1+1,i2-1
171                     IF( .NOT. tabspongedone_trn(ji,jj) ) THEN
172                        zbtr = r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm_a)
173                                                ! horizontal diffusive trends
174                        ztra = zbtr * (  ztu(ji,jj,jk) - ztu(ji-1,jj,jk) + ztv(ji,jj,jk) - ztv(ji,jj-1,jk)  ) &
175                             &  - rn_trelax_tra * r1_Dt * fspt(ji,jj) * trbdiff(ji,jj,jk,jn)
176                        ! add it to the general tracer trends
177                        tr(ji,jj,jk,jn,Krhs_a) = tr(ji,jj,jk,jn,Krhs_a) + ztra
178                     ENDIF
179                  END DO
180               END DO
181            END DO
182         END DO
183         !
184         tabspongedone_trn(i1+1:i2-1,j1+1:j2-1) = .TRUE.
185      ENDIF
186      !                 
187   END SUBROUTINE interptrn_sponge
188
189#else
190   !!----------------------------------------------------------------------
191   !!   Empty module                                           no TOP AGRIF
192   !!----------------------------------------------------------------------
193CONTAINS
194   SUBROUTINE agrif_top_sponge_empty
195      WRITE(*,*)  'agrif_top_sponge : You should not have seen this print! error?'
196   END SUBROUTINE agrif_top_sponge_empty
197#endif
198
199   !!======================================================================
200END MODULE agrif_top_sponge
Note: See TracBrowser for help on using the repository browser.