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_oce_interp.F90 in NEMO/branches/2020/dev_r13312_AGRIF-03-04_jchanut_vinterp_tstep/src/NST – NEMO

source: NEMO/branches/2020/dev_r13312_AGRIF-03-04_jchanut_vinterp_tstep/src/NST/agrif_oce_interp.F90 @ 13334

Last change on this file since 13334 was 13334, checked in by jchanut, 4 years ago

finish bypassing ocean/ice initialization with AGRIF, #2222, #2129
  • Property svn:keywords set to Id
File size: 59.4 KB
Line 
1MODULE agrif_oce_interp
2   !!======================================================================
3   !!                   ***  MODULE  agrif_oce_interp  ***
4   !! AGRIF: interpolation package for the ocean dynamics (OPA)
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   interpe3t, interpglamt, interpgphit
47   PUBLIC   interpht0, interpmbkt
48   PUBLIC   agrif_istate_oce, agrif_istate_ssh   ! called by icestate.F90 and domvvl.F90
49
50   INTEGER ::   bdy_tinterp = 0
51
52   !!----------------------------------------------------------------------
53   !! NEMO/NST 4.0 , NEMO Consortium (2018)
54   !! $Id$
55   !! Software governed by the CeCILL license (see ./LICENSE)
56   !!----------------------------------------------------------------------
57CONTAINS
58
59   SUBROUTINE Agrif_istate_oce( Kbb, Kmm, Kaa )
60      !!----------------------------------------------------------------------
61      !!                 *** ROUTINE agrif_istate_oce ***
62      !!
63      !!                 set initial t, s, u, v, ssh from parent
64      !!----------------------------------------------------------------------
65      !
66      IMPLICIT NONE
67      !
68      INTEGER, INTENT(in)  :: Kbb, Kmm, Kaa
69      INTEGER :: jn
70      !!----------------------------------------------------------------------
71      IF(lwp) WRITE(numout,*) ' '
72      IF(lwp) WRITE(numout,*) 'Agrif_istate_oce : interp child initial state from parent'
73      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~~'
74      IF(lwp) WRITE(numout,*) ' '
75
76      IF ( ln_rstart ) & 
77         & CALL ctl_stop('AGRIF hot start should be desactivated in restarting mode')
78
79      IF ( .NOT.Agrif_Parent(ln_1st_euler) ) & 
80         & CALL ctl_stop('AGRIF hot start requires to force Euler first step on parent')
81
82      l_ini_child           = .TRUE.
83      Agrif_SpecialValue    = 0.0_wp
84      Agrif_UseSpecialValue = .TRUE.
85
86      ts(:,:,:,:,:) = 0.0_wp
87      uu(:,:,:,:)   = 0.0_wp
88      vv(:,:,:,:)   = 0.0_wp 
89      ssh(:,:,:)    = 0._wp
90       
91      Krhs_a = Kbb   ;   Kmm_a = Kbb
92
93      CALL Agrif_Init_Variable(tsini_id, procname=interptsn)
94      CALL Agrif_Init_Variable(sshini_id, procname=interpsshn)
95
96      Agrif_UseSpecialValue = ln_spc_dyn
97      use_sign_north = .TRUE.
98      sign_north = -1._wp
99      CALL Agrif_Init_Variable(uini_id , procname=interpun )
100      CALL Agrif_Init_Variable(vini_id , procname=interpvn )
101      use_sign_north = .FALSE.
102
103      Agrif_UseSpecialValue = .FALSE.
104      l_ini_child           = .FALSE.
105
106      Krhs_a = Kaa   ;   Kmm_a = Kmm
107
108      ssh(:,:,Kbb) = ssh(:,:,Kbb) * tmask(:,:,1)
109
110      DO jn = 1, jpts
111         ts(:,:,:,jn,Kbb) = ts(:,:,:,jn,Kbb) * tmask(:,:,:)
112      END DO
113      uu(:,:,:,Kbb) = uu(:,:,:,Kbb) * umask(:,:,:)     
114      vv(:,:,:,Kbb) = vv(:,:,:,Kbb) * vmask(:,:,:) 
115
116      CALL lbc_lnk_multi( 'agrif_istate_oce', uu(:,:,:  ,Kbb), 'U', -1.0_wp , vv(:,:,:,Kbb), 'V', -1.0_wp )
117      CALL lbc_lnk( 'agrif_istate_oce', ts(:,:,:,:,Kbb), 'T',  1.0_wp )
118      CALL lbc_lnk( 'agrif_istate_oce', ssh(:,:,Kbb), 'T', 1.0_wp )
119
120   END SUBROUTINE Agrif_istate_oce
121
122   SUBROUTINE Agrif_istate_ssh( Kbb, Kmm )
123      !!----------------------------------------------------------------------
124      !!                 *** ROUTINE agrif_istate_ssh ***
125      !!
126      !!                    set initial ssh from parent
127      !!----------------------------------------------------------------------
128      !
129      IMPLICIT NONE
130      !
131      INTEGER, INTENT(in)  :: Kbb, Kmm 
132      !!----------------------------------------------------------------------
133      IF(lwp) WRITE(numout,*) ' '
134      IF(lwp) WRITE(numout,*) 'Agrif_istate_ssh : interp child ssh from parent'
135      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~~'
136      IF(lwp) WRITE(numout,*) ' '
137
138      IF ( ln_rstart ) & 
139         & CALL ctl_stop('AGRIF hot start should be desactivated in restarting mode')
140
141      IF ( .NOT.Agrif_Parent(ln_1st_euler) ) & 
142         & CALL ctl_stop('AGRIF hot start requires to force Euler first step on parent')
143
144      Kmm_a = Kmm
145      ssh(:,:,Kmm) = 0._wp
146      l_ini_child = .TRUE.
147      Agrif_SpecialValue    = 0._wp
148      Agrif_UseSpecialValue = .TRUE.
149      CALL Agrif_Init_Variable(sshini_id, procname=interpsshn)
150      Agrif_UseSpecialValue = .FALSE.
151      l_ini_child = .FALSE.
152      CALL lbc_lnk( 'dom_vvl_rst', ssh(:,:,Kmm), 'T', 1._wp )
153
154   END SUBROUTINE Agrif_istate_ssh
155
156
157   SUBROUTINE Agrif_tra
158      !!----------------------------------------------------------------------
159      !!                  ***  ROUTINE Agrif_tra  ***
160      !!----------------------------------------------------------------------
161      !
162      IF( Agrif_Root() )   RETURN
163      !
164      Agrif_SpecialValue    = 0._wp
165      Agrif_UseSpecialValue = .TRUE.
166      !
167      CALL Agrif_Bc_variable( tsn_id, procname=interptsn )
168      !
169      Agrif_UseSpecialValue = .FALSE.
170      !
171   END SUBROUTINE Agrif_tra
172
173
174   SUBROUTINE Agrif_dyn( kt )
175      !!----------------------------------------------------------------------
176      !!                  ***  ROUTINE Agrif_DYN  ***
177      !!---------------------------------------------------------------------- 
178      INTEGER, INTENT(in) ::   kt
179      !
180      INTEGER ::   ji, jj, jk       ! dummy loop indices
181      INTEGER ::   ibdy1, jbdy1, ibdy2, jbdy2
182      REAL(wp), DIMENSION(jpi,jpj) ::   zub, zvb
183      !!---------------------------------------------------------------------- 
184      !
185      IF( Agrif_Root() )   RETURN
186      !
187      Agrif_SpecialValue    = 0.0_wp
188      Agrif_UseSpecialValue = ln_spc_dyn
189      !
190      use_sign_north = .TRUE.
191      sign_north = -1.0_wp
192      CALL Agrif_Bc_variable( un_interp_id, procname=interpun )
193      CALL Agrif_Bc_variable( vn_interp_id, procname=interpvn )
194      use_sign_north = .FALSE.
195      !
196      Agrif_UseSpecialValue = .FALSE.
197      !
198      ! --- West --- !
199      IF( lk_west ) THEN
200         ibdy1 = nn_hls + 2                  ! halo + land + 1
201         ibdy2 = nn_hls + 1 + nbghostcells   ! halo + land + nbghostcells
202         !
203         IF( .NOT.ln_dynspg_ts ) THEN  ! Store transport
204            DO ji = mi0(ibdy1), mi1(ibdy2)
205               uu_b(ji,:,Krhs_a) = 0._wp
206               DO jk = 1, jpkm1
207                  DO jj = 1, jpj
208                     uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk)
209                  END DO
210               END DO
211               DO jj = 1, jpj
212                  uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) * r1_hu(ji,jj,Krhs_a)
213               END DO
214            END DO
215         ENDIF
216         !
217         DO ji = mi0(ibdy1), mi1(ibdy2)
218            zub(ji,:) = 0._wp    ! Correct transport
219            DO jk = 1, jpkm1
220               DO jj = 1, jpj
221                  zub(ji,jj) = zub(ji,jj) + e3u(ji,jj,jk,Krhs_a)  * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk)
222               END DO
223            END DO
224            DO jj=1,jpj
225               zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a)
226            END DO
227            DO jk = 1, jpkm1
228               DO jj = 1, jpj
229                  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)
230               END DO
231            END DO
232         END DO
233         !   
234         IF( ln_dynspg_ts ) THEN       ! Set tangential velocities to time splitting estimate
235            DO ji = mi0(ibdy1), mi1(ibdy2)
236               zvb(ji,:) = 0._wp
237               DO jk = 1, jpkm1
238                  DO jj = 1, jpj
239                     zvb(ji,jj) = zvb(ji,jj) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk)
240                  END DO
241               END DO
242               DO jj = 1, jpj
243                  zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a)
244               END DO
245               DO jk = 1, jpkm1
246                  DO jj = 1, jpj
247                     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)
248                  END DO
249               END DO
250            END DO
251         ENDIF
252         !
253      ENDIF
254
255      ! --- East --- !
256      IF( lk_east) THEN
257         ibdy1 = jpiglo - ( nn_hls + nbghostcells + 1)   ! halo + land + nbghostcells
258         ibdy2 = jpiglo - ( nn_hls + 2 )                 ! halo + land + 1
259         !
260         IF( .NOT.ln_dynspg_ts ) THEN  ! Store transport
261            DO ji = mi0(ibdy1), mi1(ibdy2)
262               uu_b(ji,:,Krhs_a) = 0._wp
263               DO jk = 1, jpkm1
264                  DO jj = 1, jpj
265                     uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk)
266                  END DO
267               END DO
268               DO jj = 1, jpj
269                  uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) * r1_hu(ji,jj,Krhs_a)
270               END DO
271            END DO
272         ENDIF
273         !
274         DO ji = mi0(ibdy1), mi1(ibdy2)
275            zub(ji,:) = 0._wp    ! Correct transport
276            DO jk = 1, jpkm1
277               DO jj = 1, jpj
278                  zub(ji,jj) = zub(ji,jj) + e3u(ji,jj,jk,Krhs_a)  * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk)
279               END DO
280            END DO
281            DO jj=1,jpj
282               zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a)
283            END DO
284            DO jk = 1, jpkm1
285               DO jj = 1, jpj
286                  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)
287               END DO
288            END DO
289         END DO
290         !
291         IF( ln_dynspg_ts ) THEN       ! Set tangential velocities to time splitting estimate
292            ibdy1 = jpiglo - ( nn_hls + nbghostcells )   ! halo + land + nbghostcells - 1
293            ibdy2 = jpiglo - ( nn_hls + 1 )              ! halo + land + 1            - 1
294            DO ji = mi0(ibdy1), mi1(ibdy2)
295               zvb(ji,:) = 0._wp
296               DO jk = 1, jpkm1
297                  DO jj = 1, jpj
298                     zvb(ji,jj) = zvb(ji,jj) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk)
299                  END DO
300               END DO
301               DO jj = 1, jpj
302                  zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a)
303               END DO
304               DO jk = 1, jpkm1
305                  DO jj = 1, jpj
306                     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)
307                  END DO
308               END DO
309            END DO
310         ENDIF
311         !
312      ENDIF
313
314      ! --- South --- !
315      IF( lk_south ) THEN
316         jbdy1 = nn_hls + 2                  ! halo + land + 1
317         jbdy2 = nn_hls + 1 + nbghostcells   ! halo + land + nbghostcells
318         !
319         IF( .NOT.ln_dynspg_ts ) THEN  ! Store transport
320            DO jj = mj0(jbdy1), mj1(jbdy2)
321               vv_b(:,jj,Krhs_a) = 0._wp
322               DO jk = 1, jpkm1
323                  DO ji = 1, jpi
324                     vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk)
325                  END DO
326               END DO
327               DO ji=1,jpi
328                  vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) * r1_hv(ji,jj,Krhs_a)     
329               END DO
330            END DO
331         ENDIF
332         !
333         DO jj = mj0(jbdy1), mj1(jbdy2)
334            zvb(:,jj) = 0._wp    ! Correct transport
335            DO jk=1,jpkm1
336               DO ji=1,jpi
337                  zvb(ji,jj) = zvb(ji,jj) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk)
338               END DO
339            END DO
340            DO ji = 1, jpi
341               zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a)
342            END DO
343            DO jk = 1, jpkm1
344               DO ji = 1, jpi
345                  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)
346               END DO
347            END DO
348         END DO
349         !
350         IF( ln_dynspg_ts ) THEN       ! Set tangential velocities to time splitting estimate
351            DO jj = mj0(jbdy1), mj1(jbdy2)
352               zub(:,jj) = 0._wp
353               DO jk = 1, jpkm1
354                  DO ji = 1, jpi
355                     zub(ji,jj) = zub(ji,jj) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk)
356                  END DO
357               END DO
358               DO ji = 1, jpi
359                  zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a)
360               END DO
361               DO jk = 1, jpkm1
362                  DO ji = 1, jpi
363                     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)
364                  END DO
365               END DO
366            END DO
367         ENDIF
368         !
369      ENDIF
370
371      ! --- North --- !
372      IF( lk_north ) THEN
373         jbdy1 = jpjglo - ( nn_hls + nbghostcells + 1)   ! halo + land + nbghostcells
374         jbdy2 = jpjglo - ( nn_hls + 2 )                 ! halo + land + 1
375         !
376         IF( .NOT.ln_dynspg_ts ) THEN  ! Store transport
377            DO jj = mj0(jbdy1), mj1(jbdy2)
378               vv_b(:,jj,Krhs_a) = 0._wp
379               DO jk = 1, jpkm1
380                  DO ji = 1, jpi
381                     vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk)
382                  END DO
383               END DO
384               DO ji=1,jpi
385                  vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) * r1_hv(ji,jj,Krhs_a)
386               END DO
387            END DO
388         ENDIF
389         !
390         DO jj = mj0(jbdy1), mj1(jbdy2)
391            zvb(:,jj) = 0._wp    ! Correct transport
392            DO jk=1,jpkm1
393               DO ji=1,jpi
394                  zvb(ji,jj) = zvb(ji,jj) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk)
395               END DO
396            END DO
397            DO ji = 1, jpi
398               zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a)
399            END DO
400            DO jk = 1, jpkm1
401               DO ji = 1, jpi
402                  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)
403               END DO
404            END DO
405         END DO
406         !
407         IF( ln_dynspg_ts ) THEN       ! Set tangential velocities to time splitting estimate
408            jbdy1 = jpjglo - ( nn_hls + nbghostcells )   ! halo + land + nbghostcells - 1
409            jbdy2 = jpjglo - ( nn_hls + 1 )              ! halo + land + 1            - 1
410            DO jj = mj0(jbdy1), mj1(jbdy2)
411               zub(:,jj) = 0._wp
412               DO jk = 1, jpkm1
413                  DO ji = 1, jpi
414                     zub(ji,jj) = zub(ji,jj) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk)
415                  END DO
416               END DO
417               DO ji = 1, jpi
418                  zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a)
419               END DO
420               DO jk = 1, jpkm1
421                  DO ji = 1, jpi
422                     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)
423                  END DO
424               END DO
425            END DO
426         ENDIF
427         !
428      ENDIF
429      !
430   END SUBROUTINE Agrif_dyn
431
432
433   SUBROUTINE Agrif_dyn_ts( jn )
434      !!----------------------------------------------------------------------
435      !!                  ***  ROUTINE Agrif_dyn_ts  ***
436      !!---------------------------------------------------------------------- 
437      INTEGER, INTENT(in) ::   jn
438      !!
439      INTEGER :: ji, jj
440      INTEGER :: istart, iend, jstart, jend
441      !!---------------------------------------------------------------------- 
442      !
443      IF( Agrif_Root() )   RETURN
444      !
445      !--- West ---!
446      IF( lk_west ) THEN
447         istart = nn_hls + 2                              ! halo + land + 1
448         iend   = nn_hls + 1 + nbghostcells               ! halo + land + nbghostcells
449         DO ji = mi0(istart), mi1(iend)
450            DO jj=1,jpj
451               va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj)
452               ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj)
453            END DO
454         END DO
455      ENDIF
456      !
457      !--- East ---!
458      IF( lk_east ) THEN
459         istart = jpiglo - ( nn_hls + nbghostcells )      ! halo + land + nbghostcells - 1
460         iend   = jpiglo - ( nn_hls + 1 )                 ! halo + land + 1            - 1
461         DO ji = mi0(istart), mi1(iend)
462
463            DO jj=1,jpj
464               va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj)
465            END DO
466         END DO
467         istart = jpiglo - ( nn_hls + nbghostcells + 1)   ! halo + land + nbghostcells
468         iend   = jpiglo - ( nn_hls + 2 )                 ! halo + land + 1
469         DO ji = mi0(istart), mi1(iend)
470            DO jj=1,jpj
471               ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj)
472            END DO
473         END DO
474      ENDIF 
475      !
476      !--- South ---!
477      IF( lk_south ) THEN
478         jstart = nn_hls + 2                              ! halo + land + 1
479         jend   = nn_hls + 1 + nbghostcells               ! halo + land + nbghostcells
480         DO jj = mj0(jstart), mj1(jend)
481
482            DO ji=1,jpi
483               ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj)
484               va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj)
485            END DO
486         END DO
487      ENDIF       
488      !
489      !--- North ---!
490      IF( lk_north ) THEN
491         jstart = jpjglo - ( nn_hls + nbghostcells )      ! halo + land + nbghostcells - 1
492         jend   = jpjglo - ( nn_hls + 1 )                 ! halo + land + 1            - 1
493         DO jj = mj0(jstart), mj1(jend)
494            DO ji=1,jpi
495               ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj)
496            END DO
497         END DO
498         jstart = jpjglo - ( nn_hls + nbghostcells + 1)   ! halo + land + nbghostcells
499         jend   = jpjglo - ( nn_hls + 2 )                 ! halo + land + 1
500         DO jj = mj0(jstart), mj1(jend)
501            DO ji=1,jpi
502               va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj)
503            END DO
504         END DO
505      ENDIF 
506      !
507   END SUBROUTINE Agrif_dyn_ts
508
509   
510   SUBROUTINE Agrif_dyn_ts_flux( jn, zu, zv )
511      !!----------------------------------------------------------------------
512      !!                  ***  ROUTINE Agrif_dyn_ts_flux  ***
513      !!---------------------------------------------------------------------- 
514      INTEGER, INTENT(in) ::   jn
515      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   zu, zv
516      !!
517      INTEGER :: ji, jj
518      INTEGER :: istart, iend, jstart, jend
519      !!---------------------------------------------------------------------- 
520      !
521      IF( Agrif_Root() )   RETURN
522      !
523      !--- West ---!
524      IF( lk_west ) THEN
525         istart = nn_hls + 2                              ! halo + land + 1
526         iend   = nn_hls + 1 + nbghostcells               ! halo + land + nbghostcells
527         DO ji = mi0(istart), mi1(iend)
528            DO jj=1,jpj
529               zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj)
530               zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj)
531            END DO
532         END DO
533      ENDIF
534      !
535      !--- East ---!
536      IF( lk_east ) THEN
537         istart = jpiglo - ( nn_hls + nbghostcells )      ! halo + land + nbghostcells - 1
538         iend   = jpiglo - ( nn_hls + 1 )                 ! halo + land + 1            - 1
539         DO ji = mi0(istart), mi1(iend)
540            DO jj=1,jpj
541               zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj)
542            END DO
543         END DO
544         istart = jpiglo - ( nn_hls + nbghostcells + 1)   ! halo + land + nbghostcells
545         iend   = jpiglo - ( nn_hls + 2 )                 ! halo + land + 1
546         DO ji = mi0(istart), mi1(iend)
547            DO jj=1,jpj
548               zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj)
549            END DO
550         END DO
551      ENDIF
552      !
553      !--- South ---!
554      IF( lk_south ) THEN
555         jstart = nn_hls + 2                              ! halo + land + 1
556         jend   = nn_hls + 1 + nbghostcells               ! halo + land + nbghostcells
557         DO jj = mj0(jstart), mj1(jend)
558            DO ji=1,jpi
559               zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj)
560               zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj)
561            END DO
562         END DO
563      ENDIF
564      !
565      !--- North ---!
566      IF( lk_north ) THEN
567         jstart = jpjglo - ( nn_hls + nbghostcells )      ! halo + land + nbghostcells - 1
568         jend   = jpjglo - ( nn_hls + 1 )                 ! halo + land + 1            - 1
569         DO jj = mj0(jstart), mj1(jend)
570            DO ji=1,jpi
571               zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj)
572            END DO
573         END DO
574         jstart = jpjglo - ( nn_hls + nbghostcells + 1)   ! halo + land + nbghostcells
575         jend   = jpjglo - ( nn_hls + 2 )                 ! halo + land + 1
576         DO jj = mj0(jstart), mj1(jend)
577            DO ji=1,jpi
578               zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj)
579            END DO
580         END DO
581      ENDIF
582      !
583   END SUBROUTINE Agrif_dyn_ts_flux
584
585   
586   SUBROUTINE Agrif_dta_ts( kt )
587      !!----------------------------------------------------------------------
588      !!                  ***  ROUTINE Agrif_dta_ts  ***
589      !!---------------------------------------------------------------------- 
590      INTEGER, INTENT(in) ::   kt
591      !!
592      INTEGER :: ji, jj
593      LOGICAL :: ll_int_cons
594      !!---------------------------------------------------------------------- 
595      !
596      IF( Agrif_Root() )   RETURN
597      !
598      ll_int_cons = ln_bt_fw ! Assume conservative temporal integration in the forward case only
599      !
600      ! Enforce volume conservation if no time refinement: 
601      IF ( Agrif_rhot()==1 ) ll_int_cons=.TRUE. 
602      !
603      ! Interpolate barotropic fluxes
604      Agrif_SpecialValue = 0._wp
605      Agrif_UseSpecialValue = ln_spc_dyn
606
607      use_sign_north = .TRUE.
608      sign_north = -1.
609
610      !
611      ! Set bdy time interpolation stage to 0 (latter incremented locally do deal with corners)
612      utint_stage(:,:) = 0
613      vtint_stage(:,:) = 0
614      !
615      IF( ll_int_cons ) THEN  ! Conservative interpolation
616         ! order matters here !!!!!!
617         CALL Agrif_Bc_variable( ub2b_interp_id, calledweight=1._wp, procname=interpub2b ) ! Time integrated
618         CALL Agrif_Bc_variable( vb2b_interp_id, calledweight=1._wp, procname=interpvb2b ) 
619         !
620         bdy_tinterp = 1
621         CALL Agrif_Bc_variable( unb_id        , calledweight=1._wp, procname=interpunb  ) ! After
622         CALL Agrif_Bc_variable( vnb_id        , calledweight=1._wp, procname=interpvnb  ) 
623         !
624         bdy_tinterp = 2
625         CALL Agrif_Bc_variable( unb_id        , calledweight=0._wp, procname=interpunb  ) ! Before
626         CALL Agrif_Bc_variable( vnb_id        , calledweight=0._wp, procname=interpvnb  )   
627      ELSE ! Linear interpolation
628         !
629         ubdy(:,:) = 0._wp   ;   vbdy(:,:) = 0._wp 
630         CALL Agrif_Bc_variable( unb_id, procname=interpunb )
631         CALL Agrif_Bc_variable( vnb_id, procname=interpvnb )
632      ENDIF
633      Agrif_UseSpecialValue = .FALSE.
634      use_sign_north = .FALSE.
635      !
636   END SUBROUTINE Agrif_dta_ts
637
638
639   SUBROUTINE Agrif_ssh( kt )
640      !!----------------------------------------------------------------------
641      !!                  ***  ROUTINE Agrif_ssh  ***
642      !!---------------------------------------------------------------------- 
643      INTEGER, INTENT(in) ::   kt
644      !
645      INTEGER  :: ji, jj
646      INTEGER  :: istart, iend, jstart, jend
647      !!---------------------------------------------------------------------- 
648      !
649      IF( Agrif_Root() )   RETURN
650      !     
651      ! Linear time interpolation of sea level
652      !
653      Agrif_SpecialValue    = 0._wp
654      Agrif_UseSpecialValue = .TRUE.
655      CALL Agrif_Bc_variable(sshn_id, procname=interpsshn )
656      Agrif_UseSpecialValue = .FALSE.
657      !
658      ! --- West --- !
659      IF(lk_west) THEN
660         istart = nn_hls + 2                              ! halo + land + 1
661         iend   = nn_hls + 1 + nbghostcells               ! halo + land + nbghostcells
662         DO ji = mi0(istart), mi1(iend)
663            DO jj = 1, jpj
664               ssh(ji,jj,Krhs_a) = hbdy(ji,jj)
665            END DO
666         END DO
667      ENDIF
668      !
669      ! --- East --- !
670      IF(lk_east) THEN
671         istart = jpiglo - ( nn_hls + nbghostcells )      ! halo + land + nbghostcells - 1
672         iend   = jpiglo - ( nn_hls + 1 )                 ! halo + land + 1            - 1
673         DO ji = mi0(istart), mi1(iend)
674            DO jj = 1, jpj
675               ssh(ji,jj,Krhs_a) = hbdy(ji,jj)
676            END DO
677         END DO
678      ENDIF
679      !
680      ! --- South --- !
681      IF(lk_south) THEN
682         jstart = nn_hls + 2                              ! halo + land + 1
683         jend   = nn_hls + 1 + nbghostcells               ! halo + land + nbghostcells
684         DO jj = mj0(jstart), mj1(jend)
685            DO ji = 1, jpi
686               ssh(ji,jj,Krhs_a) = hbdy(ji,jj)
687            END DO
688         END DO
689      ENDIF
690      !
691      ! --- North --- !
692      IF(lk_north) THEN
693         jstart = jpjglo - ( nn_hls + nbghostcells )      ! halo + land + nbghostcells - 1
694         jend   = jpjglo - ( nn_hls + 1 )                 ! halo + land + 1            - 1
695         DO jj = mj0(jstart), mj1(jend)
696            DO ji = 1, jpi
697               ssh(ji,jj,Krhs_a) = hbdy(ji,jj)
698            END DO
699         END DO
700      ENDIF
701      !
702   END SUBROUTINE Agrif_ssh
703
704
705   SUBROUTINE Agrif_ssh_ts( jn )
706      !!----------------------------------------------------------------------
707      !!                  ***  ROUTINE Agrif_ssh_ts  ***
708      !!---------------------------------------------------------------------- 
709      INTEGER, INTENT(in) ::   jn
710      !!
711      INTEGER :: ji, jj
712      INTEGER  :: istart, iend, jstart, jend
713      !!---------------------------------------------------------------------- 
714      !
715      IF( Agrif_Root() )   RETURN
716      !
717      ! --- West --- !
718      IF(lk_west) THEN
719         istart = nn_hls + 2                              ! halo + land + 1
720         iend   = nn_hls + 1 + nbghostcells               ! halo + land + nbghostcells
721         DO ji = mi0(istart), mi1(iend)
722            DO jj = 1, jpj
723               ssha_e(ji,jj) = hbdy(ji,jj)
724            END DO
725         END DO
726      ENDIF
727      !
728      ! --- East --- !
729      IF(lk_east) THEN
730         istart = jpiglo - ( nn_hls + nbghostcells )      ! halo + land + nbghostcells - 1
731         iend   = jpiglo - ( nn_hls + 1 )                 ! halo + land + 1            - 1
732         DO ji = mi0(istart), mi1(iend)
733            DO jj = 1, jpj
734               ssha_e(ji,jj) = hbdy(ji,jj)
735            END DO
736         END DO
737      ENDIF
738      !
739      ! --- South --- !
740      IF(lk_south) THEN
741         jstart = nn_hls + 2                              ! halo + land + 1
742         jend   = nn_hls + 1 + nbghostcells               ! halo + land + nbghostcells
743         DO jj = mj0(jstart), mj1(jend)
744            DO ji = 1, jpi
745               ssha_e(ji,jj) = hbdy(ji,jj)
746            END DO
747         END DO
748      ENDIF
749      !
750      ! --- North --- !
751      IF(lk_north) THEN
752         jstart = jpjglo - ( nn_hls + nbghostcells )      ! halo + land + nbghostcells - 1
753         jend   = jpjglo - ( nn_hls + 1 )                 ! halo + land + 1            - 1
754         DO jj = mj0(jstart), mj1(jend)
755            DO ji = 1, jpi
756               ssha_e(ji,jj) = hbdy(ji,jj)
757            END DO
758         END DO
759      ENDIF
760      !
761   END SUBROUTINE Agrif_ssh_ts
762
763   
764   SUBROUTINE Agrif_avm
765      !!----------------------------------------------------------------------
766      !!                  ***  ROUTINE Agrif_avm  ***
767      !!---------------------------------------------------------------------- 
768      REAL(wp) ::   zalpha
769      !!---------------------------------------------------------------------- 
770      !
771      IF( Agrif_Root() )   RETURN
772      !
773      zalpha = 1._wp ! JC: proper time interpolation impossible 
774                     ! => use last available value from parent
775      !
776      Agrif_SpecialValue    = 0.e0
777      Agrif_UseSpecialValue = .TRUE.
778      !
779      CALL Agrif_Bc_variable( avm_id, calledweight=zalpha, procname=interpavm )       
780      !
781      Agrif_UseSpecialValue = .FALSE.
782      !
783   END SUBROUTINE Agrif_avm
784
785
786   SUBROUTINE interptsn( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before )
787      !!----------------------------------------------------------------------
788      !!                  *** ROUTINE interptsn ***
789      !!----------------------------------------------------------------------
790      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) ::   ptab
791      INTEGER                                     , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2, n1, n2
792      LOGICAL                                     , INTENT(in   ) ::   before
793      !
794      INTEGER  ::   ji, jj, jk, jn  ! dummy loop indices
795      INTEGER  ::   N_in, N_out
796      INTEGER  :: item
797      ! vertical interpolation:
798      REAL(wp) :: zhtot
799      REAL(wp), DIMENSION(k1:k2,1:jpts) :: tabin
800      REAL(wp), DIMENSION(k1:k2) :: h_in, z_in
801      REAL(wp), DIMENSION(1:jpk) :: h_out, z_out
802      !!----------------------------------------------------------------------
803
804      IF( before ) THEN
805
806         item = Kmm_a
807         IF( l_ini_child )   Kmm_a = Kbb_a 
808
809         DO jn = 1,jpts
810            DO jk=k1,k2
811               DO jj=j1,j2
812                 DO ji=i1,i2
813                       ptab(ji,jj,jk,jn) = ts(ji,jj,jk,jn,Kmm_a)
814                 END DO
815              END DO
816           END DO
817         END DO
818
819         IF( l_vremap .OR. l_ini_child) THEN
820            ! Interpolate thicknesses
821            ! Warning: these are masked, hence extrapolated prior interpolation.
822            DO jk=k1,k2
823               DO jj=j1,j2
824                  DO ji=i1,i2
825                      ptab(ji,jj,jk,jpts+1) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm_a)
826
827                  END DO
828               END DO
829            END DO
830
831            ! Extrapolate thicknesses in partial bottom cells:
832            ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on
833            IF (ln_zps) THEN
834               DO jj=j1,j2
835                  DO ji=i1,i2
836                      jk = mbkt(ji,jj)
837                      ptab(ji,jj,jk,jpts+1) = 0._wp
838                  END DO
839               END DO           
840            END IF
841       
842            ! Save ssh at last level:
843            IF (.NOT.ln_linssh) THEN
844               ptab(i1:i2,j1:j2,k2,jpts+1) = ssh(i1:i2,j1:j2,Kmm_a)*tmask(i1:i2,j1:j2,1) 
845            ELSE
846               ptab(i1:i2,j1:j2,k2,jpts+1) = 0._wp
847            END IF     
848         ENDIF
849         Kmm_a = item
850
851      ELSE
852         item = Krhs_a
853         IF( l_ini_child )   Krhs_a = Kbb_a 
854
855         IF( l_vremap .OR. l_ini_child ) THEN
856            IF (ln_linssh) ptab(i1:i2,j1:j2,k2,n2) = 0._wp 
857               
858            DO jj=j1,j2
859               DO ji=i1,i2
860                  ts(ji,jj,:,:,Krhs_a) = 0.                 
861               !   IF( l_ini_child) ts(ji,jj,:,:,Krhs_a) = ptab(ji,jj,:,1:jpts)
862                  N_in = mbkt_parent(ji,jj)
863                  zhtot = 0._wp
864                  DO jk=1,N_in !k2 = jpk of parent grid
865                     IF (jk==N_in) THEN
866                        h_in(jk) = ht0_parent(ji,jj) + ptab(ji,jj,k2,n2) - zhtot
867                     ELSE
868                        h_in(jk) = ptab(ji,jj,jk,n2)
869                     ENDIF
870                     zhtot = zhtot + h_in(jk)
871                     tabin(jk,:) = ptab(ji,jj,jk,n1:n2-1)
872                  END DO
873                  z_in(1) = 0.5_wp * h_in(1) - zhtot + ht0_parent(ji,jj)
874                  DO jk=2,N_in
875                     z_in(jk) = z_in(jk-1) + 0.5_wp * h_in(jk)
876                  END DO
877
878                  N_out = 0
879                  DO jk=1,jpk ! jpk of child grid
880                     IF (tmask(ji,jj,jk) == 0._wp) EXIT
881                     N_out = N_out + 1
882                     h_out(jk) = e3t(ji,jj,jk,Krhs_a)
883                  END DO
884
885                  z_out(1) = 0.5_wp * h_out(1) - SUM(h_out(1:N_out)) + ht_0(ji,jj)
886                  DO jk=2,N_out
887                     z_out(jk) = z_out(jk-1) + 0.5_wp * h_out(jk)
888                  END DO
889
890                  IF (N_in*N_out > 0) THEN
891                     IF( l_ini_child ) THEN
892                        CALL remap_linear(tabin(1:N_in,1:jpts),z_in(1:N_in),ts(ji,jj,1:N_out,1:jpts,Krhs_a),          &
893                                      &   z_out(1:N_out),N_in,N_out,jpts) 
894                     ELSE
895                        CALL reconstructandremap(tabin(1:N_in,1:jpts),h_in(1:N_in),ts(ji,jj,1:N_out,1:jpts,Krhs_a),   &
896                                      &   h_out(1:N_out),N_in,N_out,jpts) 
897                     ENDIF
898                  ENDIF
899               END DO
900            END DO
901            Krhs_a = item
902 
903         ELSE
904         
905            DO jn=1, jpts
906                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) 
907            END DO
908         ENDIF
909
910      ENDIF
911      !
912   END SUBROUTINE interptsn
913
914   
915   SUBROUTINE interpsshn( ptab, i1, i2, j1, j2, before )
916      !!----------------------------------------------------------------------
917      !!                  ***  ROUTINE interpsshn  ***
918      !!---------------------------------------------------------------------- 
919      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
920      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
921      LOGICAL                         , INTENT(in   ) ::   before
922      !
923      !!---------------------------------------------------------------------- 
924      !
925      IF( before) THEN
926         ptab(i1:i2,j1:j2) = ssh(i1:i2,j1:j2,Kmm_a)
927      ELSE
928         IF( l_ini_child ) THEN
929            ssh(i1:i2,j1:j2,Kmm_a) = ptab(i1:i2,j1:j2) * tmask(i1:i2,j1:j2,1)
930         ELSE
931            hbdy(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) * tmask(i1:i2,j1:j2,1)
932         ENDIF
933      ENDIF
934      !
935   END SUBROUTINE interpsshn
936
937   
938   SUBROUTINE interpun( ptab, i1, i2, j1, j2, k1, k2, m1, m2, before )
939      !!----------------------------------------------------------------------
940      !!                  *** ROUTINE interpun ***
941      !!---------------------------------------------   
942      !!
943      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,m1,m2
944      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) :: ptab
945      LOGICAL, INTENT(in) :: before
946      !!
947      INTEGER :: ji,jj,jk
948      REAL(wp) :: zrhoy, zhtot
949      ! vertical interpolation:
950      REAL(wp), DIMENSION(k1:k2) :: tabin, h_in, z_in
951      REAL(wp), DIMENSION(1:jpk) :: h_out, z_out
952      INTEGER  :: N_in, N_out,item
953      REAL(wp) :: h_diff
954      !!---------------------------------------------   
955      !
956      IF (before) THEN
957
958         item = Kmm_a
959         IF( l_ini_child )   Kmm_a = Kbb_a     
960
961         DO jk=1,jpk
962            DO jj=j1,j2
963               DO ji=i1,i2
964                  ptab(ji,jj,jk,1) = (e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a) * uu(ji,jj,jk,Kmm_a)*umask(ji,jj,jk)) 
965                  IF( l_vremap .OR. l_ini_child) THEN
966                     ! Interpolate thicknesses (masked for subsequent extrapolation)
967                     ptab(ji,jj,jk,2) = umask(ji,jj,jk) * e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a)
968                  ENDIF
969               END DO
970            END DO
971         END DO
972
973        IF( l_vremap .OR. l_ini_child ) THEN
974         ! Extrapolate thicknesses in partial bottom cells:
975         ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on
976            IF (ln_zps) THEN
977               DO jj=j1,j2
978                  DO ji=i1,i2
979                     jk = mbku(ji,jj)
980                     ptab(ji,jj,jk,2) = 0._wp
981                  END DO
982               END DO           
983            END IF
984
985           ! Save ssh at last level:
986           ptab(i1:i2,j1:j2,k2,2) = 0._wp
987           IF (.NOT.ln_linssh) THEN
988              ! This vertical sum below should be replaced by the sea-level at U-points (optimization):
989              DO jk=1,jpk
990                 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)
991              END DO
992              ptab(i1:i2,j1:j2,k2,2) = ptab(i1:i2,j1:j2,k2,2) - hu_0(i1:i2,j1:j2)
993           END IF
994        ENDIF
995
996         Kmm_a = item
997         !
998      ELSE
999         zrhoy = Agrif_rhoy()
1000
1001        IF( l_vremap .OR. l_ini_child) THEN
1002! VERTICAL REFINEMENT BEGIN
1003
1004            IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp 
1005
1006            DO ji=i1,i2
1007               DO jj=j1,j2
1008                  uu(ji,jj,:,Krhs_a) = 0._wp
1009                  N_in = mbku_parent(ji,jj)
1010                  zhtot = 0._wp
1011                  DO jk=1,N_in
1012                     IF (jk==N_in) THEN
1013                        h_in(jk) = hu0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot
1014                     ELSE
1015                        h_in(jk) = ptab(ji,jj,jk,2)/(e2u(ji,jj)*zrhoy) 
1016                     ENDIF
1017                     zhtot = zhtot + h_in(jk)
1018                     IF( h_in(jk) .GT. 0. ) THEN
1019                     tabin(jk) = ptab(ji,jj,jk,1)/(e2u(ji,jj)*zrhoy*h_in(jk))
1020                     ELSE
1021                     tabin(jk) = 0.
1022                     ENDIF
1023                 END DO
1024                 z_in(1) = 0.5_wp * h_in(1) - zhtot + hu0_parent(ji,jj) 
1025                 DO jk=2,N_in
1026                    z_in(jk) = z_in(jk-1) + 0.5_wp * h_in(jk)
1027                 END DO
1028                     
1029                 N_out = 0
1030                 DO jk=1,jpk
1031                    IF (umask(ji,jj,jk) == 0) EXIT
1032                    N_out = N_out + 1
1033                    h_out(N_out) = e3u(ji,jj,jk,Krhs_a)
1034                 END DO
1035
1036                 z_out(1) = 0.5_wp * h_out(1) - SUM(h_out(1:N_out)) + hu_0(ji,jj)
1037                 DO jk=2,N_out
1038                    z_out(jk) = z_out(jk-1) + 0.5_wp * h_out(jk) 
1039                 END DO 
1040
1041                 IF (N_in*N_out > 0) THEN
1042                     IF( l_ini_child ) THEN
1043                        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)
1044                     ELSE
1045                        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)
1046                     ENDIF   
1047                 ENDIF
1048               END DO
1049            END DO
1050         ELSE
1051            DO jk = 1, jpkm1
1052               DO jj=j1,j2
1053                  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) )
1054               END DO
1055            END DO
1056         ENDIF
1057
1058      ENDIF
1059      !
1060   END SUBROUTINE interpun
1061
1062   
1063   SUBROUTINE interpvn( ptab, i1, i2, j1, j2, k1, k2, m1, m2, before )
1064      !!----------------------------------------------------------------------
1065      !!                  *** ROUTINE interpvn ***
1066      !!----------------------------------------------------------------------
1067      !
1068      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,m1,m2
1069      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) :: ptab
1070      LOGICAL, INTENT(in) :: before
1071      !
1072      INTEGER :: ji,jj,jk
1073      REAL(wp) :: zrhox
1074      ! vertical interpolation:
1075      REAL(wp), DIMENSION(k1:k2) :: tabin, h_in, z_in
1076      REAL(wp), DIMENSION(1:jpk) :: h_out, z_out
1077      INTEGER  :: N_in, N_out, item
1078      REAL(wp) :: h_diff, zhtot
1079      !!---------------------------------------------   
1080      !     
1081      IF (before) THEN   
1082
1083         item = Kmm_a
1084         IF( l_ini_child )   Kmm_a = Kbb_a     
1085       
1086         DO jk=k1,k2
1087            DO jj=j1,j2
1088               DO ji=i1,i2
1089                  ptab(ji,jj,jk,1) = (e1v(ji,jj) * e3v(ji,jj,jk,Kmm_a) * vv(ji,jj,jk,Kmm_a)*vmask(ji,jj,jk))
1090                  IF( l_vremap .OR. l_ini_child) THEN
1091                     ! Interpolate thicknesses (masked for subsequent extrapolation)
1092                     ptab(ji,jj,jk,2) = vmask(ji,jj,jk) * e1v(ji,jj) * e3v(ji,jj,jk,Kmm_a)
1093                  ENDIF
1094               END DO
1095            END DO
1096         END DO
1097
1098         IF( l_vremap .OR. l_ini_child) THEN
1099         ! Extrapolate thicknesses in partial bottom cells:
1100         ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on
1101            IF (ln_zps) THEN
1102               DO jj=j1,j2
1103                  DO ji=i1,i2
1104                     jk = mbkv(ji,jj)
1105                     ptab(ji,jj,jk,2) = 0._wp
1106                  END DO
1107               END DO           
1108            END IF
1109            ! Save ssh at last level:
1110            ptab(i1:i2,j1:j2,k2,2) = 0._wp
1111            IF (.NOT.ln_linssh) THEN
1112               ! This vertical sum below should be replaced by the sea-level at V-points (optimization):
1113               DO jk=1,jpk
1114                  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)
1115               END DO
1116               ptab(i1:i2,j1:j2,k2,2) = ptab(i1:i2,j1:j2,k2,2) - hv_0(i1:i2,j1:j2)
1117            END IF
1118         ENDIF
1119         item = Kmm_a
1120
1121      ELSE       
1122         zrhox = Agrif_rhox()
1123
1124         IF( l_vremap .OR. l_ini_child ) THEN
1125
1126            IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp 
1127
1128            DO jj=j1,j2
1129               DO ji=i1,i2
1130                  vv(ji,jj,:,Krhs_a) = 0._wp
1131                  N_in = mbkv_parent(ji,jj)
1132                  zhtot = 0._wp
1133                  DO jk=1,N_in
1134                     IF (jk==N_in) THEN
1135                        h_in(jk) = hv0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot
1136                     ELSE
1137                        h_in(jk) = ptab(ji,jj,jk,2)/(e1v(ji,jj)*zrhox) 
1138                     ENDIF
1139                     zhtot = zhtot + h_in(jk)
1140                     IF( h_in(jk) .GT. 0. ) THEN
1141                       tabin(jk) = ptab(ji,jj,jk,1)/(e1v(ji,jj)*zrhox*h_in(jk))
1142                     ELSE
1143                       tabin(jk)  = 0.
1144                     ENDIF
1145                  END DO
1146
1147                  z_in(1) = 0.5_wp * h_in(1) - zhtot + hv0_parent(ji,jj)
1148                  DO jk=2,N_in
1149                     z_in(jk) = z_in(jk-1) + 0.5_wp * h_in(jk)
1150                  END DO
1151
1152                  N_out = 0
1153                  DO jk=1,jpk
1154                     IF (vmask(ji,jj,jk) == 0) EXIT
1155                     N_out = N_out + 1
1156                     h_out(N_out) = e3v(ji,jj,jk,Krhs_a)
1157                  END DO
1158
1159                  z_out(1) = 0.5_wp * h_out(1) - SUM(h_out(1:N_out)) + hv_0(ji,jj)
1160                  DO jk=2,N_out
1161                     z_out(jk) = z_out(jk-1) + 0.5_wp * h_out(jk)
1162                  END DO
1163 
1164                  IF (N_in*N_out > 0) THEN
1165                     IF( l_ini_child ) THEN
1166                        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)
1167                     ELSE
1168                        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)
1169                     ENDIF   
1170                  ENDIF
1171               END DO
1172            END DO
1173         ELSE
1174            DO jk = 1, jpkm1
1175               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) )
1176            END DO
1177         ENDIF
1178      ENDIF
1179      !       
1180   END SUBROUTINE interpvn
1181
1182   SUBROUTINE interpunb( ptab, i1, i2, j1, j2, before)
1183      !!----------------------------------------------------------------------
1184      !!                  ***  ROUTINE interpunb  ***
1185      !!---------------------------------------------------------------------- 
1186      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
1187      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
1188      LOGICAL                         , INTENT(in   ) ::   before
1189      !
1190      INTEGER  ::   ji, jj
1191      REAL(wp) ::   zrhoy, zrhot, zt0, zt1, ztcoeff
1192      !!---------------------------------------------------------------------- 
1193      !
1194      IF( before ) THEN
1195         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)
1196      ELSE
1197         zrhoy = Agrif_Rhoy()
1198         zrhot = Agrif_rhot()
1199         ! Time indexes bounds for integration
1200         zt0 = REAL(Agrif_NbStepint()  , wp) / zrhot
1201         zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot     
1202         !
1203         DO ji = i1, i2
1204            DO jj = j1, j2
1205               IF ( utint_stage(ji,jj) < (bdy_tinterp + 1) ) THEN
1206                  IF    ( utint_stage(ji,jj) == 1  ) THEN
1207                     ztcoeff = zrhot * (  zt1**2._wp * (       zt1 - 1._wp)        &
1208                        &               - zt0**2._wp * (       zt0 - 1._wp)        )
1209                  ELSEIF( utint_stage(ji,jj) == 2  ) THEN
1210                     ztcoeff = zrhot * (  zt1        * (       zt1 - 1._wp)**2._wp &
1211                        &               - zt0        * (       zt0 - 1._wp)**2._wp )
1212                  ELSEIF( utint_stage(ji,jj) == 0  ) THEN               
1213                     ztcoeff = 1._wp
1214                  ELSE
1215                     ztcoeff = 0._wp
1216                  ENDIF
1217                  !   
1218                  ubdy(ji,jj) = ubdy(ji,jj) + ztcoeff * ptab(ji,jj)
1219                  !           
1220                  IF (( utint_stage(ji,jj) == 2 ).OR.( utint_stage(ji,jj) == 0 )) THEN
1221                     ubdy(ji,jj) = ubdy(ji,jj) / (zrhoy*e2u(ji,jj)) * umask(ji,jj,1)
1222                  ENDIF
1223                  !
1224                  utint_stage(ji,jj) = utint_stage(ji,jj) + 1
1225               ENDIF
1226            END DO
1227         END DO
1228      END IF
1229      !
1230   END SUBROUTINE interpunb
1231
1232
1233   SUBROUTINE interpvnb( ptab, i1, i2, j1, j2, before )
1234      !!----------------------------------------------------------------------
1235      !!                  ***  ROUTINE interpvnb  ***
1236      !!---------------------------------------------------------------------- 
1237      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
1238      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
1239      LOGICAL                         , INTENT(in   ) ::   before
1240      !
1241      INTEGER  ::   ji, jj
1242      REAL(wp) ::   zrhox, zrhot, zt0, zt1, ztcoeff   
1243      !!---------------------------------------------------------------------- 
1244      !
1245      IF( before ) THEN
1246         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)
1247      ELSE
1248         zrhox = Agrif_Rhox()
1249         zrhot = Agrif_rhot()
1250         ! Time indexes bounds for integration
1251         zt0 = REAL(Agrif_NbStepint()  , wp) / zrhot
1252         zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot 
1253         !     
1254         DO ji = i1, i2
1255            DO jj = j1, j2
1256               IF ( vtint_stage(ji,jj) < (bdy_tinterp + 1) ) THEN
1257                  IF    ( vtint_stage(ji,jj) == 1  ) THEN
1258                     ztcoeff = zrhot * (  zt1**2._wp * (       zt1 - 1._wp)        &
1259                        &               - zt0**2._wp * (       zt0 - 1._wp)        )
1260                  ELSEIF( vtint_stage(ji,jj) == 2  ) THEN
1261                     ztcoeff = zrhot * (  zt1        * (       zt1 - 1._wp)**2._wp &
1262                        &               - zt0        * (       zt0 - 1._wp)**2._wp )
1263                  ELSEIF( vtint_stage(ji,jj) == 0  ) THEN               
1264                     ztcoeff = 1._wp
1265                  ELSE
1266                     ztcoeff = 0._wp
1267                  ENDIF
1268                  !   
1269                  vbdy(ji,jj) = vbdy(ji,jj) + ztcoeff * ptab(ji,jj)
1270                  !           
1271                  IF (( vtint_stage(ji,jj) == 2 ).OR.( vtint_stage(ji,jj) == 0 )) THEN
1272                     vbdy(ji,jj) = vbdy(ji,jj) / (zrhox*e1v(ji,jj)) * vmask(ji,jj,1)
1273                  ENDIF
1274                  !
1275                  vtint_stage(ji,jj) = vtint_stage(ji,jj) + 1
1276               ENDIF
1277            END DO
1278         END DO         
1279      ENDIF
1280      !
1281   END SUBROUTINE interpvnb
1282
1283
1284   SUBROUTINE interpub2b( ptab, i1, i2, j1, j2, before )
1285      !!----------------------------------------------------------------------
1286      !!                  ***  ROUTINE interpub2b  ***
1287      !!---------------------------------------------------------------------- 
1288      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
1289      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
1290      LOGICAL                         , INTENT(in   ) ::   before
1291      !
1292      INTEGER  ::   ji,jj
1293      REAL(wp) ::   zrhot, zt0, zt1, zat
1294      !!---------------------------------------------------------------------- 
1295      IF( before ) THEN
1296         IF ( ln_bt_fw ) THEN
1297            ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * ub2_b(i1:i2,j1:j2)
1298         ELSE
1299            ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * un_adv(i1:i2,j1:j2)
1300         ENDIF
1301      ELSE
1302         zrhot = Agrif_rhot()
1303         ! Time indexes bounds for integration
1304         zt0 = REAL(Agrif_NbStepint()  , wp) / zrhot
1305         zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot
1306         ! Polynomial interpolation coefficients:
1307         zat = zrhot * (  zt1**2._wp * (-2._wp*zt1 + 3._wp)    &
1308            &           - zt0**2._wp * (-2._wp*zt0 + 3._wp)    ) 
1309         !
1310         ubdy(i1:i2,j1:j2) = zat * ptab(i1:i2,j1:j2) 
1311         !
1312         ! Update interpolation stage:
1313         utint_stage(i1:i2,j1:j2) = 1
1314      ENDIF
1315      !
1316   END SUBROUTINE interpub2b
1317   
1318
1319   SUBROUTINE interpvb2b( ptab, i1, i2, j1, j2, before )
1320      !!----------------------------------------------------------------------
1321      !!                  ***  ROUTINE interpvb2b  ***
1322      !!---------------------------------------------------------------------- 
1323      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
1324      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
1325      LOGICAL                         , INTENT(in   ) ::   before
1326      !
1327      INTEGER ::   ji,jj
1328      REAL(wp) ::   zrhot, zt0, zt1, zat
1329      !!---------------------------------------------------------------------- 
1330      !
1331      IF( before ) THEN
1332         IF ( ln_bt_fw ) THEN
1333            ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vb2_b(i1:i2,j1:j2)
1334         ELSE
1335            ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vn_adv(i1:i2,j1:j2)
1336         ENDIF
1337      ELSE     
1338         zrhot = Agrif_rhot()
1339         ! Time indexes bounds for integration
1340         zt0 = REAL(Agrif_NbStepint()  , wp) / zrhot
1341         zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot
1342         ! Polynomial interpolation coefficients:
1343         zat = zrhot * (  zt1**2._wp * (-2._wp*zt1 + 3._wp)    &
1344            &           - zt0**2._wp * (-2._wp*zt0 + 3._wp)    ) 
1345         !
1346         vbdy(i1:i2,j1:j2) = zat * ptab(i1:i2,j1:j2)
1347         !
1348         ! update interpolation stage:
1349         vtint_stage(i1:i2,j1:j2) = 1
1350      ENDIF
1351      !     
1352   END SUBROUTINE interpvb2b
1353
1354
1355   SUBROUTINE interpe3t( ptab, i1, i2, j1, j2, k1, k2, before )
1356      !!----------------------------------------------------------------------
1357      !!                  ***  ROUTINE interpe3t  ***
1358      !!---------------------------------------------------------------------- 
1359      INTEGER                              , INTENT(in   ) :: i1, i2, j1, j2, k1, k2
1360      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
1361      LOGICAL                              , INTENT(in   ) :: before
1362      !
1363      INTEGER :: ji, jj, jk
1364      !!---------------------------------------------------------------------- 
1365      !   
1366      IF( before ) THEN
1367         ptab(i1:i2,j1:j2,k1:k2) = tmask(i1:i2,j1:j2,k1:k2) * e3t_0(i1:i2,j1:j2,k1:k2)
1368      ELSE
1369         !
1370         DO jk = k1, k2
1371            DO jj = j1, j2
1372               DO ji = i1, i2
1373                  IF( ABS( ptab(ji,jj,jk) - tmask(ji,jj,jk) * e3t_0(ji,jj,jk) ) > 1.D-2) THEN
1374                     WRITE(numout,*) ' Agrif error for e3t_0: parent , child, i, j, k ',  & 
1375                     &                 ptab(ji,jj,jk), tmask(ji,jj,jk) * e3t_0(ji,jj,jk), &
1376                     &                 mig0(ji), mig0(jj), jk
1377                !     kindic_agr = kindic_agr + 1
1378                  ENDIF
1379               END DO
1380            END DO
1381         END DO
1382         !
1383      ENDIF
1384      !
1385   END SUBROUTINE interpe3t
1386
1387   SUBROUTINE interpglamt( ptab, i1, i2, j1, j2, before )
1388      !!----------------------------------------------------------------------
1389      !!                  ***  ROUTINE interpglamt  ***
1390      !!---------------------------------------------------------------------- 
1391      INTEGER                        , INTENT(in   ) :: i1, i2, j1, j2
1392      REAL(wp),DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
1393      LOGICAL                        , INTENT(in   ) :: before
1394      !
1395      INTEGER :: ji, jj, jk
1396      REAL(wp):: ztst
1397      !!---------------------------------------------------------------------- 
1398      !   
1399      IF( before ) THEN
1400         ptab(i1:i2,j1:j2) = glamt(i1:i2,j1:j2)
1401      ELSE
1402         ztst = MAXVAL(ABS(glamt(i1:i2,j1:j2)))*1.e-4
1403         DO jj = j1, j2
1404            DO ji = i1, i2
1405               IF( ABS( ptab(ji,jj) - glamt(ji,jj) ) > ztst ) THEN
1406                  WRITE(numout,*) ' Agrif error for glamt: parent, child, i, j ', ptab(ji,jj), glamt(ji,jj), mig0(ji), mig0(jj)
1407!                  kindic_agr = kindic_agr + 1
1408               ENDIF
1409            END DO
1410         END DO
1411      ENDIF
1412      !
1413   END SUBROUTINE interpglamt
1414
1415
1416   SUBROUTINE interpgphit( ptab, i1, i2, j1, j2, before )
1417      !!----------------------------------------------------------------------
1418      !!                  ***  ROUTINE interpgphit  ***
1419      !!---------------------------------------------------------------------- 
1420      INTEGER                        , INTENT(in   ) :: i1, i2, j1, j2
1421      REAL(wp),DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
1422      LOGICAL                        , INTENT(in   ) :: before
1423      !
1424      INTEGER :: ji, jj, jk
1425      REAL(wp):: ztst
1426      !!---------------------------------------------------------------------- 
1427      !   
1428      IF( before ) THEN
1429         ptab(i1:i2,j1:j2) = gphit(i1:i2,j1:j2)
1430      ELSE
1431         ztst = MAXVAL(ABS(gphit(i1:i2,j1:j2)))*1.e-4
1432         DO jj = j1, j2
1433            DO ji = i1, i2
1434               IF( ABS( ptab(ji,jj) - gphit(ji,jj) ) > ztst ) THEN
1435                  WRITE(numout,*) ' Agrif error for gphit: parent, child, i, j ', ptab(ji,jj), gphit(ji,jj), mig0(ji), mig0(jj)
1436!                  kindic_agr = kindic_agr + 1
1437               ENDIF
1438            END DO
1439         END DO
1440      ENDIF
1441      !
1442   END SUBROUTINE interpgphit
1443
1444
1445   SUBROUTINE interpavm( ptab, i1, i2, j1, j2, k1, k2, m1, m2, before )
1446      !!----------------------------------------------------------------------
1447      !!                  ***  ROUTINE interavm  ***
1448      !!---------------------------------------------------------------------- 
1449      INTEGER                                    , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2, m1, m2
1450      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) ::   ptab
1451      LOGICAL                                    , INTENT(in   ) ::   before
1452      !
1453      INTEGER  :: ji, jj, jk
1454      INTEGER  :: N_in, N_out
1455      REAL(wp), DIMENSION(k1:k2) :: tabin, z_in
1456      REAL(wp), DIMENSION(1:jpk) :: z_out
1457      !!---------------------------------------------------------------------- 
1458      !     
1459      IF (before) THEN         
1460         DO jk=k1,k2
1461            DO jj=j1,j2
1462              DO ji=i1,i2
1463                    ptab(ji,jj,jk,1) = avm_k(ji,jj,jk)
1464              END DO
1465           END DO
1466         END DO
1467
1468         IF( l_vremap ) THEN
1469            ! Interpolate thicknesses
1470            ! Warning: these are masked, hence extrapolated prior interpolation.
1471            DO jk=k1,k2
1472               DO jj=j1,j2
1473                  DO ji=i1,i2
1474                      ptab(ji,jj,jk,2) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm_a)
1475                  END DO
1476               END DO
1477            END DO
1478
1479            ! Extrapolate thicknesses in partial bottom cells:
1480            ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on
1481            IF (ln_zps) THEN
1482               DO jj=j1,j2
1483                  DO ji=i1,i2
1484                      jk = mbkt(ji,jj)
1485                      ptab(ji,jj,jk,2) = 0._wp
1486                  END DO
1487               END DO           
1488            END IF
1489       
1490           ! Save ssh at last level:
1491            IF (.NOT.ln_linssh) THEN
1492               ptab(i1:i2,j1:j2,k2,2) = ssh(i1:i2,j1:j2,Kmm_a)*tmask(i1:i2,j1:j2,1) 
1493            ELSE
1494               ptab(i1:i2,j1:j2,k2,2) = 0._wp
1495            END IF     
1496          ENDIF
1497
1498      ELSE
1499
1500         IF( l_vremap ) THEN
1501            IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp 
1502            avm_k(i1:i2,j1:j2,k1:k2) = 0._wp
1503               
1504            DO jj = j1, j2
1505               DO ji =i1, i2
1506                  N_in = mbkt_parent(ji,jj)
1507                  IF ( tmask(ji,jj,1) == 0._wp) N_in = 0
1508                  z_in(N_in+1) = ht0_parent(ji,jj) + ptab(ji,jj,k2,2)
1509                  DO jk = N_in, 1, -1  ! Parent vertical grid               
1510                        z_in(jk) = z_in(jk+1) - ptab(ji,jj,jk,2)
1511                       tabin(jk) = ptab(ji,jj,jk,1)
1512                  END DO
1513                  N_out = mbkt(ji,jj) 
1514                  DO jk = 1, N_out        ! Child vertical grid
1515                     z_out(jk) = gdepw(ji,jj,jk,Kmm_a)
1516                  END DO
1517                  IF (N_in*N_out > 0) THEN
1518                     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)
1519                  ENDIF
1520               END DO
1521            END DO
1522         ELSE
1523            avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2,1)
1524         ENDIF
1525      ENDIF
1526      !
1527   END SUBROUTINE interpavm
1528
1529   
1530   SUBROUTINE interpmbkt( ptab, i1, i2, j1, j2, before )
1531      !!----------------------------------------------------------------------
1532      !!                  ***  ROUTINE interpsshn  ***
1533      !!---------------------------------------------------------------------- 
1534      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
1535      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
1536      LOGICAL                         , INTENT(in   ) ::   before
1537      !
1538      !!---------------------------------------------------------------------- 
1539      !
1540      IF( before) THEN
1541         ptab(i1:i2,j1:j2) = REAL(mbkt(i1:i2,j1:j2),wp)
1542      ELSE
1543         mbkt_parent(i1:i2,j1:j2) = NINT(ptab(i1:i2,j1:j2))
1544      ENDIF
1545      !
1546   END SUBROUTINE interpmbkt
1547
1548   
1549   SUBROUTINE interpht0( ptab, i1, i2, j1, j2, before )
1550      !!----------------------------------------------------------------------
1551      !!                  ***  ROUTINE interpsshn  ***
1552      !!---------------------------------------------------------------------- 
1553      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
1554      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
1555      LOGICAL                         , INTENT(in   ) ::   before
1556      !
1557      !!---------------------------------------------------------------------- 
1558      !
1559      IF( before) THEN
1560         ptab(i1:i2,j1:j2) = ht_0(i1:i2,j1:j2)
1561      ELSE
1562         ht0_parent(i1:i2,j1:j2) = ptab(i1:i2,j1:j2)
1563      ENDIF
1564      !
1565   END SUBROUTINE interpht0
1566   
1567#else
1568   !!----------------------------------------------------------------------
1569   !!   Empty module                                          no AGRIF zoom
1570   !!----------------------------------------------------------------------
1571CONTAINS
1572   SUBROUTINE Agrif_OCE_Interp_empty
1573      WRITE(*,*)  'agrif_oce_interp : You should not have seen this print! error?'
1574   END SUBROUTINE Agrif_OCE_Interp_empty
1575#endif
1576
1577   !!======================================================================
1578END MODULE agrif_oce_interp
Note: See TracBrowser for help on using the repository browser.