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/2019/dev_r11233_AGRIF-05_jchanut_vert_coord_interp/src/NST – NEMO

source: NEMO/branches/2019/dev_r11233_AGRIF-05_jchanut_vert_coord_interp/src/NST/agrif_top_sponge.F90 @ 11603

Last change on this file since 11603 was 11603, checked in by jchanut, 5 years ago

#2222, 1) correct time interpolation of barotropic velocities in corners. 2) Clean remapping module and enable remapping several variables at the same time. At this stage, vertical remapping doesn't change VORTEX results with an identical vertical grid ONLY in one way mode and a linearized free surface (within truncature errors).

  • Property svn:keywords set to Id
File size: 6.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   !
23   USE in_out_manager
24   USE lib_mpp
25
26   IMPLICIT NONE
27   PRIVATE
28
29   PUBLIC Agrif_Sponge_trc, interptrn_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_trc
39      !!----------------------------------------------------------------------
40      !!                   *** ROUTINE Agrif_Sponge_Trc ***
41      !!----------------------------------------------------------------------
42      REAL(wp) ::   zcoef   ! local scalar
43      !!----------------------------------------------------------------------
44      !
45#if defined SPONGE_TOP
46!! Assume persistence
47      zcoef = REAL(Agrif_rhot()-1,wp)/REAL(Agrif_rhot())
48      CALL Agrif_sponge
49      Agrif_SpecialValue    = 0._wp
50      Agrif_UseSpecialValue = .TRUE.
51      tabspongedone_trn     = .FALSE.
52      CALL Agrif_Bc_Variable( trn_sponge_id, calledweight=zcoef, procname=interptrn_sponge )
53      Agrif_UseSpecialValue = .FALSE.
54#endif
55      !
56   END SUBROUTINE Agrif_Sponge_Trc
57
58
59   SUBROUTINE interptrn_sponge( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before )
60      !!----------------------------------------------------------------------
61      !!                   *** ROUTINE interptrn_sponge ***
62      !!----------------------------------------------------------------------
63      INTEGER                                     , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2, n1, n2
64      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) ::   tabres
65      LOGICAL                                     , INTENT(in   ) ::   before
66      !
67      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices
68      REAL(wp) ::   zabe1, zabe2
69      REAL(wp), DIMENSION(i1:i2,j1:j2)             ::   ztu, ztv
70      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2) ::   trbdiff
71      ! vertical interpolation:
72      REAL(wp), DIMENSION(i1:i2,j1:j2,jpk,n1:n2) ::tabres_child
73      REAL(wp), DIMENSION(k1:k2,n1:n2-1) :: tabin
74      REAL(wp), DIMENSION(k1:k2) :: h_in
75      REAL(wp), DIMENSION(1:jpk) :: h_out
76      INTEGER :: N_in, N_out
77      REAL(wp) :: h_diff
78      !!----------------------------------------------------------------------
79      !
80      IF( before ) THEN
81         DO jn = 1, jptra
82            DO jk=k1,k2
83               DO jj=j1,j2
84                  DO ji=i1,i2
85                     tabres(ji,jj,jk,jn) = trb(ji,jj,jk,jn)
86                  END DO
87               END DO
88            END DO
89         END DO
90
91# if defined key_vertical
92         DO jk=k1,k2
93            DO jj=j1,j2
94               DO ji=i1,i2
95                  tabres(ji,jj,jk,jpts+1) = tmask(ji,jj,jk) * e3t_b(ji,jj,jk) 
96               END DO
97            END DO
98         END DO
99# endif
100      ELSE     
101# if defined key_vertical
102         tabres_child(:,:,:,:) = 0.
103         DO jj=j1,j2
104            DO ji=i1,i2
105               N_in = 0
106               DO jk=k1,k2 !k2 = jpk of parent grid
107                  IF (tabres(ji,jj,jk,n2) == 0) EXIT
108                  N_in = N_in + 1
109                  tabin(jk,:) = tabres(ji,jj,jk,n1:n2-1)
110                  h_in(N_in) = tabres(ji,jj,jk,n2)
111               END DO
112               N_out = 0
113               DO jk=1,jpk ! jpk of child grid
114                  IF (tmask(ji,jj,jk) == 0) EXIT
115                  N_out = N_out + 1
116                  h_out(jk) = e3t_b(ji,jj,jk) !Child grid scale factors. Could multiply by e1e2t here instead of division above
117               ENDDO
118               IF (N_in > 0) THEN
119                  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)
120               ENDIF
121            ENDDO
122         ENDDO
123# endif
124
125         DO jj=j1,j2
126            DO ji=i1,i2
127               DO jk=1,jpkm1
128# if defined key_vertical
129                  trbdiff(ji,jj,jk,1:jptra) = trb(ji,jj,jk,1:jptra) - tabres_child(ji,jj,jk,1:jptra)
130# else
131                  trbdiff(ji,jj,jk,1:jptra) = trb(ji,jj,jk,1:jptra) - tabres(ji,jj,jk,1:jptra)
132# endif
133               ENDDO
134            ENDDO
135         ENDDO
136
137         DO jn = 1, jptra
138            DO jk = 1, jpkm1
139               DO jj = j1,j2-1
140                  DO ji = i1,i2-1
141                     zabe1 = fsaht_spu(ji,jj) * e2_e1u(ji,jj) * e3u_n(ji,jj,jk) * umask(ji,jj,jk)
142                     zabe2 = fsaht_spv(ji,jj) * e1_e2v(ji,jj) * e3v_n(ji,jj,jk) * vmask(ji,jj,jk)
143                     ztu(ji,jj) = zabe1 * ( trbdiff(ji+1,jj  ,jk,jn) - trbdiff(ji,jj,jk,jn) )
144                     ztv(ji,jj) = zabe2 * ( trbdiff(ji  ,jj+1,jk,jn) - trbdiff(ji,jj,jk,jn) )
145                  END DO
146               END DO
147               !
148               DO jj = j1+1,j2-1
149                  DO ji = i1+1,i2-1
150                     IF( .NOT. tabspongedone_trn(ji,jj) ) THEN
151                        tra(ji,jj,jk,jn) = tra(ji,jj,jk,jn) + (  ztu(ji,jj) - ztu(ji-1,jj  )     &
152                           &                                   + ztv(ji,jj) - ztv(ji  ,jj-1)  )  &
153                           &                                * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk)
154                     ENDIF
155                  END DO
156               END DO
157            END DO
158            !
159         END DO
160         !
161         tabspongedone_trn(i1+1:i2-1,j1+1:j2-1) = .TRUE.
162      ENDIF
163      !                 
164   END SUBROUTINE interptrn_sponge
165
166#else
167   !!----------------------------------------------------------------------
168   !!   Empty module                                           no TOP AGRIF
169   !!----------------------------------------------------------------------
170CONTAINS
171   SUBROUTINE agrif_top_sponge_empty
172      WRITE(*,*)  'agrif_top_sponge : You should not have seen this print! error?'
173   END SUBROUTINE agrif_top_sponge_empty
174#endif
175
176   !!======================================================================
177END MODULE agrif_top_sponge
Note: See TracBrowser for help on using the repository browser.