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 branches/2017/dev_METO_MERCATOR_2017_agrif/NEMOGCM/NEMO/NST_SRC – NEMO

source: branches/2017/dev_METO_MERCATOR_2017_agrif/NEMOGCM/NEMO/NST_SRC/agrif_top_sponge.F90 @ 9006

Last change on this file since 9006 was 9001, checked in by timgraham, 6 years ago

Added vertical refinement to top sponge
  • Property svn:keywords set to Id
File size: 6.7 KB
Line 
1#define SPONGE_TOP
2
3MODULE agrif_top_sponge
4   !!======================================================================
5   !!                ***  MODULE agrif_top_sponge  ***
6   !! AGRIF :   define in memory AGRIF variables for sea-ice
7   !!======================================================================
8   !! History :  2.0  ! 2006-08  (R. Benshila, L. Debreu)  Original code
9   !!----------------------------------------------------------------------
10
11   !!----------------------------------------------------------------------
12   !!   Agrif_Sponge_trc :
13   !!   interptrn_sponge : 
14   !!----------------------------------------------------------------------
15#if defined key_agrif && defined key_top
16   USE par_oce
17   USE par_trc
18   USE oce
19   USE trc
20   USE dom_oce
21   USE agrif_oce
22   USE agrif_opa_sponge
23   !
24   USE in_out_manager
25   USE lib_mpp
26   USE wrk_nemo 
27
28   IMPLICIT NONE
29   PRIVATE
30
31   PUBLIC Agrif_Sponge_trc, interptrn_sponge
32
33   !!----------------------------------------------------------------------
34   !! NEMO/NST 3.7 , NEMO Consortium (2015)
35   !! $Id$
36   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
37   !!----------------------------------------------------------------------
38CONTAINS
39
40   SUBROUTINE Agrif_Sponge_trc
41      !!----------------------------------------------------------------------
42      !!                   *** ROUTINE Agrif_Sponge_Trc ***
43      !!----------------------------------------------------------------------
44      REAL(wp) ::   timecoeff
45      !!----------------------------------------------------------------------
46      !
47#if defined SPONGE_TOP
48!!      timecoeff = REAL( Agrif_NbStepint(), wp ) / Agrif_rhot()
49!! Assume persistence
50      timecoeff = REAL(Agrif_rhot()-1,wp)/REAL(Agrif_rhot())
51      CALL Agrif_sponge
52      Agrif_SpecialValue    = 0._wp
53      Agrif_UseSpecialValue = .TRUE.
54      tabspongedone_trn     = .FALSE.
55      CALL Agrif_Bc_Variable( trn_sponge_id, calledweight=timecoeff, procname=interptrn_sponge )
56      Agrif_UseSpecialValue = .FALSE.
57#endif
58      !
59   END SUBROUTINE Agrif_Sponge_Trc
60
61
62   SUBROUTINE interptrn_sponge( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before )
63      !!----------------------------------------------------------------------
64      !!                   *** ROUTINE interptrn_sponge ***
65      !!----------------------------------------------------------------------
66      INTEGER                                     , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2, n1, n2
67      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) ::   tabres
68      LOGICAL                                     , INTENT(in   ) ::   before
69      !
70      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices
71      REAL(wp) ::   zabe1, zabe2
72      REAL(wp), DIMENSION(i1:i2,j1:j2)             ::   ztu, ztv
73      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2) ::   trbdiff
74      ! vertical interpolation:
75      REAL(wp), DIMENSION(i1:i2,j1:j2,jpk,n1:n2) ::tabres_child
76      REAL(wp), DIMENSION(k1:k2,n1:n2-1) :: tabin
77      REAL(wp), DIMENSION(k1:k2) :: h_in
78      REAL(wp), DIMENSION(1:jpk) :: h_out
79      INTEGER :: N_in, N_out
80      REAL(wp) :: h_diff
81      !!----------------------------------------------------------------------
82      !
83      IF( before ) THEN
84         DO jn = 1, jptra
85            DO jk=k1,k2
86               DO jj=j1,j2
87                  DO ji=i1,i2
88                     tabres(ji,jj,jk,jn) = trb(ji,jj,jk,jn)
89                  END DO
90               END DO
91            END DO
92         END DO
93
94# if defined key_vertical
95         DO jk=k1,k2
96            DO jj=j1,j2
97               DO ji=i1,i2
98                  tabres(ji,jj,jk,jpts+1) = tmask(ji,jj,jk) * e3t_n(ji,jj,jk) 
99               END DO
100            END DO
101         END DO
102# endif
103      ELSE     
104# if defined key_vertical
105         tabres_child(:,:,:,:) = 0.
106         DO jj=j1,j2
107            DO ji=i1,i2
108               N_in = 0
109               DO jk=k1,k2 !k2 = jpk of parent grid
110                  IF (tabres(ji,jj,jk,n2) == 0) EXIT
111                  N_in = N_in + 1
112                  tabin(jk,:) = tabres(ji,jj,jk,n1:n2-1)
113                  h_in(N_in) = tabres(ji,jj,jk,n2)
114               END DO
115               N_out = 0
116               DO jk=1,jpk ! jpk of child grid
117                  IF (tmask(ji,jj,jk) == 0) EXIT
118                  N_out = N_out + 1
119                  h_out(jk) = e3t_n(ji,jj,jk) !Child grid scale factors. Could multiply by e1e2t here instead of division above
120               ENDDO
121               IF (N_in > 0) THEN
122                  h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in))
123                  tabres(ji,jj,k2,:) = tabres(ji,jj,k2-1,:) !what is this line for?????
124                  DO jn=1,jptra
125                     call reconstructandremap(tabin(1:N_in,jn),h_in,tabres_child(ji,jj,1:N_out,jn),h_out,N_in,N_out)
126                  ENDDO
127               ENDIF
128            ENDDO
129         ENDDO
130# endif
131
132         DO jj=j1,j2
133            DO ji=i1,i2
134               DO jk=1,jpkm1
135# if defined key_vertical
136                  trbdiff(ji,jj,jk,1:jptra) = trb(ji,jj,jk,1:jptra) - tabres_child(ji,jj,jk,1:jptra)
137# else
138                  trbdiff(ji,jj,jk,1:jptra) = trb(ji,jj,jk,1:jptra) - tabres(ji,jj,jk,1:jptra)
139# endif
140               ENDDO
141            ENDDO
142         ENDDO
143
144         DO jn = 1, jptra
145            DO jk = 1, jpkm1
146               DO jj = j1,j2-1
147                  DO ji = i1,i2-1
148                     zabe1 = fsaht_spu(ji,jj) * e2_e1u(ji,jj) * e3u_n(ji,jj,jk) * umask(ji,jj,jk)
149                     zabe2 = fsaht_spv(ji,jj) * e1_e2v(ji,jj) * e3v_n(ji,jj,jk) * vmask(ji,jj,jk)
150                     ztu(ji,jj) = zabe1 * ( trbdiff(ji+1,jj  ,jk,jn) - trbdiff(ji,jj,jk,jn) )
151                     ztv(ji,jj) = zabe2 * ( trbdiff(ji  ,jj+1,jk,jn) - trbdiff(ji,jj,jk,jn) )
152                  END DO
153               END DO
154               !
155               DO jj = j1+1,j2-1
156                  DO ji = i1+1,i2-1
157                     IF( .NOT. tabspongedone_trn(ji,jj) ) THEN
158                        tra(ji,jj,jk,jn) = tra(ji,jj,jk,jn) + (  ztu(ji,jj) - ztu(ji-1,jj  )     &
159                           &                                   + ztv(ji,jj) - ztv(ji  ,jj-1)  )  &
160                           &                                * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk)
161                     ENDIF
162                  END DO
163               END DO
164            END DO
165            !
166         END DO
167         !
168         tabspongedone_trn(i1+1:i2-1,j1+1:j2-1) = .TRUE.
169      ENDIF
170      !                 
171   END SUBROUTINE interptrn_sponge
172
173#else
174
175CONTAINS
176   SUBROUTINE agrif_top_sponge_empty
177      WRITE(*,*)  'agrif_top_sponge : You should not have seen this print! error?'
178   END SUBROUTINE agrif_top_sponge_empty
179#endif
180
181   !!======================================================================
182END MODULE agrif_top_sponge
Note: See TracBrowser for help on using the repository browser.