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_boundary_connections.F90 in NEMO/branches/2019/ENHANCE-03_domcfg/src – NEMO

source: NEMO/branches/2019/ENHANCE-03_domcfg/src/agrif_boundary_connections.F90 @ 11201

Last change on this file since 11201 was 10727, checked in by rblod, 5 years ago

new nesting tools (attempt) and brutal cleaning of DOMAINcfg, see ticket #2129

File size: 11.9 KB
Line 
1#if defined key_agrif
2subroutine agrif_boundary_connections
3use agrif_profiles
4use agrif_parameters
5implicit none
6external connect_e3t_copy, connect_e3t_connect, connect_bottom_level,connect_e3u, connect_e3v
7if (agrif_root()) return
8
9call Agrif_connection()
10
11call Agrif_Bc_variable(bottom_level_id, procname = connect_bottom_level)
12
13call Agrif_Bc_variable(e3t_copy_id, procname = connect_e3t_copy)
14
15! Agrif_UseSpecialValue = .TRUE.
16! Agrif_SpecialValue = 0.
17! call Agrif_Bc_variable(e3t_connect_id, procname = connect_e3t_connect)
18! Agrif_UseSpecialValue = .FALSE.
19
20
21      Agrif_SpecialValue    = 0.
22      Agrif_UseSpecialValue = ln_spc_dyn
23      !
24      CALL Agrif_Bc_variable( e3u_id, procname=connect_e3u )
25      CALL Agrif_Bc_variable( e3v_id, procname=connect_e3v )
26      !
27      Agrif_UseSpecialValue = .FALSE.
28     
29end subroutine agrif_boundary_connections
30
31
32    SUBROUTINE connect_e3t_copy( ptab, i1, i2, j1, j2, k1, k2, before, nb,ndir)
33    USE dom_oce
34    USE domzgr
35    USE agrif_parameters
36      !!----------------------------------------------------------------------
37      !!                  ***  ROUTINE interpsshn  ***
38      !!---------------------------------------------------------------------- 
39      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2
40      REAL, DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) ::   ptab
41      LOGICAL                         , INTENT(in   ) ::   before
42      INTEGER                         , INTENT(in   ) ::   nb , ndir
43      LOGICAL  ::   western_side, eastern_side,northern_side,southern_side
44      !
45      !!----------------------------------------------------------------------
46      INTEGER :: ji,jj,jk     
47      !
48         western_side  = (nb == 1).AND.(ndir == 1)
49         eastern_side  = (nb == 1).AND.(ndir == 2)
50         southern_side = (nb == 2).AND.(ndir == 1)
51         northern_side = (nb == 2).AND.(ndir == 2)
52
53      IF( before) THEN
54         ptab(i1:i2,j1:j2,k1:k2) = e3t_0(i1:i2,j1:j2,k1:k2)
55      ELSE
56         e3t_0(i1:i2,j1:j2,k1:k2) = ptab(i1:i2,j1:j2,k1:k2)
57      ENDIF
58      !
59   END SUBROUTINE connect_e3t_copy
60   
61    SUBROUTINE connect_bottom_level( ptab, i1, i2, j1, j2, before, nb,ndir)
62    USE dom_oce
63    USE domzgr
64      !!----------------------------------------------------------------------
65      !!                  ***  ROUTINE interpsshn  ***
66      !!---------------------------------------------------------------------- 
67      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
68      REAL, DIMENSION(i1:i2,j1:j2)    , INTENT(inout) ::   ptab
69      LOGICAL                         , INTENT(in   ) ::   before
70      INTEGER                         , INTENT(in   ) ::   nb , ndir
71      LOGICAL  ::   western_side, eastern_side,northern_side,southern_side
72      !
73      !!----------------------------------------------------------------------
74      INTEGER :: ji,jj     
75      !
76         western_side  = (nb == 1).AND.(ndir == 1)
77         eastern_side  = (nb == 1).AND.(ndir == 2)
78         southern_side = (nb == 2).AND.(ndir == 1)
79         northern_side = (nb == 2).AND.(ndir == 2)
80
81      IF( before) THEN
82         ptab(i1:i2,j1:j2) = mbkt(i1:i2,j1:j2)*ssmask(i1:i2,j1:j2)
83      ELSE
84         mbkt(i1:i2,j1:j2) = nint(ptab(i1:i2,j1:j2))
85         
86         WHERE (mbkt(i1:i2,j1:j2)==0)
87           ssmask(i1:i2,j1:j2) = 0.
88         END WHERE
89           
90      ENDIF
91      !
92   END SUBROUTINE connect_bottom_level
93   
94    SUBROUTINE connect_e3t_connect( ptab, i1, i2, j1, j2, k1, k2, before, nb,ndir)
95    USE dom_oce
96    USE domzgr
97      !!----------------------------------------------------------------------
98      !!                  ***  ROUTINE interpsshn  ***
99      !!---------------------------------------------------------------------- 
100      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2
101      REAL, DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) ::   ptab
102      LOGICAL                         , INTENT(in   ) ::   before
103      INTEGER                         , INTENT(in   ) ::   nb , ndir
104      LOGICAL  ::   western_side, eastern_side,northern_side,southern_side
105      !
106      !!----------------------------------------------------------------------
107      INTEGER :: ji,jj,jk   
108      REAL,DIMENSION(i1:i2,j1:j2) :: bathy_local     
109      !
110         western_side  = (nb == 1).AND.(ndir == 1)
111         eastern_side  = (nb == 1).AND.(ndir == 2)
112         southern_side = (nb == 2).AND.(ndir == 1)
113         northern_side = (nb == 2).AND.(ndir == 2)
114
115      IF( before) THEN
116         do jk=1,jpk
117         do jj=j1,j2
118         do ji=i1,i2
119          if (mbkt(ji,jj)>=jk) then
120            ptab(ji,jj,jk) = e3t_0(ji,jj,jk)
121          else
122            ptab(ji,jj,jk) = 0.
123          endif
124         enddo
125         enddo
126         enddo
127         
128         do jj=j1,j2
129         do ji=i1,i2
130           ptab(ji,jj,jpk+1) = SUM ( e3t_0(ji,jj, 1:mbkt(ji,jj) ) ) * ssmask(ji,jj)
131         enddo
132         enddo
133
134      ELSE
135         do jj=j1,j2
136         do ji=i1,i2
137           bathy_local (ji,jj) = SUM ( e3t_0(ji,jj, 1:mbkt(ji,jj) ) ) * ssmask(ji,jj)
138           print *,'ji = ',ji,jj,bathy_local(ji,jj),ptab(ji,jj,jpk+1)
139         enddo
140         enddo
141         
142         ! DO jk=1,jpk
143           ! DO jj=j1,j2
144             ! DO ji=i1,i2
145                 ! e3t_0(ji,jj,jk) = MAX(ptab(ji,jj,jk),MIN(e3zps_min, e3t_1d(jk)*e3zps_rat ))
146                 ! e3t_0(ji,jj,jk) = MIN(e3t_0(ji,jj,jk),e3t_1d(jk))
147             ! ENDDO
148           ! ENDDO
149         ! ENDDO
150      ENDIF
151      !
152   END SUBROUTINE connect_e3t_connect
153   
154   SUBROUTINE connect_e3u( ptab, i1, i2, j1, j2, k1, k2,before, nb, ndir )
155   USE dom_oce
156      !!----------------------------------------------------------------------
157      !!                  *** ROUTINE interpun ***
158      !!---------------------------------------------   
159      !!
160      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2
161      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
162      LOGICAL, INTENT(in) :: before
163      INTEGER, INTENT(in) :: nb , ndir
164      !!
165      INTEGER :: ji,jj,jk
166      REAL(wp) :: zrhoy
167      ! vertical interpolation:
168      REAL(wp), DIMENSION(k1:k2) :: tabin, h_in
169      REAL(wp), DIMENSION(1:jpk) :: h_out
170      INTEGER  :: N_in, N_out, iref
171      REAL(wp) :: h_diff
172      LOGICAL  :: western_side, eastern_side
173      !!---------------------------------------------   
174      !
175      IF (before) THEN
176         DO jk=1,jpk
177            DO jj=j1,j2
178               DO ji=i1,i2
179                 if (min(mbkt(ji,jj),mbkt(ji+1,jj))<jk) then
180                  ptab(ji,jj,jk) = 0.
181                 else
182                  ptab(ji,jj,jk) = e2u(ji,jj) * e3u_0(ji,jj,jk)
183                 endif
184# if defined key_vertical
185                  ptab(ji,jj,jk,2) = (umask(ji,jj,jk) * e2u(ji,jj) * e3u_n(ji,jj,jk))
186# endif
187               END DO
188            END DO
189         END DO
190      ELSE
191         zrhoy = Agrif_rhoy()
192# if defined key_vertical
193! VERTICAL REFINEMENT BEGIN
194         western_side  = (nb == 1).AND.(ndir == 1)
195         eastern_side  = (nb == 1).AND.(ndir == 2)
196
197         DO ji=i1,i2
198            iref = ji
199            IF (western_side) iref = MAX(2,ji)
200            IF (eastern_side) iref = MIN(nlci-2,ji)
201            DO jj=j1,j2
202               N_in = 0
203               DO jk=k1,k2
204                  IF (ptab(ji,jj,jk,2) == 0) EXIT
205                  N_in = N_in + 1
206                  tabin(jk) = ptab(ji,jj,jk,1)/ptab(ji,jj,jk,2)
207                  h_in(N_in) = ptab(ji,jj,jk,2)/(e2u(ji,jj)*zrhoy) 
208              ENDDO
209         
210              IF (N_in == 0) THEN
211                 ua(ji,jj,:) = 0._wp
212                 CYCLE
213              ENDIF
214         
215              N_out = 0
216              DO jk=1,jpk
217                 if (umask(iref,jj,jk) == 0) EXIT
218                 N_out = N_out + 1
219                 h_out(N_out) = e3u_a(iref,jj,jk)
220              ENDDO
221         
222              IF (N_out == 0) THEN
223                 ua(ji,jj,:) = 0._wp
224                 CYCLE
225              ENDIF
226         
227              IF (N_in * N_out > 0) THEN
228                 h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in))
229! Should be able to remove the next IF/ELSEIF statement once scale factors are dealt with properly
230                 if (h_diff < -1.e4) then
231                    print *,'CHECK YOUR BATHY ...', h_diff, sum(h_out(1:N_out)), sum(h_in(1:N_in))
232!                    stop
233                 endif
234              ENDIF
235              call reconstructandremap(tabin(1:N_in),h_in(1:N_in),ua(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out)
236            ENDDO
237         ENDDO
238
239# else
240         DO jk = 1, jpkm1
241            DO jj=j1,j2
242            do ji=i1,i2
243              if (min(mbkt(ji+1,jj),mbkt(ji,jj))<jk) then
244                e3u_0(ji,jj,jk)=e3t_1d(jk)
245              else
246                e3u_0(ji,jj,jk) = MAX(ptab(ji,jj,jk) / ( zrhoy * e2u(ji,jj) ),MIN(e3zps_min,e3t_1d(jk)*e3zps_rat))
247              endif
248            enddo
249               
250            END DO
251         END DO
252# endif
253
254      ENDIF
255      !
256   END SUBROUTINE connect_e3u
257   
258   SUBROUTINE connect_e3v( ptab, i1, i2, j1, j2, k1, k2, before, nb, ndir )
259   USE dom_oce
260      !!----------------------------------------------------------------------
261      !!                  *** ROUTINE interpvn ***
262      !!----------------------------------------------------------------------
263      !
264      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2
265      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
266      LOGICAL, INTENT(in) :: before
267      INTEGER, INTENT(in) :: nb , ndir
268      !
269      INTEGER :: ji,jj,jk
270      REAL(wp) :: zrhox
271      ! vertical interpolation:
272      REAL(wp), DIMENSION(k1:k2) :: tabin, h_in
273      REAL(wp), DIMENSION(1:jpk) :: h_out
274      INTEGER  :: N_in, N_out, jref
275      REAL(wp) :: h_diff
276      LOGICAL  :: northern_side,southern_side
277      !!---------------------------------------------   
278      !     
279      IF (before) THEN         
280         DO jk=k1,k2
281            DO jj=j1,j2
282               DO ji=i1,i2
283                 if (min(mbkt(ji,jj),mbkt(ji,jj+1))<jk) then
284                  ptab(ji,jj,jk) = 0.
285                 else
286                  ptab(ji,jj,jk) = (e1v(ji,jj) * e3v_0(ji,jj,jk))
287                 endif
288# if defined key_vertical
289                  ptab(ji,jj,jk,2) = vmask(ji,jj,jk) * e1v(ji,jj) * e3v_n(ji,jj,jk)
290# endif
291               END DO
292            END DO
293         END DO
294      ELSE       
295         zrhox = Agrif_rhox()
296# if defined key_vertical
297
298         southern_side = (nb == 2).AND.(ndir == 1)
299         northern_side = (nb == 2).AND.(ndir == 2)
300
301         DO jj=j1,j2
302            jref = jj
303            IF (southern_side) jref = MAX(2,jj)
304            IF (northern_side) jref = MIN(nlcj-2,jj)
305            DO ji=i1,i2
306               N_in = 0
307               DO jk=k1,k2
308                  if (ptab(ji,jj,jk,2) == 0) EXIT
309                  N_in = N_in + 1
310                  tabin(jk) = ptab(ji,jj,jk,1)/ptab(ji,jj,jk,2)
311                  h_in(N_in) = ptab(ji,jj,jk,2)/(e1v(ji,jj)*zrhox)
312               END DO
313               IF (N_in == 0) THEN
314                  va(ji,jj,:) = 0._wp
315                  CYCLE
316               ENDIF
317         
318               N_out = 0
319               DO jk=1,jpk
320                  if (vmask(ji,jref,jk) == 0) EXIT
321                  N_out = N_out + 1
322                  h_out(N_out) = e3v_a(ji,jref,jk)
323               END DO
324               IF (N_out == 0) THEN
325                 va(ji,jj,:) = 0._wp
326                 CYCLE
327               ENDIF
328               call reconstructandremap(tabin(1:N_in),h_in(1:N_in),va(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out)
329            END DO
330         END DO
331# else
332         DO jk = 1, jpkm1
333          DO jj=j1,j2
334          DO ji=i1,i2
335              if (min(mbkt(ji,jj),mbkt(ji,jj+1))<jk) then
336                e3v_0(ji,jj,jk)=e3t_1d(jk)
337              else
338                e3v_0(ji,jj,jk) = MAX(ptab(ji,jj,jk) / ( zrhox * e1v(ji,jj) ),MIN(e3zps_min,e3t_1d(jk)*e3zps_rat))
339              endif
340          ENDDO
341          ENDDO
342         END DO
343# endif
344      ENDIF
345      !       
346   END SUBROUTINE connect_e3v
347
348#else
349subroutine agrif_boundary_connections_empty
350end subroutine agrif_boundary_connections_empty
351#endif
Note: See TracBrowser for help on using the repository browser.