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 utils/tools_dev_r12970_AGRIF_CMEMS/DOMAINcfg/src – NEMO

source: utils/tools_dev_r12970_AGRIF_CMEMS/DOMAINcfg/src/agrif_boundary_connections.F90 @ 13024

Last change on this file since 13024 was 13024, checked in by rblod, 4 years ago

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