source: NEMO/trunk/src/NST/agrif_oce_interp.F90 @ 14976

Last change on this file since 14976 was 14976, checked in by jchanut, 3 months ago

#2638, merge dev_14608_AGRIF_domcfg branch into trunk

  • Property svn:keywords set to Id
File size: 73.9 KB
Line 
1MODULE agrif_oce_interp
2   !!======================================================================
3   !!                   ***  MODULE  agrif_oce_interp  ***
4   !! AGRIF: interpolation package for the ocean dynamics (OCE)
5   !!======================================================================
6   !! History :  2.0  !  2002-06  (L. Debreu)  Original cade
7   !!            3.2  !  2009-04  (R. Benshila)
8   !!            3.6  !  2014-09  (R. Benshila)
9   !!----------------------------------------------------------------------
10#if defined key_agrif
11   !!----------------------------------------------------------------------
12   !!   'key_agrif'                                              AGRIF zoom
13   !!----------------------------------------------------------------------
14   !!   Agrif_tra     :
15   !!   Agrif_dyn     :
16   !!   Agrif_ssh     :
17   !!   Agrif_dyn_ts  :
18   !!   Agrif_dta_ts  :
19   !!   Agrif_ssh_ts  :
20   !!   Agrif_avm     :
21   !!   interpu       :
22   !!   interpv       :
23   !!----------------------------------------------------------------------
24   USE par_oce
25   USE oce
26   USE dom_oce     
27   USE zdf_oce
28   USE agrif_oce
29   USE phycst
30!!!   USE dynspg_ts, ONLY: un_adv, vn_adv
31   !
32   USE in_out_manager
33   USE agrif_oce_sponge
34   USE lib_mpp
35   USE vremap
36   USE lbclnk
37 
38   IMPLICIT NONE
39   PRIVATE
40
41   PUBLIC   Agrif_dyn, Agrif_ssh, Agrif_dyn_ts, Agrif_dyn_ts_flux, Agrif_ssh_ts, Agrif_dta_ts
42   PUBLIC   Agrif_tra, Agrif_avm
43   PUBLIC   interpun , interpvn
44   PUBLIC   interptsn, interpsshn, interpavm
45   PUBLIC   interpunb, interpvnb , interpub2b, interpvb2b
46   PUBLIC   interpglamt, interpgphit
47   PUBLIC   interpht0, interpmbkt, interpe3t0_vremap
48   PUBLIC   agrif_istate_oce, agrif_istate_ssh   ! called by icestate.F90 and domvvl.F90
49   PUBLIC   agrif_check_bat
50
51   INTEGER ::   bdy_tinterp = 0
52
53   !! * Substitutions
54#  include "domzgr_substitute.h90"
55   !! NEMO/NST 4.0 , NEMO Consortium (2018)
56   !! $Id$
57   !! Software governed by the CeCILL license (see ./LICENSE)
58   !!----------------------------------------------------------------------
59CONTAINS
60
61   SUBROUTINE Agrif_istate_oce( Kbb, Kmm, Kaa )
62      !!----------------------------------------------------------------------
63      !!                 *** ROUTINE agrif_istate_oce ***
64      !!
65      !!                 set initial t, s, u, v, ssh from parent
66      !!----------------------------------------------------------------------
67      !
68      IMPLICIT NONE
69      !
70      INTEGER, INTENT(in)  :: Kbb, Kmm, Kaa
71      INTEGER :: jn
72      !!----------------------------------------------------------------------
73      IF(lwp) WRITE(numout,*) ' '
74      IF(lwp) WRITE(numout,*) 'Agrif_istate_oce : interp child initial state from parent'
75      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~~'
76      IF(lwp) WRITE(numout,*) ' '
77
78      IF ( .NOT.Agrif_Parent(l_1st_euler) ) & 
79         & CALL ctl_stop('AGRIF hot start requires to force Euler first step on parent')
80
81      l_ini_child           = .TRUE.
82      Agrif_SpecialValue    = 0.0_wp
83      Agrif_UseSpecialValue = .TRUE.
84
85      ts(:,:,:,:,Kbb) = 0.0_wp
86      uu(:,:,:,Kbb)   = 0.0_wp
87      vv(:,:,:,Kbb)   = 0.0_wp 
88       
89      Krhs_a = Kbb   ;   Kmm_a = Kbb
90
91      CALL Agrif_Init_Variable(tsini_id, procname=interptsn)
92
93      Agrif_UseSpecialValue = ln_spc_dyn
94      use_sign_north = .TRUE.
95      sign_north = -1._wp
96      CALL Agrif_Init_Variable(uini_id , procname=interpun )
97      CALL Agrif_Init_Variable(vini_id , procname=interpvn )
98      use_sign_north = .FALSE.
99
100      Agrif_UseSpecialValue = .FALSE.
101      l_ini_child           = .FALSE.
102
103      Krhs_a = Kaa   ;   Kmm_a = Kmm
104
105      DO jn = 1, jpts
106         ts(:,:,:,jn,Kbb) = ts(:,:,:,jn,Kbb) * tmask(:,:,:)
107      END DO
108      uu(:,:,:,Kbb) = uu(:,:,:,Kbb) * umask(:,:,:)     
109      vv(:,:,:,Kbb) = vv(:,:,:,Kbb) * vmask(:,:,:) 
110
111      CALL lbc_lnk( 'agrif_istate_oce', uu(:,:,:  ,Kbb), 'U', -1.0_wp , vv(:,:,:,Kbb), 'V', -1.0_wp )
112      CALL lbc_lnk( 'agrif_istate_oce', ts(:,:,:,:,Kbb), 'T',  1.0_wp )
113
114   END SUBROUTINE Agrif_istate_oce
115
116
117   SUBROUTINE Agrif_istate_ssh( Kbb, Kmm, Kaa )
118      !!----------------------------------------------------------------------
119      !!                 *** ROUTINE agrif_istate_ssh ***
120      !!
121      !!                    set initial ssh from parent
122      !!----------------------------------------------------------------------
123      !
124      IMPLICIT NONE
125      !
126      INTEGER, INTENT(in)  :: Kbb, Kmm, Kaa 
127      !!----------------------------------------------------------------------
128      IF(lwp) WRITE(numout,*) ' '
129      IF(lwp) WRITE(numout,*) 'Agrif_istate_ssh : interp child ssh from parent'
130      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~~'
131      IF(lwp) WRITE(numout,*) ' '
132
133      IF ( .NOT.Agrif_Parent(l_1st_euler) ) & 
134         & CALL ctl_stop('AGRIF hot start requires to force Euler first step on parent')
135
136      Krhs_a = Kbb   ;   Kmm_a = Kbb
137      !
138      Agrif_SpecialValue    = 0._wp
139      Agrif_UseSpecialValue = .TRUE.
140      l_ini_child           = .TRUE.
141      !
142      ssh(:,:,Kbb) = 0._wp
143      CALL Agrif_Init_Variable(sshini_id, procname=interpsshn)
144      !
145      Agrif_UseSpecialValue = .FALSE.
146      l_ini_child           = .FALSE.
147      !
148      Krhs_a = Kaa   ;   Kmm_a = Kmm
149      !
150      CALL lbc_lnk( 'Agrif_istate_ssh', ssh(:,:,Kbb), 'T', 1._wp )
151      !
152      ssh(:,:,Kmm) = ssh(:,:,Kbb)
153      ssh(:,:,Kaa) = 0._wp
154
155   END SUBROUTINE Agrif_istate_ssh
156
157
158   SUBROUTINE Agrif_tra
159      !!----------------------------------------------------------------------
160      !!                  ***  ROUTINE Agrif_tra  ***
161      !!----------------------------------------------------------------------
162      !
163      IF( Agrif_Root() )   RETURN
164      !
165      Agrif_SpecialValue    = 0._wp
166      Agrif_UseSpecialValue = .TRUE.
167      l_vremap           = ln_vert_remap
168      !
169      CALL Agrif_Bc_variable( ts_interp_id, procname=interptsn )
170      !
171      Agrif_UseSpecialValue = .FALSE.
172      l_vremap              = .FALSE.
173      !
174   END SUBROUTINE Agrif_tra
175
176
177   SUBROUTINE Agrif_dyn( kt )
178      !!----------------------------------------------------------------------
179      !!                  ***  ROUTINE Agrif_DYN  ***
180      !!---------------------------------------------------------------------- 
181      INTEGER, INTENT(in) ::   kt
182      !
183      INTEGER ::   ji, jj, jk       ! dummy loop indices
184      INTEGER ::   ibdy1, jbdy1, ibdy2, jbdy2
185      REAL(wp), DIMENSION(jpi,jpj) ::   zub, zvb
186      !!---------------------------------------------------------------------- 
187      !
188      IF( Agrif_Root() )   RETURN
189      !
190      Agrif_SpecialValue    = 0.0_wp
191      Agrif_UseSpecialValue = ln_spc_dyn
192      l_vremap              = ln_vert_remap
193      !
194      use_sign_north = .TRUE.
195      sign_north = -1.0_wp
196      CALL Agrif_Bc_variable( un_interp_id, procname=interpun )
197      CALL Agrif_Bc_variable( vn_interp_id, procname=interpvn )
198
199      IF( .NOT.ln_dynspg_ts ) THEN ! Get transports
200         ubdy(:,:) = 0._wp    ;  vbdy(:,:) = 0._wp
201         utint_stage(:,:) = 0 ;  vtint_stage(:,:) = 0
202         CALL Agrif_Bc_variable( unb_interp_id, procname=interpunb )
203         CALL Agrif_Bc_variable( vnb_interp_id, procname=interpvnb )
204      ENDIF
205
206      use_sign_north = .FALSE.
207      !
208      Agrif_UseSpecialValue = .FALSE.
209      l_vremap              = .FALSE.
210      !
211      ! Ensure below that vertically integrated transports match
212      ! either transports out of time splitting procedure (ln_dynspg_ts=.TRUE.)
213      ! or parent grid transports (ln_dynspg_ts=.FALSE.)
214      !
215      ! --- West --- !
216      IF( lk_west ) THEN
217         ibdy1 = nn_hls + 2                  ! halo + land + 1
218         ibdy2 = nn_hls + nbghostcells + nn_shift_bar*Agrif_Rhox()   ! halo + land + nbghostcells
219         !
220         IF( .NOT.ln_dynspg_ts ) THEN  ! Store transport
221            DO ji = mi0(ibdy1), mi1(ibdy2)
222               DO jj = 1, jpj
223                  uu_b(ji,jj,Krhs_a) = ubdy(ji,jj) * r1_hu(ji,jj,Krhs_a)
224                  vv_b(ji,jj,Krhs_a) = vbdy(ji,jj) * r1_hv(ji,jj,Krhs_a)
225               END DO
226            END DO
227         ENDIF
228         !
229         DO ji = mi0(ibdy1), mi1(ibdy2)
230            zub(ji,:) = 0._wp 
231            DO jk = 1, jpkm1
232               DO jj = 1, jpj
233                  zub(ji,jj) = zub(ji,jj) + e3u(ji,jj,jk,Krhs_a)  * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk)
234               END DO
235            END DO
236            DO jj=1,jpj
237               zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a)
238            END DO
239            DO jk = 1, jpkm1
240               DO jj = 1, jpj
241                  uu(ji,jj,jk,Krhs_a) = ( uu(ji,jj,jk,Krhs_a) + uu_b(ji,jj,Krhs_a) - zub(ji,jj) ) * umask(ji,jj,jk)
242               END DO
243            END DO
244         END DO
245         !   
246         DO ji = mi0(ibdy1), mi1(ibdy2)
247            zvb(ji,:) = 0._wp
248            DO jk = 1, jpkm1
249               DO jj = 1, jpj
250                  zvb(ji,jj) = zvb(ji,jj) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk)
251               END DO
252            END DO
253            DO jj = 1, jpj
254               zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a)
255            END DO
256            DO jk = 1, jpkm1
257               DO jj = 1, jpj
258                  vv(ji,jj,jk,Krhs_a) = ( vv(ji,jj,jk,Krhs_a) + vv_b(ji,jj,Krhs_a) - zvb(ji,jj) )*vmask(ji,jj,jk)
259               END DO
260            END DO
261         END DO
262         !
263      ENDIF
264
265      ! --- East --- !
266      IF( lk_east) THEN
267         ibdy1 = jpiglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhox()   
268         ibdy2 = jpiglo - ( nn_hls + 2 )                 
269         !
270         IF( .NOT.ln_dynspg_ts ) THEN
271            DO ji = mi0(ibdy1), mi1(ibdy2)
272               DO jj = 1, jpj
273                  uu_b(ji,jj,Krhs_a) = ubdy(ji,jj) * r1_hu(ji,jj,Krhs_a)
274               END DO
275            END DO
276         ENDIF
277         !
278         DO ji = mi0(ibdy1), mi1(ibdy2)
279            zub(ji,:) = 0._wp   
280            DO jk = 1, jpkm1
281               DO jj = 1, jpj
282                  zub(ji,jj) = zub(ji,jj) + e3u(ji,jj,jk,Krhs_a)  * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk)
283               END DO
284            END DO
285            DO jj=1,jpj
286               zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a)
287            END DO
288            DO jk = 1, jpkm1
289               DO jj = 1, jpj
290                  uu(ji,jj,jk,Krhs_a) = ( uu(ji,jj,jk,Krhs_a) + uu_b(ji,jj,Krhs_a) - zub(ji,jj) ) * umask(ji,jj,jk)
291               END DO
292            END DO
293         END DO
294         !
295         ibdy1 = jpiglo - ( nn_hls + nbghostcells - 1 ) - nn_shift_bar*Agrif_Rhox() 
296         ibdy2 = jpiglo - ( nn_hls + 1 )     
297         !
298         IF( .NOT.ln_dynspg_ts ) THEN
299            DO ji = mi0(ibdy1), mi1(ibdy2)
300               DO jj = 1, jpj
301                  vv_b(ji,jj,Krhs_a) = vbdy(ji,jj) * r1_hv(ji,jj,Krhs_a)
302               END DO
303            END DO
304         ENDIF
305         !
306         DO ji = mi0(ibdy1), mi1(ibdy2)
307            zvb(ji,:) = 0._wp
308            DO jk = 1, jpkm1
309               DO jj = 1, jpj
310                     zvb(ji,jj) = zvb(ji,jj) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk)
311               END DO
312            END DO
313            DO jj = 1, jpj
314               zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a)
315            END DO
316            DO jk = 1, jpkm1
317               DO jj = 1, jpj
318                     vv(ji,jj,jk,Krhs_a) = ( vv(ji,jj,jk,Krhs_a) + vv_b(ji,jj,Krhs_a) - zvb(ji,jj) ) * vmask(ji,jj,jk)
319               END DO
320            END DO
321         END DO
322         !
323      ENDIF
324
325      ! --- South --- !
326      IF( lk_south ) THEN
327         jbdy1 = nn_hls + 2                 
328         jbdy2 = nn_hls + nbghostcells + nn_shift_bar*Agrif_Rhoy()   
329         !
330         IF( .NOT.ln_dynspg_ts ) THEN
331            DO jj = mj0(jbdy1), mj1(jbdy2)
332               DO ji = 1, jpi
333                  uu_b(ji,jj,Krhs_a) = ubdy(ji,jj) * r1_hu(ji,jj,Krhs_a)
334                  vv_b(ji,jj,Krhs_a) = vbdy(ji,jj) * r1_hv(ji,jj,Krhs_a)
335               END DO
336            END DO
337         ENDIF
338         !
339         DO jj = mj0(jbdy1), mj1(jbdy2)
340            zvb(:,jj) = 0._wp
341            DO jk=1,jpkm1
342               DO ji=1,jpi
343                  zvb(ji,jj) = zvb(ji,jj) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk)
344               END DO
345            END DO
346            DO ji = 1, jpi
347               zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a)
348            END DO
349            DO jk = 1, jpkm1
350               DO ji = 1, jpi
351                  vv(ji,jj,jk,Krhs_a) = ( vv(ji,jj,jk,Krhs_a) + vv_b(ji,jj,Krhs_a) - zvb(ji,jj) ) * vmask(ji,jj,jk)
352               END DO
353            END DO
354         END DO
355         !
356         DO jj = mj0(jbdy1), mj1(jbdy2)
357            zub(:,jj) = 0._wp
358            DO jk = 1, jpkm1
359               DO ji = 1, jpi
360                  zub(ji,jj) = zub(ji,jj) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk)
361               END DO
362            END DO
363            DO ji = 1, jpi
364               zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a)
365            END DO
366            DO jk = 1, jpkm1
367               DO ji = 1, jpi
368                  uu(ji,jj,jk,Krhs_a) = ( uu(ji,jj,jk,Krhs_a) + uu_b(ji,jj,Krhs_a) - zub(ji,jj) ) * umask(ji,jj,jk)
369               END DO
370            END DO
371         END DO
372         !
373      ENDIF
374
375      ! --- North --- !
376      IF( lk_north ) THEN
377         jbdy1 = jpjglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhoy() 
378         jbdy2 = jpjglo - ( nn_hls + 2 )
379         !
380         IF( .NOT.ln_dynspg_ts ) THEN
381            DO jj = mj0(jbdy1), mj1(jbdy2)
382               DO ji = 1, jpi
383                  vv_b(ji,jj,Krhs_a) = vbdy(ji,jj) * r1_hv(ji,jj,Krhs_a)
384               END DO
385            END DO
386         ENDIF
387         !
388         DO jj = mj0(jbdy1), mj1(jbdy2)
389            zvb(:,jj) = 0._wp 
390            DO jk=1,jpkm1
391               DO ji=1,jpi
392                  zvb(ji,jj) = zvb(ji,jj) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk)
393               END DO
394            END DO
395            DO ji = 1, jpi
396               zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a)
397            END DO
398            DO jk = 1, jpkm1
399               DO ji = 1, jpi
400                  vv(ji,jj,jk,Krhs_a) = ( vv(ji,jj,jk,Krhs_a) + vv_b(ji,jj,Krhs_a) - zvb(ji,jj) ) * vmask(ji,jj,jk)
401               END DO
402            END DO
403         END DO
404         !
405         jbdy1 = jpjglo - ( nn_hls + nbghostcells -1 ) - nn_shift_bar*Agrif_Rhoy() 
406         jbdy2 = jpjglo - ( nn_hls + 1 )
407         !
408         IF( .NOT.ln_dynspg_ts ) THEN
409            DO jj = mj0(jbdy1), mj1(jbdy2)
410               DO ji = 1, jpi
411                  uu_b(ji,jj,Krhs_a) = ubdy(ji,jj) * r1_hu(ji,jj,Krhs_a)
412               END DO
413            END DO
414         ENDIF
415         !
416         DO jj = mj0(jbdy1), mj1(jbdy2)
417            zub(:,jj) = 0._wp
418            DO jk = 1, jpkm1
419               DO ji = 1, jpi
420                  zub(ji,jj) = zub(ji,jj) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk)
421               END DO
422            END DO
423            DO ji = 1, jpi
424               zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a)
425            END DO
426            DO jk = 1, jpkm1
427               DO ji = 1, jpi
428                     uu(ji,jj,jk,Krhs_a) = ( uu(ji,jj,jk,Krhs_a) + uu_b(ji,jj,Krhs_a) - zub(ji,jj) ) * umask(ji,jj,jk)
429               END DO
430            END DO
431         END DO
432         !
433      ENDIF
434      !
435   END SUBROUTINE Agrif_dyn
436
437
438   SUBROUTINE Agrif_dyn_ts( jn )
439      !!----------------------------------------------------------------------
440      !!                  ***  ROUTINE Agrif_dyn_ts  ***
441      !!---------------------------------------------------------------------- 
442      INTEGER, INTENT(in) ::   jn
443      !!
444      INTEGER :: ji, jj
445      INTEGER :: istart, iend, jstart, jend
446      !!---------------------------------------------------------------------- 
447      !
448      IF( Agrif_Root() )   RETURN
449      !
450      !--- West ---!
451      IF( lk_west ) THEN
452         istart = nn_hls + 2                              ! halo + land + 1
453         iend   = nn_hls + nbghostcells  + nn_shift_bar*Agrif_Rhox()              ! halo + land + nbghostcells
454         DO ji = mi0(istart), mi1(iend)
455            DO jj=1,jpj
456               va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj)
457               ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj)
458            END DO
459         END DO
460      ENDIF
461      !
462      !--- East ---!
463      IF( lk_east ) THEN
464         istart = jpiglo - ( nn_hls + nbghostcells -1 ) - nn_shift_bar*Agrif_Rhox() 
465         iend   = jpiglo - ( nn_hls + 1 )               
466         DO ji = mi0(istart), mi1(iend)
467
468            DO jj=1,jpj
469               va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj)
470            END DO
471         END DO
472         istart = jpiglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhox() 
473         iend   = jpiglo - ( nn_hls + 2 )               
474         DO ji = mi0(istart), mi1(iend)
475            DO jj=1,jpj
476               ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj)
477            END DO
478         END DO
479      ENDIF 
480      !
481      !--- South ---!
482      IF( lk_south ) THEN
483         jstart = nn_hls + 2                             
484         jend   = nn_hls + nbghostcells + nn_shift_bar*Agrif_Rhoy()           
485         DO jj = mj0(jstart), mj1(jend)
486
487            DO ji=1,jpi
488               ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj)
489               va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj)
490            END DO
491         END DO
492      ENDIF       
493      !
494      !--- North ---!
495      IF( lk_north ) THEN
496         jstart = jpjglo - ( nn_hls + nbghostcells -1 ) - nn_shift_bar*Agrif_Rhoy()     
497         jend   = jpjglo - ( nn_hls + 1 )               
498         DO jj = mj0(jstart), mj1(jend)
499            DO ji=1,jpi
500               ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj)
501            END DO
502         END DO
503         jstart = jpjglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhoy() 
504         jend   = jpjglo - ( nn_hls + 2 )               
505         DO jj = mj0(jstart), mj1(jend)
506            DO ji=1,jpi
507               va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj)
508            END DO
509         END DO
510      ENDIF 
511      !
512   END SUBROUTINE Agrif_dyn_ts
513
514   
515   SUBROUTINE Agrif_dyn_ts_flux( jn, zu, zv )
516      !!----------------------------------------------------------------------
517      !!                  ***  ROUTINE Agrif_dyn_ts_flux  ***
518      !!---------------------------------------------------------------------- 
519      INTEGER, INTENT(in) ::   jn
520      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   zu, zv
521      !!
522      INTEGER :: ji, jj
523      INTEGER :: istart, iend, jstart, jend
524      !!---------------------------------------------------------------------- 
525      !
526      IF( Agrif_Root() )   RETURN
527      !
528      !--- West ---!
529      IF( lk_west ) THEN
530         istart = nn_hls + 2                             
531         iend   = nn_hls + nbghostcells + nn_shift_bar*Agrif_Rhox() 
532         DO ji = mi0(istart), mi1(iend)
533            DO jj=1,jpj
534               zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj)
535               zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj)
536            END DO
537         END DO
538      ENDIF
539      !
540      !--- East ---!
541      IF( lk_east ) THEN
542         istart = jpiglo - ( nn_hls + nbghostcells -1 ) - nn_shift_bar*Agrif_Rhox()
543         iend   = jpiglo - ( nn_hls + 1 )                 
544         DO ji = mi0(istart), mi1(iend)
545            DO jj=1,jpj
546               zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj)
547            END DO
548         END DO
549         istart = jpiglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhox() 
550         iend   = jpiglo - ( nn_hls + 2 )                 
551         DO ji = mi0(istart), mi1(iend)
552            DO jj=1,jpj
553               zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj)
554            END DO
555         END DO
556      ENDIF
557      !
558      !--- South ---!
559      IF( lk_south ) THEN
560         jstart = nn_hls + 2                             
561         jend   = nn_hls + nbghostcells + nn_shift_bar*Agrif_Rhoy() 
562         DO jj = mj0(jstart), mj1(jend)
563            DO ji=1,jpi
564               zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj)
565               zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj)
566            END DO
567         END DO
568      ENDIF
569      !
570      !--- North ---!
571      IF( lk_north ) THEN
572         jstart = jpjglo - ( nn_hls + nbghostcells -1 ) - nn_shift_bar*Agrif_Rhoy() 
573         jend   = jpjglo - ( nn_hls + 1 )               
574         DO jj = mj0(jstart), mj1(jend)
575            DO ji=1,jpi
576               zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj)
577            END DO
578         END DO
579         jstart = jpjglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhoy() 
580         jend   = jpjglo - ( nn_hls + 2 )               
581         DO jj = mj0(jstart), mj1(jend)
582            DO ji=1,jpi
583               zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj)
584            END DO
585         END DO
586      ENDIF
587      !
588   END SUBROUTINE Agrif_dyn_ts_flux
589
590   
591   SUBROUTINE Agrif_dta_ts( kt )
592      !!----------------------------------------------------------------------
593      !!                  ***  ROUTINE Agrif_dta_ts  ***
594      !!---------------------------------------------------------------------- 
595      INTEGER, INTENT(in) ::   kt
596      !!
597      LOGICAL :: ll_int_cons
598      !!---------------------------------------------------------------------- 
599      !
600      IF( Agrif_Root() )   RETURN
601      !
602      ll_int_cons = ln_bt_fw ! Assume conservative temporal integration in the forward case only
603      !
604      ! Enforce volume conservation if no time refinement: 
605      IF ( Agrif_rhot()==1 ) ll_int_cons=.TRUE. 
606      !
607      ! Interpolate barotropic fluxes
608      Agrif_SpecialValue = 0._wp
609      Agrif_UseSpecialValue = ln_spc_dyn
610
611      use_sign_north = .TRUE.
612      sign_north = -1.
613
614      !
615      ! Set bdy time interpolation stage to 0 (latter incremented locally do deal with corners)
616      utint_stage(:,:) = 0
617      vtint_stage(:,:) = 0
618      !
619      IF( ll_int_cons ) THEN  ! Conservative interpolation
620         IF ( lk_tint2d_notinterp ) THEN
621            Agrif_UseSpecialValue = .FALSE.
622            CALL Agrif_Bc_variable( ub2b_interp_id, calledweight=1._wp, procname=interpub2b_const )
623            CALL Agrif_Bc_variable( vb2b_interp_id, calledweight=1._wp, procname=interpvb2b_const ) 
624            ! Divergence conserving correction terms:
625            IF ( Agrif_Rhox()>1 ) CALL Agrif_Bc_variable(    ub2b_cor_id, calledweight=1._wp, procname=ub2b_cor )
626            IF ( Agrif_Rhoy()>1 ) CALL Agrif_Bc_variable(    vb2b_cor_id, calledweight=1._wp, procname=vb2b_cor )
627         ELSE
628            ! order matters here !!!!!!
629            CALL Agrif_Bc_variable( ub2b_interp_id, calledweight=1._wp, procname=interpub2b ) ! Time integrated
630            CALL Agrif_Bc_variable( vb2b_interp_id, calledweight=1._wp, procname=interpvb2b ) 
631            !
632            bdy_tinterp = 1
633            CALL Agrif_Bc_variable( unb_interp_id , calledweight=1._wp, procname=interpunb  ) ! After
634            CALL Agrif_Bc_variable( vnb_interp_id , calledweight=1._wp, procname=interpvnb  ) 
635            !
636            bdy_tinterp = 2
637            CALL Agrif_Bc_variable( unb_interp_id , calledweight=0._wp, procname=interpunb  ) ! Before
638            CALL Agrif_Bc_variable( vnb_interp_id , calledweight=0._wp, procname=interpvnb  )   
639         ENDIF
640      ELSE ! Linear interpolation
641         !
642         ubdy(:,:) = 0._wp   ;   vbdy(:,:) = 0._wp 
643         CALL Agrif_Bc_variable( unb_interp_id, procname=interpunb )
644         CALL Agrif_Bc_variable( vnb_interp_id, procname=interpvnb )
645      ENDIF
646      Agrif_UseSpecialValue = .FALSE.
647      use_sign_north = .FALSE.
648      !
649   END SUBROUTINE Agrif_dta_ts
650
651
652   SUBROUTINE Agrif_ssh( kt )
653      !!----------------------------------------------------------------------
654      !!                  ***  ROUTINE Agrif_ssh  ***
655      !!---------------------------------------------------------------------- 
656      INTEGER, INTENT(in) ::   kt
657      !
658      INTEGER  :: ji, jj
659      INTEGER  :: istart, iend, jstart, jend
660      !!---------------------------------------------------------------------- 
661      !
662      IF( Agrif_Root() )   RETURN
663      !     
664      ! Linear time interpolation of sea level
665      !
666      Agrif_SpecialValue    = 0._wp
667      Agrif_UseSpecialValue = .TRUE.
668      CALL Agrif_Bc_variable(sshn_id, procname=interpsshn )
669      Agrif_UseSpecialValue = .FALSE.
670      !
671      ! --- West --- !
672      IF(lk_west) THEN
673         istart = nn_hls + 2                                                          ! halo + land + 1
674         iend   = nn_hls + nbghostcells + nn_shift_bar*Agrif_Rhox()               ! halo + land + nbghostcells
675         DO ji = mi0(istart), mi1(iend)
676            DO jj = 1, jpj
677               ssh(ji,jj,Krhs_a) = hbdy(ji,jj)
678            END DO
679         END DO
680      ENDIF
681      !
682      ! --- East --- !
683      IF(lk_east) THEN
684         istart = jpiglo - ( nn_hls + nbghostcells -1 ) - nn_shift_bar*Agrif_Rhox()       ! halo + land + nbghostcells - 1
685         iend   = jpiglo - ( nn_hls + 1 )                                              ! halo + land + 1            - 1
686         DO ji = mi0(istart), mi1(iend)
687            DO jj = 1, jpj
688               ssh(ji,jj,Krhs_a) = hbdy(ji,jj)
689            END DO
690         END DO
691      ENDIF
692      !
693      ! --- South --- !
694      IF(lk_south) THEN
695         jstart = nn_hls + 2                                                          ! halo + land + 1
696         jend   = nn_hls + nbghostcells + nn_shift_bar*Agrif_Rhoy()               ! halo + land + nbghostcells
697         DO jj = mj0(jstart), mj1(jend)
698            DO ji = 1, jpi
699               ssh(ji,jj,Krhs_a) = hbdy(ji,jj)
700            END DO
701         END DO
702      ENDIF
703      !
704      ! --- North --- !
705      IF(lk_north) THEN
706         jstart = jpjglo - ( nn_hls + nbghostcells -1 ) - nn_shift_bar*Agrif_Rhoy()     ! halo + land + nbghostcells - 1
707         jend   = jpjglo - ( nn_hls + 1 )                                            ! halo + land + 1            - 1
708         DO jj = mj0(jstart), mj1(jend)
709            DO ji = 1, jpi
710               ssh(ji,jj,Krhs_a) = hbdy(ji,jj)
711            END DO
712         END DO
713      ENDIF
714      !
715   END SUBROUTINE Agrif_ssh
716
717
718   SUBROUTINE Agrif_ssh_ts( jn )
719      !!----------------------------------------------------------------------
720      !!                  ***  ROUTINE Agrif_ssh_ts  ***
721      !!---------------------------------------------------------------------- 
722      INTEGER, INTENT(in) ::   jn
723      !!
724      INTEGER :: ji, jj
725      INTEGER  :: istart, iend, jstart, jend
726      !!---------------------------------------------------------------------- 
727      !
728      IF( Agrif_Root() )   RETURN
729      !
730      ! --- West --- !
731      IF(lk_west) THEN
732         istart = nn_hls + 2                                                        ! halo + land + 1
733         iend   = nn_hls + nbghostcells + nn_shift_bar*Agrif_Rhox()             ! halo + land + nbghostcells
734         DO ji = mi0(istart), mi1(iend)
735            DO jj = 1, jpj
736               ssha_e(ji,jj) = hbdy(ji,jj)
737            END DO
738         END DO
739      ENDIF
740      !
741      ! --- East --- !
742      IF(lk_east) THEN
743         istart = jpiglo - ( nn_hls + nbghostcells -1 ) - nn_shift_bar*Agrif_Rhox()    ! halo + land + nbghostcells - 1
744         iend   = jpiglo - ( nn_hls + 1 )                                           ! halo + land + 1            - 1
745         DO ji = mi0(istart), mi1(iend)
746            DO jj = 1, jpj
747               ssha_e(ji,jj) = hbdy(ji,jj)
748            END DO
749         END DO
750      ENDIF
751      !
752      ! --- South --- !
753      IF(lk_south) THEN
754         jstart = nn_hls + 2                                                        ! halo + land + 1
755         jend   = nn_hls + nbghostcells + nn_shift_bar*Agrif_Rhoy()             ! halo + land + nbghostcells
756         DO jj = mj0(jstart), mj1(jend)
757            DO ji = 1, jpi
758               ssha_e(ji,jj) = hbdy(ji,jj)
759            END DO
760         END DO
761      ENDIF
762      !
763      ! --- North --- !
764      IF(lk_north) THEN
765         jstart = jpjglo - ( nn_hls + nbghostcells -1 ) - nn_shift_bar*Agrif_Rhoy()    ! halo + land + nbghostcells - 1
766         jend   = jpjglo - ( nn_hls + 1 )                                           ! halo + land + 1            - 1
767         DO jj = mj0(jstart), mj1(jend)
768            DO ji = 1, jpi
769               ssha_e(ji,jj) = hbdy(ji,jj)
770            END DO
771         END DO
772      ENDIF
773      !
774   END SUBROUTINE Agrif_ssh_ts
775
776   
777   SUBROUTINE Agrif_avm
778      !!----------------------------------------------------------------------
779      !!                  ***  ROUTINE Agrif_avm  ***
780      !!---------------------------------------------------------------------- 
781      REAL(wp) ::   zalpha
782      !!---------------------------------------------------------------------- 
783      !
784      IF( Agrif_Root() )   RETURN
785      !
786      zalpha = 1._wp ! JC: proper time interpolation impossible 
787                     ! => use last available value from parent
788      !
789      Agrif_SpecialValue    = 0.e0
790      Agrif_UseSpecialValue = .TRUE.
791      l_vremap              = ln_vert_remap
792      !
793      CALL Agrif_Bc_variable( avm_id, calledweight=zalpha, procname=interpavm )       
794      !
795      Agrif_UseSpecialValue = .FALSE.
796      l_vremap              = .FALSE.
797      !
798   END SUBROUTINE Agrif_avm
799
800
801   SUBROUTINE interptsn( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before )
802      !!----------------------------------------------------------------------
803      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) ::   ptab
804      INTEGER                                     , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2, n1, n2
805      LOGICAL                                     , INTENT(in   ) ::   before
806      !
807      INTEGER  ::   ji, jj, jk, jn  ! dummy loop indices
808      INTEGER  ::   N_in, N_out
809      INTEGER  :: item
810      ! vertical interpolation:
811      REAL(wp) :: zhtot, zwgt
812      REAL(wp), DIMENSION(k1:k2,1:jpts) :: tabin, tabin_i
813      REAL(wp), DIMENSION(k1:k2) :: z_in, h_in_i, z_in_i
814      REAL(wp), DIMENSION(1:jpk) :: h_out, z_out
815      !!----------------------------------------------------------------------
816
817      IF( before ) THEN
818
819         item = Kmm_a
820         IF( l_ini_child )   Kmm_a = Kbb_a 
821
822         DO jn = 1,jpts
823            DO jk=k1,k2
824               DO jj=j1,j2
825                 DO ji=i1,i2
826                       ptab(ji,jj,jk,jn) = ts(ji,jj,jk,jn,Kmm_a)
827                 END DO
828              END DO
829           END DO
830         END DO
831
832         IF( l_vremap .OR. l_ini_child .OR. ln_zps ) THEN
833
834            ! Fill cell depths (i.e. gdept) to be interpolated
835            ! Warning: these are masked, hence extrapolated prior interpolation.
836            DO jj=j1,j2
837               DO ji=i1,i2
838                  ptab(ji,jj,k1,jpts+1) = 0.5_wp * tmask(ji,jj,k1) * e3t(ji,jj,k1,Kmm_a)
839                  DO jk=k1+1,k2
840                     ptab(ji,jj,jk,jpts+1) = tmask(ji,jj,jk) * &
841                        & ( ptab(ji,jj,jk-1,jpts+1) + 0.5_wp * (e3t(ji,jj,jk-1,Kmm_a)+e3t(ji,jj,jk,Kmm_a)) )
842                  END DO
843               END DO
844            END DO
845         
846            ! Save ssh at last level:
847            IF (.NOT.ln_linssh) THEN
848               ptab(i1:i2,j1:j2,k2,jpts+1) = ssh(i1:i2,j1:j2,Kmm_a)*tmask(i1:i2,j1:j2,1) 
849            END IF     
850         ENDIF
851         Kmm_a = item
852
853      ELSE
854         item = Krhs_a
855         IF( l_ini_child )   Krhs_a = Kbb_a 
856
857         IF( l_vremap .OR. l_ini_child ) THEN
858            IF (ln_linssh) ptab(i1:i2,j1:j2,k2,n2) = 0._wp 
859            DO jj=j1,j2
860               DO ji=i1,i2
861                  ts(ji,jj,:,:,Krhs_a) = 0. 
862                  !
863                  ! Build vertical grids:
864                  N_in = mbkt_parent(ji,jj)
865                  N_out = mbkt(ji,jj)
866                  IF (N_in*N_out > 0) THEN
867                     ! Input grid (account for partial cells if any):
868                     DO jk=1,N_in
869                        z_in(jk) = ptab(ji,jj,jk,n2) - ptab(ji,jj,k2,n2)
870                        tabin(jk,1:jpts) = ptab(ji,jj,jk,1:jpts)
871                     END DO
872                 
873                     ! Intermediate grid:
874                     IF ( l_vremap ) THEN
875                        DO jk = 1, N_in
876                           h_in_i(jk) = e3t0_parent(ji,jj,jk) * & 
877                             &       (1._wp + ptab(ji,jj,k2,n2)/(ht0_parent(ji,jj)*ssmask(ji,jj) + 1._wp - ssmask(ji,jj)))
878                        END DO
879                        z_in_i(1) = 0.5_wp * h_in_i(1)
880                        DO jk=2,N_in
881                           z_in_i(jk) = z_in_i(jk-1) + 0.5_wp * ( h_in_i(jk) + h_in_i(jk-1) )
882                        END DO
883                        z_in_i(1:N_in) = z_in_i(1:N_in)  - ptab(ji,jj,k2,n2)
884                     ENDIF                             
885
886                     ! Output (Child) grid:
887                     DO jk=1,N_out
888                        h_out(jk) = e3t(ji,jj,jk,Krhs_a)
889                     END DO
890                     z_out(1) = 0.5_wp * h_out(1)
891                     DO jk=2,N_out
892                        z_out(jk) = z_out(jk-1) + 0.5_wp * ( h_out(jk)+h_out(jk-1) )
893                     END DO
894                     IF (.NOT.ln_linssh) z_out(1:N_out) = z_out(1:N_out)  - ssh(ji,jj,Krhs_a)
895
896                     IF( l_ini_child ) THEN
897                        CALL remap_linear(tabin(1:N_in,1:jpts),z_in(1:N_in),ts(ji,jj,1:N_out,1:jpts,Krhs_a),              &
898                                      &   z_out(1:N_out),N_in,N_out,jpts) 
899                     ELSE
900                        CALL remap_linear(tabin(1:N_in,1:jpts),z_in(1:N_in),tabin_i(1:N_in,1:jpts),                       &
901                                     &   z_in_i(1:N_in),N_in,N_in,jpts)
902                        CALL reconstructandremap(tabin_i(1:N_in,1:jpts),h_in_i(1:N_in),ts(ji,jj,1:N_out,1:jpts,Krhs_a),   &
903                                      &   h_out(1:N_out),N_in,N_out,jpts) 
904                     ENDIF
905                  ENDIF
906               END DO
907            END DO
908            Krhs_a = item
909 
910         ELSE
911         
912            IF ( Agrif_Parent(ln_zps) ) THEN ! Account for partial cells
913                                             ! linear vertical interpolation
914               DO jj=j1,j2
915                  DO ji=i1,i2
916                     !
917                     N_in  = mbkt(ji,jj)
918                     N_out = mbkt(ji,jj)
919                     z_in(1) = ptab(ji,jj,1,n2)
920                     tabin(1,1:jpts) = ptab(ji,jj,1,1:jpts)
921                     DO jk=2, N_in
922                        z_in(jk) = ptab(ji,jj,jk,n2)
923                        tabin(jk,1:jpts) = ptab(ji,jj,jk,1:jpts)
924                     END DO
925                     IF (.NOT.ln_linssh) z_in(1:N_in) = z_in(1:N_in) - ptab(ji,jj,k2,n2)
926                     z_out(1) = 0.5_wp * e3t(ji,jj,1,Krhs_a)
927                     DO jk=2, N_out
928                        z_out(jk) = z_out(jk-1) + 0.5_wp * (e3t(ji,jj,jk-1,Krhs_a) + e3t(ji,jj,jk,Krhs_a))
929                     END DO
930                     IF (.NOT.ln_linssh) z_out(1:N_out) = z_out(1:N_out) - ssh(ji,jj,Krhs_a)
931                     CALL remap_linear(tabin(1:N_in,1:jpts),z_in(1:N_in),ptab(ji,jj,1:N_out,1:jpts), &
932                                   &   z_out(1:N_out),N_in,N_out,jpts) 
933                  END DO
934               END DO
935            ENDIF
936
937            DO jn =1, jpts
938               ts(i1:i2,j1:j2,1:jpk,jn,Krhs_a) = ptab(i1:i2,j1:j2,1:jpk,jn)*tmask(i1:i2,j1:j2,1:jpk)
939            END DO
940         ENDIF
941
942      ENDIF
943      !
944   END SUBROUTINE interptsn
945
946   
947   SUBROUTINE interpsshn( ptab, i1, i2, j1, j2, before )
948      !!----------------------------------------------------------------------
949      !!                  ***  ROUTINE interpsshn  ***
950      !!---------------------------------------------------------------------- 
951      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
952      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
953      LOGICAL                         , INTENT(in   ) ::   before
954      !
955      !!---------------------------------------------------------------------- 
956      !
957      IF( before) THEN
958         ptab(i1:i2,j1:j2) = ssh(i1:i2,j1:j2,Kmm_a)
959      ELSE
960         IF( l_ini_child ) THEN
961            ssh(i1:i2,j1:j2,Krhs_a) = ptab(i1:i2,j1:j2) * tmask(i1:i2,j1:j2,1)
962         ELSE
963            hbdy(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) * tmask(i1:i2,j1:j2,1)
964         ENDIF
965      ENDIF
966      !
967   END SUBROUTINE interpsshn
968
969   
970   SUBROUTINE interpun( ptab, i1, i2, j1, j2, k1, k2, m1, m2, before )
971      !!----------------------------------------------------------------------
972      !!                  *** ROUTINE interpun ***
973      !!---------------------------------------------   
974      !!
975      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,m1,m2
976      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) :: ptab
977      LOGICAL, INTENT(in) :: before
978      !!
979      INTEGER :: ji,jj,jk
980      REAL(wp) :: zrhoy, zhtot
981      ! vertical interpolation:
982      REAL(wp), DIMENSION(k1:k2) :: tabin, h_in, z_in
983      REAL(wp), DIMENSION(1:jpk) :: h_out, z_out
984      INTEGER  :: N_in, N_out,item
985      REAL(wp) :: h_diff
986      !!---------------------------------------------   
987      !
988      IF (before) THEN
989
990         item = Kmm_a
991         IF( l_ini_child )   Kmm_a = Kbb_a     
992
993         DO jk=1,jpk
994            DO jj=j1,j2
995               DO ji=i1,i2
996                  ptab(ji,jj,jk,1) = (e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a) * uu(ji,jj,jk,Kmm_a)*umask(ji,jj,jk)) 
997                  IF( l_vremap .OR. l_ini_child) THEN
998                     ! Interpolate thicknesses (masked for subsequent extrapolation)
999                     ptab(ji,jj,jk,2) = umask(ji,jj,jk) * e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a)
1000                  ENDIF
1001               END DO
1002            END DO
1003         END DO
1004
1005        IF( l_vremap .OR. l_ini_child ) THEN
1006         ! Extrapolate thicknesses in partial bottom cells:
1007         ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on
1008            IF (ln_zps) THEN
1009               DO jj=j1,j2
1010                  DO ji=i1,i2
1011                     jk = mbku(ji,jj)
1012                     ptab(ji,jj,jk,2) = 0._wp
1013                  END DO
1014               END DO           
1015            END IF
1016
1017           ! Save ssh at last level:
1018           ptab(i1:i2,j1:j2,k2,2) = 0._wp
1019           IF (.NOT.ln_linssh) THEN
1020              ! This vertical sum below should be replaced by the sea-level at U-points (optimization):
1021              DO jk=1,jpk
1022                 ptab(i1:i2,j1:j2,k2,2) = ptab(i1:i2,j1:j2,k2,2) + e3u(i1:i2,j1:j2,jk,Kmm_a) * umask(i1:i2,j1:j2,jk)
1023              END DO
1024              ptab(i1:i2,j1:j2,k2,2) = ptab(i1:i2,j1:j2,k2,2) - hu_0(i1:i2,j1:j2)
1025           END IF
1026        ENDIF
1027
1028         Kmm_a = item
1029         !
1030      ELSE
1031         zrhoy = Agrif_rhoy()
1032
1033        IF( l_vremap .OR. l_ini_child) THEN
1034! VERTICAL REFINEMENT BEGIN
1035
1036            IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp 
1037
1038            DO ji=i1,i2
1039               DO jj=j1,j2
1040                  uu(ji,jj,:,Krhs_a) = 0._wp
1041                  N_in = mbku_parent(ji,jj)
1042                  N_out = mbku(ji,jj)
1043                  IF (N_in*N_out > 0) THEN
1044                     zhtot = 0._wp
1045                     DO jk=1,N_in
1046                        !IF (jk==N_in) THEN
1047                        !   h_in(jk) = hu0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot
1048                        !ELSE
1049                        !   h_in(jk) = ptab(ji,jj,jk,2)/(e2u(ji,jj)*zrhoy)
1050                        !ENDIF
1051                        IF ( l_vremap ) THEN
1052                           h_in(jk) = e3u0_parent(ji,jj,jk) 
1053                        ELSE
1054                           IF (jk==N_in) THEN
1055                              h_in(jk) = hu0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot
1056                           ELSE
1057                              h_in(jk) = ptab(ji,jj,jk,2)/(e2u(ji,jj)*zrhoy) 
1058                           ENDIF
1059                        ENDIF
1060                        zhtot = zhtot + h_in(jk)
1061                        IF( h_in(jk) .GT. 0. ) THEN
1062                           tabin(jk) = ptab(ji,jj,jk,1)/(e2u(ji,jj)*zrhoy*h_in(jk))
1063                        ELSE
1064                           tabin(jk) = 0.
1065                        ENDIF
1066                    END DO
1067                    z_in(1) = 0.5_wp * h_in(1) - zhtot + hu0_parent(ji,jj) 
1068                    DO jk=2,N_in
1069                       z_in(jk) = z_in(jk-1) + 0.5_wp * (h_in(jk)+h_in(jk-1))
1070                    END DO
1071                     
1072                    DO jk=1, N_out
1073                       h_out(jk) = e3u(ji,jj,jk,Krhs_a)
1074                    END DO
1075
1076                    z_out(1) = 0.5_wp * h_out(1) - SUM(h_out(1:N_out)) + hu_0(ji,jj)
1077                    DO jk=2,N_out
1078                       z_out(jk) = z_out(jk-1) + 0.5_wp * (h_out(jk-1) + h_out(jk)) 
1079                    END DO 
1080
1081                    IF( l_ini_child ) THEN
1082                       CALL remap_linear       (tabin(1:N_in),z_in(1:N_in),uu(ji,jj,1:N_out,Krhs_a),z_out(1:N_out),N_in,N_out,1)
1083                    ELSE
1084                       CALL reconstructandremap(tabin(1:N_in),h_in(1:N_in),uu(ji,jj,1:N_out,Krhs_a),h_out(1:N_out),N_in,N_out,1)
1085                    ENDIF   
1086                 ENDIF
1087               END DO
1088            END DO
1089         ELSE
1090            DO jk = 1, jpkm1
1091               DO jj=j1,j2
1092                  uu(i1:i2,jj,jk,Krhs_a) = ptab(i1:i2,jj,jk,1) / ( zrhoy * e2u(i1:i2,jj) * e3u(i1:i2,jj,jk,Krhs_a) )
1093               END DO
1094            END DO
1095         ENDIF
1096
1097      ENDIF
1098      !
1099   END SUBROUTINE interpun
1100
1101   
1102   SUBROUTINE interpvn( ptab, i1, i2, j1, j2, k1, k2, m1, m2, before )
1103      !!----------------------------------------------------------------------
1104      !!                  *** ROUTINE interpvn ***
1105      !!----------------------------------------------------------------------
1106      !
1107      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,m1,m2
1108      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) :: ptab
1109      LOGICAL, INTENT(in) :: before
1110      !
1111      INTEGER :: ji,jj,jk
1112      REAL(wp) :: zrhox
1113      ! vertical interpolation:
1114      REAL(wp), DIMENSION(k1:k2) :: tabin, h_in, z_in
1115      REAL(wp), DIMENSION(1:jpk) :: h_out, z_out
1116      INTEGER  :: N_in, N_out, item
1117      REAL(wp) :: h_diff, zhtot
1118      !!---------------------------------------------   
1119      !     
1120      IF (before) THEN   
1121
1122         item = Kmm_a
1123         IF( l_ini_child )   Kmm_a = Kbb_a     
1124       
1125         DO jk=k1,k2
1126            DO jj=j1,j2
1127               DO ji=i1,i2
1128                  ptab(ji,jj,jk,1) = (e1v(ji,jj) * e3v(ji,jj,jk,Kmm_a) * vv(ji,jj,jk,Kmm_a)*vmask(ji,jj,jk))
1129                  IF( l_vremap .OR. l_ini_child) THEN
1130                     ! Interpolate thicknesses (masked for subsequent extrapolation)
1131                     ptab(ji,jj,jk,2) = vmask(ji,jj,jk) * e1v(ji,jj) * e3v(ji,jj,jk,Kmm_a)
1132                  ENDIF
1133               END DO
1134            END DO
1135         END DO
1136
1137         IF( l_vremap .OR. l_ini_child) THEN
1138         ! Extrapolate thicknesses in partial bottom cells:
1139         ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on
1140            IF (ln_zps) THEN
1141               DO jj=j1,j2
1142                  DO ji=i1,i2
1143                     jk = mbkv(ji,jj)
1144                     ptab(ji,jj,jk,2) = 0._wp
1145                  END DO
1146               END DO           
1147            END IF
1148            ! Save ssh at last level:
1149            ptab(i1:i2,j1:j2,k2,2) = 0._wp
1150            IF (.NOT.ln_linssh) THEN
1151               ! This vertical sum below should be replaced by the sea-level at V-points (optimization):
1152               DO jk=1,jpk
1153                  ptab(i1:i2,j1:j2,k2,2) = ptab(i1:i2,j1:j2,k2,2) + e3v(i1:i2,j1:j2,jk,Kmm_a) * vmask(i1:i2,j1:j2,jk)
1154               END DO
1155               ptab(i1:i2,j1:j2,k2,2) = ptab(i1:i2,j1:j2,k2,2) - hv_0(i1:i2,j1:j2)
1156            END IF
1157         ENDIF
1158         item = Kmm_a
1159
1160      ELSE       
1161         zrhox = Agrif_rhox()
1162
1163         IF( l_vremap .OR. l_ini_child ) THEN
1164
1165            IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp 
1166
1167            DO jj=j1,j2
1168               DO ji=i1,i2
1169                  vv(ji,jj,:,Krhs_a) = 0._wp
1170                  N_in = mbkv_parent(ji,jj)
1171                  N_out = mbkv(ji,jj)
1172
1173                  IF (N_in*N_out > 0) THEN
1174                     zhtot = 0._wp
1175                     DO jk=1,N_in
1176                        !IF (jk==N_in) THEN
1177                        !   h_in(jk) = hv0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot
1178                        !ELSE
1179                        !   h_in(jk) = ptab(ji,jj,jk,2)/(e1v(ji,jj)*zrhox)
1180                        !ENDIF
1181                        IF (l_vremap) THEN
1182                           h_in(jk) = e3v0_parent(ji,jj,jk)
1183                        ELSE
1184                           IF (jk==N_in) THEN
1185                              h_in(jk) = hv0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot
1186                           ELSE
1187                              h_in(jk) = ptab(ji,jj,jk,2)/(e1v(ji,jj)*zrhox) 
1188                           ENDIF
1189                        ENDIF
1190                        zhtot = zhtot + h_in(jk)
1191                        IF( h_in(jk) .GT. 0. ) THEN
1192                          tabin(jk) = ptab(ji,jj,jk,1)/(e1v(ji,jj)*zrhox*h_in(jk))
1193                        ELSE
1194                          tabin(jk)  = 0.
1195                        ENDIF
1196                     END DO
1197
1198                     z_in(1) = 0.5_wp * h_in(1) - zhtot + hv0_parent(ji,jj)
1199                     DO jk=2,N_in
1200                        z_in(jk) = z_in(jk-1) + 0.5_wp * (h_in(jk-1)+h_in(jk))
1201                     END DO
1202
1203                     DO jk=1,N_out
1204                        h_out(jk) = e3v(ji,jj,jk,Krhs_a)
1205                     END DO
1206
1207                     z_out(1) = 0.5_wp * h_out(1) - SUM(h_out(1:N_out)) + hv_0(ji,jj)
1208                     DO jk=2,N_out
1209                        z_out(jk) = z_out(jk-1) + 0.5_wp * (h_out(jk-1)+h_out(jk))
1210                     END DO
1211 
1212                     IF( l_ini_child ) THEN
1213                        CALL remap_linear       (tabin(1:N_in),z_in(1:N_in),vv(ji,jj,1:N_out,Krhs_a),z_out(1:N_out),N_in,N_out,1)
1214                     ELSE
1215                        CALL reconstructandremap(tabin(1:N_in),h_in(1:N_in),vv(ji,jj,1:N_out,Krhs_a),h_out(1:N_out),N_in,N_out,1)
1216                     ENDIF   
1217                  ENDIF
1218               END DO
1219            END DO
1220         ELSE
1221            DO jk = 1, jpkm1
1222               vv(i1:i2,j1:j2,jk,Krhs_a) = ptab(i1:i2,j1:j2,jk,1) / ( zrhox * e1v(i1:i2,j1:j2) * e3v(i1:i2,j1:j2,jk,Krhs_a) )
1223            END DO
1224         ENDIF
1225      ENDIF
1226      !       
1227   END SUBROUTINE interpvn
1228
1229   SUBROUTINE interpunb( ptab, i1, i2, j1, j2, before)
1230      !!----------------------------------------------------------------------
1231      !!                  ***  ROUTINE interpunb  ***
1232      !!---------------------------------------------------------------------- 
1233      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
1234      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
1235      LOGICAL                         , INTENT(in   ) ::   before
1236      !
1237      INTEGER  ::   ji, jj
1238      REAL(wp) ::   zrhoy, zrhot, zt0, zt1, ztcoeff
1239      !!---------------------------------------------------------------------- 
1240      !
1241      IF( before ) THEN
1242         ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * hu(i1:i2,j1:j2,Kmm_a) * uu_b(i1:i2,j1:j2,Kmm_a)
1243      ELSE
1244         zrhoy = Agrif_Rhoy()
1245         zrhot = Agrif_rhot()
1246         ! Time indexes bounds for integration
1247         zt0 = REAL(Agrif_NbStepint()  , wp) / zrhot
1248         zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot     
1249         !
1250         DO ji = i1, i2
1251            DO jj = j1, j2
1252               IF ( utint_stage(ji,jj) < (bdy_tinterp + 1) ) THEN
1253                  IF    ( utint_stage(ji,jj) == 1  ) THEN
1254                     ztcoeff = zrhot * (  zt1**2._wp * (       zt1 - 1._wp)        &
1255                        &               - zt0**2._wp * (       zt0 - 1._wp)        )
1256                  ELSEIF( utint_stage(ji,jj) == 2  ) THEN
1257                     ztcoeff = zrhot * (  zt1        * (       zt1 - 1._wp)**2._wp &
1258                        &               - zt0        * (       zt0 - 1._wp)**2._wp )
1259                  ELSEIF( utint_stage(ji,jj) == 0  ) THEN               
1260                     ztcoeff = 1._wp
1261                  ELSE
1262                     ztcoeff = 0._wp
1263                  ENDIF
1264                  !   
1265                  ubdy(ji,jj) = ubdy(ji,jj) + ztcoeff * ptab(ji,jj)
1266                  !           
1267                  IF (( utint_stage(ji,jj) == 2 ).OR.( utint_stage(ji,jj) == 0 )) THEN
1268                     ubdy(ji,jj) = ubdy(ji,jj) / (zrhoy*e2u(ji,jj)) * umask(ji,jj,1)
1269                  ENDIF
1270                  !
1271                  utint_stage(ji,jj) = utint_stage(ji,jj) + 1
1272               ENDIF
1273            END DO
1274         END DO
1275      END IF
1276      !
1277   END SUBROUTINE interpunb
1278
1279
1280   SUBROUTINE interpvnb( ptab, i1, i2, j1, j2, before )
1281      !!----------------------------------------------------------------------
1282      !!                  ***  ROUTINE interpvnb  ***
1283      !!---------------------------------------------------------------------- 
1284      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
1285      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
1286      LOGICAL                         , INTENT(in   ) ::   before
1287      !
1288      INTEGER  ::   ji, jj
1289      REAL(wp) ::   zrhox, zrhot, zt0, zt1, ztcoeff   
1290      !!---------------------------------------------------------------------- 
1291      !
1292      IF( before ) THEN
1293         ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * hv(i1:i2,j1:j2,Kmm_a) * vv_b(i1:i2,j1:j2,Kmm_a)
1294      ELSE
1295         zrhox = Agrif_Rhox()
1296         zrhot = Agrif_rhot()
1297         ! Time indexes bounds for integration
1298         zt0 = REAL(Agrif_NbStepint()  , wp) / zrhot
1299         zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot 
1300         !     
1301         DO ji = i1, i2
1302            DO jj = j1, j2
1303               IF ( vtint_stage(ji,jj) < (bdy_tinterp + 1) ) THEN
1304                  IF    ( vtint_stage(ji,jj) == 1  ) THEN
1305                     ztcoeff = zrhot * (  zt1**2._wp * (       zt1 - 1._wp)        &
1306                        &               - zt0**2._wp * (       zt0 - 1._wp)        )
1307                  ELSEIF( vtint_stage(ji,jj) == 2  ) THEN
1308                     ztcoeff = zrhot * (  zt1        * (       zt1 - 1._wp)**2._wp &
1309                        &               - zt0        * (       zt0 - 1._wp)**2._wp )
1310                  ELSEIF( vtint_stage(ji,jj) == 0  ) THEN               
1311                     ztcoeff = 1._wp
1312                  ELSE
1313                     ztcoeff = 0._wp
1314                  ENDIF
1315                  !   
1316                  vbdy(ji,jj) = vbdy(ji,jj) + ztcoeff * ptab(ji,jj)
1317                  !           
1318                  IF (( vtint_stage(ji,jj) == 2 ).OR.( vtint_stage(ji,jj) == 0 )) THEN
1319                     vbdy(ji,jj) = vbdy(ji,jj) / (zrhox*e1v(ji,jj)) * vmask(ji,jj,1)
1320                  ENDIF
1321                  !
1322                  vtint_stage(ji,jj) = vtint_stage(ji,jj) + 1
1323               ENDIF
1324            END DO
1325         END DO         
1326      ENDIF
1327      !
1328   END SUBROUTINE interpvnb
1329
1330
1331   SUBROUTINE interpub2b( ptab, i1, i2, j1, j2, before )
1332      !!----------------------------------------------------------------------
1333      !!                  ***  ROUTINE interpub2b  ***
1334      !!---------------------------------------------------------------------- 
1335      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
1336      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
1337      LOGICAL                         , INTENT(in   ) ::   before
1338      !
1339      INTEGER  ::   ji,jj
1340      REAL(wp) ::   zrhot, zt0, zt1, zat
1341      !!---------------------------------------------------------------------- 
1342      IF( before ) THEN
1343!         IF ( ln_bt_fw ) THEN
1344            ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * ub2_b(i1:i2,j1:j2)
1345!         ELSE
1346!            ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * un_adv(i1:i2,j1:j2)
1347!         ENDIF
1348      ELSE
1349         zrhot = Agrif_rhot()
1350         ! Time indexes bounds for integration
1351         zt0 = REAL(Agrif_NbStepint()  , wp) / zrhot
1352         zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot
1353         ! Polynomial interpolation coefficients:
1354         zat = zrhot * (  zt1**2._wp * (-2._wp*zt1 + 3._wp)    &
1355            &           - zt0**2._wp * (-2._wp*zt0 + 3._wp)    ) 
1356         !
1357         ubdy(i1:i2,j1:j2) = zat * ptab(i1:i2,j1:j2) 
1358         !
1359         ! Update interpolation stage:
1360         utint_stage(i1:i2,j1:j2) = 1
1361      ENDIF
1362      !
1363   END SUBROUTINE interpub2b
1364   
1365   SUBROUTINE interpub2b_const( ptab, i1, i2, j1, j2, before )
1366      !!----------------------------------------------------------------------
1367      !!                  ***  ROUTINE interpub2b_const  ***
1368      !!---------------------------------------------------------------------- 
1369      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
1370      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
1371      LOGICAL                         , INTENT(in   ) ::   before
1372      !
1373      REAL(wp) :: zrhoy
1374      !!---------------------------------------------------------------------- 
1375      IF( before ) THEN
1376!         IF ( ln_bt_fw ) THEN
1377            ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * ub2_b(i1:i2,j1:j2)
1378!         ELSE
1379!            ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * un_adv(i1:i2,j1:j2)
1380!         ENDIF
1381      ELSE
1382         zrhoy = Agrif_Rhoy()
1383         !
1384         ubdy(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) & 
1385                           & / (zrhoy*e2u(i1:i2,j1:j2)) * umask(i1:i2,j1:j2,1)
1386         !
1387      ENDIF
1388      !
1389   END SUBROUTINE interpub2b_const
1390
1391
1392   SUBROUTINE ub2b_cor( ptab, i1, i2, j1, j2, before )
1393      !!----------------------------------------------------------------------
1394      !!                  ***  ROUTINE ub2b_cor  ***
1395      !!---------------------------------------------------------------------- 
1396      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
1397      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
1398      LOGICAL                         , INTENT(in   ) ::   before
1399      !
1400      INTEGER  :: ji, jj
1401      REAL(wp) :: zrhox, zrhoy, zx
1402      !!---------------------------------------------------------------------- 
1403      IF( before ) THEN
1404         ptab(:,:) = 0._wp
1405         DO ji=i1+1,i2-1
1406            DO jj=j1+1,j2-1
1407               ptab(ji,jj) = 0.25_wp*( ( vb2_b(ji+1,jj  )*e1v(ji+1,jj  )   & 
1408                           &            -vb2_b(ji-1,jj  )*e1v(ji-1,jj  ) ) &
1409                           &          -( vb2_b(ji+1,jj-1)*e1v(ji+1,jj-1)   &
1410                           &            -vb2_b(ji-1,jj-1)*e1v(ji-1,jj-1) ) )
1411            END DO
1412         END DO
1413      ELSE
1414         !
1415         zrhox = Agrif_Rhox() 
1416         zrhoy = Agrif_Rhoy()
1417         DO ji=i1,i2
1418            DO jj=j1,j2
1419               IF (utint_stage(ji,jj)==0) THEN
1420                  zx = 2._wp*MOD(ABS(mig0(ji)-nbghostcells), INT(Agrif_Rhox()))/zrhox - 1._wp 
1421                  ubdy(ji,jj) = ubdy(ji,jj) + 0.25_wp*(1._wp-zx*zx) * ptab(ji,jj) & 
1422                              &         / zrhoy *r1_e2u(ji,jj) * umask(ji,jj,1) 
1423                  utint_stage(ji,jj) = 1 
1424               ENDIF
1425            END DO
1426         END DO 
1427         !
1428      ENDIF
1429      !
1430   END SUBROUTINE ub2b_cor
1431
1432
1433   SUBROUTINE interpvb2b( ptab, i1, i2, j1, j2, before )
1434      !!----------------------------------------------------------------------
1435      !!                  ***  ROUTINE interpvb2b  ***
1436      !!---------------------------------------------------------------------- 
1437      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
1438      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
1439      LOGICAL                         , INTENT(in   ) ::   before
1440      !
1441      INTEGER ::   ji,jj
1442      REAL(wp) ::   zrhot, zt0, zt1, zat
1443      !!---------------------------------------------------------------------- 
1444      !
1445      IF( before ) THEN
1446!         IF ( ln_bt_fw ) THEN
1447            ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vb2_b(i1:i2,j1:j2)
1448!         ELSE
1449!            ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vn_adv(i1:i2,j1:j2)
1450!         ENDIF
1451      ELSE     
1452         zrhot = Agrif_rhot()
1453         ! Time indexes bounds for integration
1454         zt0 = REAL(Agrif_NbStepint()  , wp) / zrhot
1455         zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot
1456         ! Polynomial interpolation coefficients:
1457         zat = zrhot * (  zt1**2._wp * (-2._wp*zt1 + 3._wp)    &
1458            &           - zt0**2._wp * (-2._wp*zt0 + 3._wp)    ) 
1459         !
1460         vbdy(i1:i2,j1:j2) = zat * ptab(i1:i2,j1:j2)
1461         !
1462         ! update interpolation stage:
1463         vtint_stage(i1:i2,j1:j2) = 1
1464      ENDIF
1465      !     
1466   END SUBROUTINE interpvb2b
1467
1468
1469   SUBROUTINE interpvb2b_const( ptab, i1, i2, j1, j2, before )
1470      !!----------------------------------------------------------------------
1471      !!                  ***  ROUTINE interpub2b_const  ***
1472      !!---------------------------------------------------------------------- 
1473      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
1474      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
1475      LOGICAL                         , INTENT(in   ) ::   before
1476      !
1477      REAL(wp) :: zrhox
1478      !!---------------------------------------------------------------------- 
1479      IF( before ) THEN
1480!         IF ( ln_bt_fw ) THEN
1481            ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vb2_b(i1:i2,j1:j2)
1482!         ELSE
1483!            ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vn_adv(i1:i2,j1:j2)
1484!         ENDIF
1485      ELSE
1486         zrhox = Agrif_Rhox()
1487         !
1488         vbdy(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) &
1489                           & / (zrhox*e1v(i1:i2,j1:j2)) * vmask(i1:i2,j1:j2,1)
1490         !
1491      ENDIF
1492      !
1493   END SUBROUTINE interpvb2b_const
1494
1495 
1496   SUBROUTINE vb2b_cor( ptab, i1, i2, j1, j2, before )
1497      !!----------------------------------------------------------------------
1498      !!                  ***  ROUTINE vb2b_cor  ***
1499      !!---------------------------------------------------------------------- 
1500      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
1501      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
1502      LOGICAL                         , INTENT(in   ) ::   before
1503      !
1504      INTEGER  :: ji, jj
1505      REAL(wp) :: zrhox, zrhoy, zy
1506      !!---------------------------------------------------------------------- 
1507      IF( before ) THEN
1508         ptab(:,:) = 0._wp
1509         DO ji=i1+1,i2-1
1510            DO jj=j1+1,j2-1
1511               ptab(ji,jj) = 0.25_wp*( ( ub2_b(ji  ,jj+1)*e2u(ji  ,jj+1)   & 
1512                           &            -ub2_b(ji  ,jj-1)*e2u(ji  ,jj-1) ) &
1513                           &          -( ub2_b(ji-1,jj+1)*e2u(ji-1,jj+1)   &
1514                           &            -ub2_b(ji-1,jj-1)*e2u(ji-1,jj-1) ) )
1515            END DO
1516         END DO
1517      ELSE
1518         !
1519         zrhox = Agrif_Rhox() 
1520         zrhoy = Agrif_Rhoy()
1521         DO ji=i1,i2
1522            DO jj=j1,j2
1523               IF (vtint_stage(ji,jj)==0) THEN
1524                  zy = 2._wp*MOD(ABS(mjg0(jj)-nbghostcells), INT(Agrif_Rhoy()))/zrhoy - 1._wp 
1525                  vbdy(ji,jj) = vbdy(ji,jj) + 0.25_wp*(1._wp-zy*zy) * ptab(ji,jj) & 
1526                              &         / zrhox * r1_e1v(ji,jj) * vmask(ji,jj,1) 
1527                  vtint_stage(ji,jj) = 1 
1528               ENDIF
1529            END DO
1530         END DO 
1531         !
1532      ENDIF
1533      !
1534   END SUBROUTINE vb2b_cor
1535
1536
1537   SUBROUTINE interpe3t0_vremap( ptab, i1, i2, j1, j2, k1, k2, before )
1538      !!----------------------------------------------------------------------
1539      !!                  ***  ROUTINE interpe3t0_vremap  ***
1540      !!---------------------------------------------------------------------- 
1541      INTEGER                              , INTENT(in   ) :: i1, i2, j1, j2, k1, k2
1542      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
1543      LOGICAL                              , INTENT(in   ) :: before
1544      !
1545      INTEGER :: ji, jj, jk
1546      REAL(wp) :: zh
1547      !!---------------------------------------------------------------------- 
1548      !   
1549      IF( before ) THEN
1550         IF ( ln_zps ) THEN
1551            DO jk = k1, k2
1552               DO jj = j1, j2
1553                  DO ji = i1, i2
1554                     ptab(ji, jj, jk) = e3t_1d(jk)
1555                  END DO
1556               END DO
1557            END DO
1558         ELSE
1559            ptab(i1:i2,j1:j2,k1:k2) = e3t_0(i1:i2,j1:j2,k1:k2)
1560         ENDIF
1561      ELSE
1562         !
1563         DO jk = k1, k2
1564            DO jj = j1, j2
1565               DO ji = i1, i2
1566                  e3t0_parent(ji,jj,jk) = ptab(ji,jj,jk)
1567               END DO
1568            END DO
1569         END DO
1570
1571         ! Retrieve correct scale factor at the bottom:
1572         DO jj = j1, j2
1573            DO ji = i1, i2
1574               zh = 0._wp
1575               DO jk = 1, mbkt_parent(ji, jj)-1
1576                  zh = zh + e3t0_parent(ji,jj,jk)
1577               END DO
1578               e3t0_parent(ji,jj,mbkt_parent(ji,jj)) = ht0_parent(ji, jj) - zh
1579            END DO
1580         END DO
1581         
1582      ENDIF
1583      !
1584   END SUBROUTINE interpe3t0_vremap
1585
1586
1587   SUBROUTINE interpglamt( ptab, i1, i2, j1, j2, before )
1588      !!----------------------------------------------------------------------
1589      !!                  ***  ROUTINE interpglamt  ***
1590      !!---------------------------------------------------------------------- 
1591      INTEGER                        , INTENT(in   ) :: i1, i2, j1, j2
1592      REAL(wp),DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
1593      LOGICAL                        , INTENT(in   ) :: before
1594      !
1595      INTEGER :: ji, jj, jk
1596      REAL(wp):: ztst
1597      !!---------------------------------------------------------------------- 
1598      !   
1599      IF( before ) THEN
1600         ptab(i1:i2,j1:j2) = glamt(i1:i2,j1:j2)
1601      ELSE
1602         ztst = MAXVAL(ABS(glamt(i1:i2,j1:j2)))*1.e-4
1603         DO jj = j1, j2
1604            DO ji = i1, i2
1605               IF( ABS( ptab(ji,jj) - glamt(ji,jj) ) > ztst ) THEN
1606                  WRITE(numout,*) ' Agrif error for glamt: parent, child, i, j ', ptab(ji,jj), glamt(ji,jj), mig0(ji), mig0(jj)
1607!                  kindic_agr = kindic_agr + 1
1608               ENDIF
1609            END DO
1610         END DO
1611      ENDIF
1612      !
1613   END SUBROUTINE interpglamt
1614
1615
1616   SUBROUTINE interpgphit( ptab, i1, i2, j1, j2, before )
1617      !!----------------------------------------------------------------------
1618      !!                  ***  ROUTINE interpgphit  ***
1619      !!---------------------------------------------------------------------- 
1620      INTEGER                        , INTENT(in   ) :: i1, i2, j1, j2
1621      REAL(wp),DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
1622      LOGICAL                        , INTENT(in   ) :: before
1623      !
1624      INTEGER :: ji, jj, jk
1625      REAL(wp):: ztst
1626      !!---------------------------------------------------------------------- 
1627      !   
1628      IF( before ) THEN
1629         ptab(i1:i2,j1:j2) = gphit(i1:i2,j1:j2)
1630      ELSE
1631         ztst = MAXVAL(ABS(gphit(i1:i2,j1:j2)))*1.e-4
1632         DO jj = j1, j2
1633            DO ji = i1, i2
1634               IF( ABS( ptab(ji,jj) - gphit(ji,jj) ) > ztst ) THEN
1635                  WRITE(numout,*) ' Agrif error for gphit: parent, child, i, j ', ptab(ji,jj), gphit(ji,jj), mig0(ji), mig0(jj)
1636!                  kindic_agr = kindic_agr + 1
1637               ENDIF
1638            END DO
1639         END DO
1640      ENDIF
1641      !
1642   END SUBROUTINE interpgphit
1643
1644
1645   SUBROUTINE interpavm( ptab, i1, i2, j1, j2, k1, k2, m1, m2, before )
1646      !!----------------------------------------------------------------------
1647      !!                  ***  ROUTINE interavm  ***
1648      !!---------------------------------------------------------------------- 
1649      INTEGER                                    , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2, m1, m2
1650      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) ::   ptab
1651      LOGICAL                                    , INTENT(in   ) ::   before
1652      !
1653      INTEGER  :: ji, jj, jk
1654      INTEGER  :: N_in, N_out
1655      REAL(wp), DIMENSION(k1:k2) :: tabin, z_in
1656      REAL(wp), DIMENSION(1:jpk) :: z_out
1657      !!---------------------------------------------------------------------- 
1658      !     
1659      IF (before) THEN         
1660         DO jk=k1,k2
1661            DO jj=j1,j2
1662              DO ji=i1,i2
1663                    ptab(ji,jj,jk,1) = avm_k(ji,jj,jk)
1664              END DO
1665           END DO
1666         END DO
1667
1668         IF( l_vremap ) THEN
1669            ! Interpolate interfaces
1670            ! Warning: these are masked, hence extrapolated prior interpolation.
1671            DO jk=k1,k2
1672               DO jj=j1,j2
1673                  DO ji=i1,i2
1674                      ptab(ji,jj,jk,2) = tmask(ji,jj,jk) * gdepw(ji,jj,jk,Kmm_a)
1675                  END DO
1676               END DO
1677            END DO
1678       
1679           ! Save ssh at last level:
1680            IF (.NOT.ln_linssh) THEN
1681               ptab(i1:i2,j1:j2,k2,2) = ssh(i1:i2,j1:j2,Kmm_a)*tmask(i1:i2,j1:j2,1) 
1682            ELSE
1683               ptab(i1:i2,j1:j2,k2,2) = 0._wp
1684            END IF     
1685          ENDIF
1686
1687      ELSE
1688
1689         IF( l_vremap ) THEN
1690            IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp 
1691            avm_k(i1:i2,j1:j2,1:jpkm1) = 0._wp
1692               
1693            DO jj = j1, j2
1694               DO ji =i1, i2
1695                  N_in = mbkt_parent(ji,jj)
1696                  N_out = mbkt(ji,jj)
1697                  IF (N_in*N_out > 0) THEN
1698                     DO jk = 1, N_in  ! Parent vertical grid               
1699                        z_in(jk)  = ptab(ji,jj,jk,2) - ptab(ji,jj,k2,2)
1700                        tabin(jk) = ptab(ji,jj,jk,1)
1701                     END DO
1702                     DO jk = 1, N_out        ! Child vertical grid
1703                        z_out(jk) = gdepw(ji,jj,jk,Kmm_a) - ssh(ji,jj,Kmm_a)
1704                     END DO
1705                     IF (.NOT.ln_linssh) z_out(1:N_out) = z_out(1:N_out)  - ssh(ji,jj,Kmm_a)
1706
1707                     CALL remap_linear(tabin(1:N_in),z_in(1:N_in),avm_k(ji,jj,1:N_out),z_out(1:N_out),N_in,N_out,1)
1708                  ENDIF
1709               END DO
1710            END DO
1711         ELSE
1712            avm_k(i1:i2,j1:j2,1:jpkm1) = ptab (i1:i2,j1:j2,1:jpkm1,1)
1713         ENDIF
1714      ENDIF
1715      !
1716   END SUBROUTINE interpavm
1717
1718   
1719   SUBROUTINE interpmbkt( ptab, i1, i2, j1, j2, before )
1720      !!----------------------------------------------------------------------
1721      !!                  ***  ROUTINE interpmbkt  ***
1722      !!---------------------------------------------------------------------- 
1723      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
1724      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
1725      LOGICAL                         , INTENT(in   ) ::   before
1726      !
1727      !!---------------------------------------------------------------------- 
1728      !
1729      IF( before) THEN
1730         ptab(i1:i2,j1:j2) = REAL(mbkt(i1:i2,j1:j2),wp)
1731      ELSE
1732         mbkt_parent(i1:i2,j1:j2) = NINT(ptab(i1:i2,j1:j2))
1733      ENDIF
1734      !
1735   END SUBROUTINE interpmbkt
1736
1737   
1738   SUBROUTINE interpht0( ptab, i1, i2, j1, j2, before )
1739      !!----------------------------------------------------------------------
1740      !!                  ***  ROUTINE interpht0  ***
1741      !!---------------------------------------------------------------------- 
1742      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
1743      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
1744      LOGICAL                         , INTENT(in   ) ::   before
1745      !
1746      !!---------------------------------------------------------------------- 
1747      !
1748      IF( before) THEN
1749         ptab(i1:i2,j1:j2) = ht_0(i1:i2,j1:j2)
1750      ELSE
1751         ht0_parent(i1:i2,j1:j2) = ptab(i1:i2,j1:j2)
1752      ENDIF
1753      !
1754   END SUBROUTINE interpht0
1755
1756   SUBROUTINE Agrif_check_bat( iindic )
1757      !!----------------------------------------------------------------------
1758      !!                  ***  ROUTINE Agrif_check_bat  ***
1759      !!---------------------------------------------------------------------- 
1760      INTEGER, INTENT(inout) ::   iindic
1761      !!
1762      INTEGER :: ji, jj, jk
1763      INTEGER  :: istart, iend, jstart, jend, ispon
1764      !!---------------------------------------------------------------------- 
1765      !
1766      !
1767      ! --- West --- !
1768      IF(lk_west) THEN
1769         ispon  = nn_sponge_len * Agrif_irhox()
1770         istart = nn_hls + 2                                  ! halo + land + 1
1771         iend   = nn_hls + nbghostcells + ispon           ! halo + land + nbghostcells + sponge
1772         jstart = nn_hls + 2 
1773         jend   = jpjglo - nn_hls - 1 
1774         DO ji = mi0(istart), mi1(iend)
1775            DO jj = mj0(jstart), mj1(jend)
1776               IF ( ABS(ht0_parent(ji,jj)-ht_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
1777               IF ( .NOT.ln_vert_remap) THEN
1778                  DO jk = 1, jpkm1
1779                     IF ( ABS(e3t0_parent(ji,jj,jk)-e3t_0(ji,jj,jk))*tmask(ji,jj,jk) > 1.e-3 ) iindic = iindic + 1
1780                  END DO
1781               ENDIF
1782            END DO
1783            DO jj = mj0(jstart), mj1(jend-1)
1784               IF ( ABS(hv0_parent(ji,jj)-hv_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
1785               IF ( .NOT.ln_vert_remap) THEN
1786                  DO jk = 1, jpkm1
1787                     IF ( ABS(e3v0_parent(ji,jj,jk)-e3v_0(ji,jj,jk))*vmask(ji,jj,jk) > 1.e-3 ) iindic = iindic + 1
1788                  END DO
1789               ENDIF
1790            END DO
1791         END DO
1792         DO ji = mi0(istart), mi1(iend-1)
1793            DO jj = mj0(jstart), mj1(jend)
1794               IF ( ABS(hu0_parent(ji,jj)-hu_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
1795               IF ( .NOT.ln_vert_remap) THEN
1796                  DO jk = 1, jpkm1
1797                     IF ( ABS(e3u0_parent(ji,jj,jk)-e3u_0(ji,jj,jk))*umask(ji,jj,jk) > 1.e-3 ) iindic = iindic + 1
1798                  END DO
1799               ENDIF
1800            END DO
1801         END DO
1802      ENDIF
1803      !
1804      ! --- East --- !
1805      IF(lk_east) THEN
1806         ispon  = nn_sponge_len * Agrif_irhox() 
1807         istart = jpiglo - ( nn_hls + nbghostcells + ispon -1 )  ! halo + land + nbghostcells + sponge - 1
1808         iend   = jpiglo - nn_hls - 1                            ! halo + land + 1                     - 1
1809         jstart = nn_hls + 2 
1810         jend   = jpjglo - nn_hls - 1
1811         DO ji = mi0(istart), mi1(iend)
1812            DO jj = mj0(jstart), mj1(jend)
1813               IF ( ABS(ht0_parent(ji,jj)-ht_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
1814               IF ( .NOT.ln_vert_remap) THEN
1815                  DO jk = 1, jpkm1
1816                     IF ( ABS(e3t0_parent(ji,jj,jk)-e3t_0(ji,jj,jk))*tmask(ji,jj,jk) > 1.e-3 ) iindic = iindic + 1
1817                  END DO
1818               ENDIF
1819            END DO
1820            DO jj = mj0(jstart), mj1(jend-1)
1821               IF ( ABS(hv0_parent(ji,jj)-hv_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
1822               IF ( .NOT.ln_vert_remap) THEN
1823                  DO jk = 1, jpkm1
1824                     IF ( ABS(e3v0_parent(ji,jj,jk)-e3v_0(ji,jj,jk))*vmask(ji,jj,jk) > 1.e-3 ) iindic = iindic + 1
1825                  END DO
1826               ENDIF
1827            END DO
1828         END DO
1829         DO ji = mi0(istart), mi1(iend-1)
1830            DO jj = mj0(jstart), mj1(jend)
1831               IF ( ABS(hu0_parent(ji,jj)-hu_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
1832               IF ( .NOT.ln_vert_remap) THEN
1833                  DO jk = 1, jpkm1
1834                     IF ( ABS(e3u0_parent(ji,jj,jk)-e3u_0(ji,jj,jk))*umask(ji,jj,jk) > 1.e-3 ) iindic = iindic + 1
1835                  END DO
1836               ENDIF
1837            END DO
1838         END DO
1839      ENDIF
1840      !
1841      ! --- South --- !
1842      IF(lk_south) THEN
1843         ispon  = nn_sponge_len * Agrif_irhoy() 
1844         jstart = nn_hls + 2                                 ! halo + land + 1
1845         jend   = nn_hls + nbghostcells + ispon          ! halo + land + nbghostcells + sponge
1846         istart = nn_hls + 2 
1847         iend   = jpiglo - nn_hls - 1 
1848         DO jj = mj0(jstart), mj1(jend)
1849            DO ji = mi0(istart), mi1(iend)
1850               IF ( ABS(ht0_parent(ji,jj)-ht_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
1851               IF ( .NOT.ln_vert_remap) THEN
1852                  DO jk = 1, jpkm1
1853                     IF ( ABS(e3t0_parent(ji,jj,jk)-e3t_0(ji,jj,jk))*tmask(ji,jj,jk) > 1.e-3 ) iindic = iindic + 1
1854                  END DO
1855               ENDIF
1856            END DO
1857            DO ji = mi0(istart), mi1(iend-1)
1858               IF ( ABS(hu0_parent(ji,jj)-hu_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
1859               IF ( .NOT.ln_vert_remap) THEN
1860                  DO jk = 1, jpkm1
1861                     IF ( ABS(e3u0_parent(ji,jj,jk)-e3u_0(ji,jj,jk))*umask(ji,jj,jk) > 1.e-3 ) iindic = iindic + 1
1862                  END DO
1863               ENDIF
1864            END DO
1865         END DO
1866         DO jj = mj0(jstart), mj1(jend-1)
1867            DO ji = mi0(istart), mi1(iend)
1868               IF ( ABS(hv0_parent(ji,jj)-hv_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
1869               IF ( .NOT.ln_vert_remap) THEN
1870                  DO jk = 1, jpkm1
1871                     IF ( ABS(e3v0_parent(ji,jj,jk)-e3v_0(ji,jj,jk))*vmask(ji,jj,jk) > 1.e-3 ) iindic = iindic + 1
1872                  END DO
1873               ENDIF
1874            END DO
1875         END DO
1876      ENDIF
1877      !
1878      ! --- North --- !
1879      IF(lk_north) THEN
1880         ispon  = nn_sponge_len * Agrif_irhoy() 
1881         jstart = jpjglo - ( nn_hls + nbghostcells + ispon - 1)  ! halo + land + nbghostcells +sponge - 1
1882         jend   = jpjglo - nn_hls - 1                            ! halo + land + 1            - 1
1883         istart = nn_hls + 2 
1884         iend   = jpiglo - nn_hls - 1 
1885         DO jj = mj0(jstart), mj1(jend)
1886            DO ji = mi0(istart), mi1(iend)
1887               IF ( ABS(ht0_parent(ji,jj)-ht_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
1888               IF ( .NOT.ln_vert_remap) THEN
1889                  DO jk = 1, jpkm1
1890                     IF ( ABS(e3t0_parent(ji,jj,jk)-e3t_0(ji,jj,jk))*tmask(ji,jj,jk) > 1.e-3 ) iindic = iindic + 1
1891                  END DO
1892               ENDIF
1893            END DO
1894            DO ji = mi0(istart), mi1(iend-1)
1895               IF ( ABS(hu0_parent(ji,jj)-hu_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
1896               IF ( .NOT.ln_vert_remap) THEN
1897                  DO jk = 1, jpkm1
1898                     IF ( ABS(e3u0_parent(ji,jj,jk)-e3u_0(ji,jj,jk))*umask(ji,jj,jk) > 1.e-3 ) iindic = iindic + 1
1899                  END DO
1900               ENDIF
1901            END DO
1902         END DO
1903         DO jj = mj0(jstart), mj1(jend-1)
1904            DO ji = mi0(istart), mi1(iend)
1905               IF ( ABS(hv0_parent(ji,jj)-hv_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
1906               IF ( .NOT.ln_vert_remap) THEN
1907                  DO jk = 1, jpkm1
1908                     IF ( ABS(e3v0_parent(ji,jj,jk)-e3v_0(ji,jj,jk))*vmask(ji,jj,jk) > 1.e-3 ) iindic = iindic + 1
1909                  END DO
1910               ENDIF
1911            END DO
1912         END DO
1913      ENDIF
1914      !
1915   END SUBROUTINE Agrif_check_bat
1916   
1917#else
1918   !!----------------------------------------------------------------------
1919   !!   Empty module                                          no AGRIF zoom
1920   !!----------------------------------------------------------------------
1921CONTAINS
1922   SUBROUTINE Agrif_OCE_Interp_empty
1923      WRITE(*,*)  'agrif_oce_interp : You should not have seen this print! error?'
1924   END SUBROUTINE Agrif_OCE_Interp_empty
1925#endif
1926
1927   !!======================================================================
1928END MODULE agrif_oce_interp
Note: See TracBrowser for help on using the repository browser.