Newer
Older
#define PARENT_EXT_BDY
MODULE agrif_oce_interp
!!======================================================================
!! *** MODULE agrif_oce_interp ***
!! AGRIF: interpolation package for the ocean dynamics (OCE)
!!======================================================================
!! History : 2.0 ! 2002-06 (L. Debreu) Original cade
!! 3.2 ! 2009-04 (R. Benshila)
!! 3.6 ! 2014-09 (R. Benshila)
!!----------------------------------------------------------------------
#if defined key_agrif
!!----------------------------------------------------------------------
!! 'key_agrif' AGRIF zoom
!!----------------------------------------------------------------------
!! Agrif_tra :
!! Agrif_dyn :
!! Agrif_ssh :
!! Agrif_dyn_ts :
!! Agrif_dta_ts :
!! Agrif_ssh_ts :
!! Agrif_avm :
!! interpu :
!! interpv :
!!----------------------------------------------------------------------
USE par_oce
USE oce
USE dom_oce
USE zdf_oce
USE agrif_oce
USE phycst
!
USE in_out_manager
USE agrif_oce_sponge
USE lib_mpp
USE vremap
USE lbclnk
#if defined key_si3
USE iceistate, ONLY: rsshadj, nn_iceini_file
USE sbc_oce , ONLY: ln_ice_embd
USE sbc_ice , ONLY: snwice_mass
#endif
IMPLICIT NONE
PRIVATE
PUBLIC Agrif_dyn, Agrif_ssh, Agrif_dyn_ts, Agrif_dyn_ts_flux, Agrif_ssh_ts, Agrif_dta_ts
PUBLIC Agrif_tra, Agrif_avm
PUBLIC interpun , interpvn
PUBLIC interptsn, interpsshn, interpavm
PUBLIC interpunb, interpvnb , interpub2b, interpvb2b
PUBLIC interpglamt, interpgphit
PUBLIC interpht0, interpmbkt, interpe3t0_vremap
PUBLIC interp_e1e2t_frac, interp_e2u_frac, interp_e1v_frac
PUBLIC agrif_istate_oce, agrif_istate_ssh ! called by icestate.F90 and domvvl.F90
PUBLIC agrif_check_bat
INTEGER :: bdy_tinterp = 0
!! * Substitutions
# include "domzgr_substitute.h90"
!! NEMO/NST 4.0 , NEMO Consortium (2018)
!! $Id: agrif_oce_interp.F90 15119 2021-07-13 14:43:22Z jchanut $
!! Software governed by the CeCILL license (see ./LICENSE)
!!----------------------------------------------------------------------
CONTAINS
SUBROUTINE Agrif_istate_oce( Kbb, Kmm, Kaa )
!!----------------------------------------------------------------------
!! *** ROUTINE agrif_istate_oce ***
!!
!! set initial t, s, u, v, ssh from parent
!!----------------------------------------------------------------------
!
IMPLICIT NONE
!
INTEGER, INTENT(in) :: Kbb, Kmm, Kaa
INTEGER :: jn
!!----------------------------------------------------------------------
IF(lwp) WRITE(numout,*) ' '
IF(lwp) WRITE(numout,*) 'Agrif_istate_oce : interp child initial state from parent'
IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~~'
IF(lwp) WRITE(numout,*) ' '
IF ( .NOT.Agrif_Parent(l_1st_euler) ) &
& CALL ctl_stop('AGRIF hot start requires to force Euler first step on parent')
l_ini_child = .TRUE.
Agrif_SpecialValue = 0.0_wp
Agrif_UseSpecialValue = .TRUE.
l_vremap = ln_vert_remap
ts(:,:,:,:,Kbb) = 0.0_wp
uu(:,:,:,Kbb) = 0.0_wp
vv(:,:,:,Kbb) = 0.0_wp
Krhs_a = Kbb ; Kmm_a = Kbb
CALL Agrif_Init_Variable(tsini_id, procname=interptsn)
Agrif_UseSpecialValue = ln_spc_dyn
use_sign_north = .TRUE.
sign_north = -1._wp
CALL Agrif_Init_Variable(uini_id , procname=interpun )
CALL Agrif_Init_Variable(vini_id , procname=interpvn )
use_sign_north = .FALSE.
Agrif_UseSpecialValue = .FALSE.
l_ini_child = .FALSE.
l_vremap = .FALSE.
Krhs_a = Kaa ; Kmm_a = Kmm
DO jn = 1, jpts
ts(:,:,:,jn,Kbb) = ts(:,:,:,jn,Kbb) * tmask(:,:,:)
END DO
uu(:,:,:,Kbb) = uu(:,:,:,Kbb) * umask(:,:,:)
vv(:,:,:,Kbb) = vv(:,:,:,Kbb) * vmask(:,:,:)
CALL lbc_lnk( 'agrif_istate_oce', uu(:,:,: ,Kbb), 'U', -1.0_wp , vv(:,:,:,Kbb), 'V', -1.0_wp )
CALL lbc_lnk( 'agrif_istate_oce', ts(:,:,:,:,Kbb), 'T', 1.0_wp )
END SUBROUTINE Agrif_istate_oce
SUBROUTINE Agrif_istate_ssh( Kbb, Kmm, Kaa, ghosts_only )
!!----------------------------------------------------------------------
!! *** ROUTINE agrif_istate_ssh ***
!!
!! set initial ssh from parent
!!----------------------------------------------------------------------
!
IMPLICIT NONE
!
INTEGER, INTENT(in) :: Kbb, Kmm, Kaa
LOGICAL, INTENT(in), OPTIONAL :: ghosts_only
LOGICAL :: l_do_all
!!----------------------------------------------------------------------
IF(lwp) WRITE(numout,*) ' '
IF(lwp) WRITE(numout,*) 'Agrif_istate_ssh : interp child ssh from parent'
IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~~'
IF(lwp) WRITE(numout,*) ' '
IF ( .NOT.Agrif_Parent(l_1st_euler) ) &
& CALL ctl_stop('AGRIF hot start requires to force Euler first step on parent')
l_do_all = .TRUE.
IF (present(ghosts_only)) l_do_all = .FALSE.
Krhs_a = Kbb ; Kmm_a = Kbb
!
Agrif_SpecialValue = 0._wp
Agrif_UseSpecialValue = .TRUE.
l_ini_child = .TRUE.
!
IF (l_do_all) THEN
CALL Agrif_Init_Variable(sshini_id, procname=interpsshn)
ELSE
CALL Agrif_Bc_Variable(sshini_id, calledweight=1._wp, procname=interpsshn)
ENDIF
!
Agrif_UseSpecialValue = .FALSE.
l_ini_child = .FALSE.
!
Krhs_a = Kaa ; Kmm_a = Kmm
!
CALL lbc_lnk( 'Agrif_istate_ssh', ssh(:,:,Kbb), 'T', 1._wp )
!
ssh(:,:,Kmm) = ssh(:,:,Kbb)
ssh(:,:,Kaa) = 0._wp
END SUBROUTINE Agrif_istate_ssh
!!----------------------------------------------------------------------
!! *** ROUTINE Agrif_tra ***
!!----------------------------------------------------------------------
INTEGER, INTENT(in) :: kt
INTEGER, OPTIONAL, INTENT(in) :: kstg
REAL(wp) :: ztindex
! Set time index depending on stage in case of RK3 time stepping:
IF ( PRESENT( kstg ) ) THEN
ztindex = REAL(Agrif_Nbstepint(), wp)
IF ( kstg == 1 ) THEN
ztindex = ztindex + 1._wp / 3._wp
ELSEIF ( kstg == 2 ) THEN
ztindex = ztindex + 1._wp / 2._wp
ELSEIF ( kstg == 3 ) THEN
ztindex = ztindex + 1._wp
ENDIF
ztindex = ztindex / Agrif_Rhot()
ELSE
ztindex = REAL(Agrif_Nbstepint()+1, wp) / Agrif_Rhot()
ENDIF
!
Agrif_UseSpecialValue = l_spc_tra
CALL Agrif_Bc_variable( ts_interp_id, calledweight=ztindex, procname=interptsn )
!
Agrif_UseSpecialValue = .FALSE.
l_vremap = .FALSE.
!
END SUBROUTINE Agrif_tra
!!----------------------------------------------------------------------
!! *** ROUTINE Agrif_DYN ***
!!----------------------------------------------------------------------
INTEGER, INTENT(in) :: kt
INTEGER :: ji, jj, jk ! dummy loop indices
INTEGER :: ibdy1, jbdy1, ibdy2, jbdy2
REAL(wp) :: zflag
REAL(wp), DIMENSION(jpi,jpj) :: zhub, zhvb
!!----------------------------------------------------------------------
!
IF( Agrif_Root() ) RETURN
!
! Set time index depending on stage in case of RK3 time stepping:
IF ( PRESENT( kstg ) ) THEN
ztindex = REAL(Agrif_Nbstepint(), wp)
IF ( kstg == 1 ) THEN
ztindex = ztindex + 1._wp / 3._wp
ELSEIF ( kstg == 2 ) THEN
ztindex = ztindex + 1._wp / 2._wp
ELSEIF ( kstg == 3 ) THEN
ztindex = ztindex + 1._wp
ENDIF
ztindex = ztindex / Agrif_Rhot()
ELSE
ztindex = REAL(Agrif_Nbstepint()+1, wp) / Agrif_Rhot()
ENDIF
!
Agrif_SpecialValue = 0.0_wp
Agrif_UseSpecialValue = ln_spc_dyn
l_vremap = ln_vert_remap
!
use_sign_north = .TRUE.
sign_north = -1.0_wp
CALL Agrif_Bc_variable( un_interp_id, calledweight=ztindex, procname=interpun )
CALL Agrif_Bc_variable( vn_interp_id, calledweight=ztindex, procname=interpvn )
IF( .NOT.ln_dynspg_ts ) THEN ! Get transports
ubdy(:,:) = 0._wp ; vbdy(:,:) = 0._wp
utint_stage(:,:) = 0 ; vtint_stage(:,:) = 0
CALL Agrif_Bc_variable( unb_interp_id, calledweight=ztindex, procname=interpunb )
CALL Agrif_Bc_variable( vnb_interp_id, calledweight=ztindex, procname=interpvnb )
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
ENDIF
use_sign_north = .FALSE.
!
Agrif_UseSpecialValue = .FALSE.
l_vremap = .FALSE.
!
! Ensure below that vertically integrated transports match
! either transports out of time splitting procedure (ln_dynspg_ts=.TRUE.)
! or parent grid transports (ln_dynspg_ts=.FALSE.)
!
! --- West --- !
IF( lk_west ) THEN
ibdy1 = nn_hls + 2 ! halo + land + 1
ibdy2 = nn_hls + nbghostcells + nn_shift_bar*Agrif_Rhox() ! halo + land + nbghostcells
!
IF( .NOT.ln_dynspg_ts ) THEN ! Store transport
DO ji = mi0(ibdy1), mi1(ibdy2)
DO jj = 1, jpj
uu_b(ji,jj,Krhs_a) = ubdy(ji,jj) * r1_hu(ji,jj,Krhs_a)
vv_b(ji,jj,Krhs_a) = vbdy(ji,jj) * r1_hv(ji,jj,Krhs_a)
END DO
END DO
ENDIF
!
DO ji = mi0(ibdy1), mi1(ibdy2)
zub(ji,:) = 0._wp
zhub(ji,:) = 0._wp
zflag = 0.5_wp - SIGN(0.5_wp, rn_hcri - e3u(ji,jj,jk,Krhs_a))
zub(ji,jj) = zub(ji,jj) + zflag * e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk)
zhub(ji,jj) = zhub(ji,jj) + zflag * e3u(ji,jj,jk,Krhs_a) * umask(ji,jj,jk)
!! zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a)
zub(ji,jj) = zub(ji,jj) / ( zhub(ji,jj) + 1._wp - ssumask(ji,jj))
zflag = 0.5_wp - SIGN(0.5_wp, rn_hcri - e3u(ji,jj,jk,Krhs_a))
uu(ji,jj,jk,Krhs_a) = zflag * ( uu(ji,jj,jk,Krhs_a) + uu_b(ji,jj,Krhs_a) - zub(ji,jj) ) * umask(ji,jj,jk)
END DO
END DO
END DO
!
DO ji = mi0(ibdy1), mi1(ibdy2)
zvb(ji,:) = 0._wp
zhvb(ji,:) = 0._wp
zflag = 0.5_wp - SIGN(0.5_wp, rn_hcri - e3v(ji,jj,jk,Krhs_a))
zvb(ji,jj) = zvb(ji,jj) + zflag * e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk)
zhvb(ji,jj) = zhvb(ji,jj) + zflag * e3v(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk)
!! zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a)
zvb(ji,jj) = zvb(ji,jj) / ( zhvb(ji,jj) + 1._wp - ssvmask(ji,jj))
zflag = 0.5_wp - SIGN(0.5_wp, rn_hcri - e3v(ji,jj,jk,Krhs_a))
vv(ji,jj,jk,Krhs_a) = zflag * ( vv(ji,jj,jk,Krhs_a) + vv_b(ji,jj,Krhs_a) - zvb(ji,jj) )*vmask(ji,jj,jk)
END DO
END DO
END DO
!
ENDIF
! --- East --- !
IF( lk_east) THEN
ibdy1 = jpiglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhox()
ibdy2 = jpiglo - ( nn_hls + 2 )
!
IF( .NOT.ln_dynspg_ts ) THEN
DO ji = mi0(ibdy1), mi1(ibdy2)
DO jj = 1, jpj
uu_b(ji,jj,Krhs_a) = ubdy(ji,jj) * r1_hu(ji,jj,Krhs_a)
END DO
END DO
ENDIF
!
DO ji = mi0(ibdy1), mi1(ibdy2)
zub(ji,:) = 0._wp
zhub(ji,:) = 0._wp
zflag = 0.5_wp - SIGN(0.5_wp, rn_hcri - e3u(ji,jj,jk,Krhs_a))
zub(ji,jj) = zub(ji,jj) + zflag * e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk)
zhub(ji,jj) = zhub(ji,jj) + zflag * e3u(ji,jj,jk,Krhs_a) * umask(ji,jj,jk)
!! zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a)
zub(ji,jj) = zub(ji,jj) / ( zhub(ji,jj) + 1._wp - ssumask(ji,jj))
zflag = 0.5_wp - SIGN(0.5_wp, rn_hcri - e3u(ji,jj,jk,Krhs_a))
uu(ji,jj,jk,Krhs_a) = zflag * ( uu(ji,jj,jk,Krhs_a) + uu_b(ji,jj,Krhs_a) - zub(ji,jj) ) * umask(ji,jj,jk)
END DO
END DO
END DO
!
ibdy1 = jpiglo - ( nn_hls + nbghostcells - 1 ) - nn_shift_bar*Agrif_Rhox()
ibdy2 = jpiglo - ( nn_hls + 1 )
!
IF( .NOT.ln_dynspg_ts ) THEN
DO ji = mi0(ibdy1), mi1(ibdy2)
DO jj = 1, jpj
vv_b(ji,jj,Krhs_a) = vbdy(ji,jj) * r1_hv(ji,jj,Krhs_a)
END DO
END DO
ENDIF
!
DO ji = mi0(ibdy1), mi1(ibdy2)
zvb(ji,:) = 0._wp
zhvb(ji,:) = 0._wp
zflag = 0.5_wp - SIGN(0.5_wp, rn_hcri - e3v(ji,jj,jk,Krhs_a))
zvb(ji,jj) = zvb(ji,jj) + zflag * e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk)
zhvb(ji,jj) = zhvb(ji,jj) + zflag * e3v(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk)
!! zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a)
zvb(ji,jj) = zvb(ji,jj) / ( zhvb(ji,jj) + 1._wp - ssvmask(ji,jj))
zflag = 0.5_wp - SIGN(0.5_wp, rn_hcri - e3v(ji,jj,jk,Krhs_a))
vv(ji,jj,jk,Krhs_a) = zflag * ( vv(ji,jj,jk,Krhs_a) + vv_b(ji,jj,Krhs_a) - zvb(ji,jj) ) * vmask(ji,jj,jk)
END DO
END DO
END DO
!
ENDIF
! --- South --- !
IF( lk_south ) THEN
jbdy1 = nn_hls + 2
jbdy2 = nn_hls + nbghostcells + nn_shift_bar*Agrif_Rhoy()
!
IF( .NOT.ln_dynspg_ts ) THEN
DO jj = mj0(jbdy1), mj1(jbdy2)
DO ji = 1, jpi
uu_b(ji,jj,Krhs_a) = ubdy(ji,jj) * r1_hu(ji,jj,Krhs_a)
vv_b(ji,jj,Krhs_a) = vbdy(ji,jj) * r1_hv(ji,jj,Krhs_a)
END DO
END DO
ENDIF
!
DO jj = mj0(jbdy1), mj1(jbdy2)
zvb(:,jj) = 0._wp
zhvb(:,jj) = 0._wp
zflag = 0.5_wp - SIGN(0.5_wp, rn_hcri - e3v(ji,jj,jk,Krhs_a))
zvb(ji,jj) = zvb(ji,jj) + zflag * e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk)
zhvb(ji,jj) = zhvb(ji,jj) + zflag * e3v(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk)
!! zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a)
zvb(ji,jj) = zvb(ji,jj) / ( zhvb(ji,jj) + 1._wp - ssvmask(ji,jj))
zflag = 0.5_wp - SIGN(0.5_wp, rn_hcri - e3v(ji,jj,jk,Krhs_a))
vv(ji,jj,jk,Krhs_a) = zflag * ( vv(ji,jj,jk,Krhs_a) + vv_b(ji,jj,Krhs_a) - zvb(ji,jj) ) * vmask(ji,jj,jk)
END DO
END DO
END DO
!
DO jj = mj0(jbdy1), mj1(jbdy2)
zub(:,jj) = 0._wp
zhub(:,jj) = 0._wp
zflag = 0.5_wp - SIGN(0.5_wp, rn_hcri - e3u(ji,jj,jk,Krhs_a))
zub(ji,jj) = zub(ji,jj) + zflag * e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk)
zhub(ji,jj) = zhub(ji,jj) + zflag * e3u(ji,jj,jk,Krhs_a) * umask(ji,jj,jk)
!! zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a)
zub(ji,jj) = zub(ji,jj) / ( zhub(ji,jj) + 1._wp - ssumask(ji,jj))
zflag = 0.5_wp - SIGN(0.5_wp, rn_hcri - e3u(ji,jj,jk,Krhs_a))
uu(ji,jj,jk,Krhs_a) = zflag * ( uu(ji,jj,jk,Krhs_a) + uu_b(ji,jj,Krhs_a) - zub(ji,jj) ) * umask(ji,jj,jk)
END DO
END DO
END DO
!
ENDIF
! --- North --- !
IF( lk_north ) THEN
jbdy1 = jpjglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhoy()
jbdy2 = jpjglo - ( nn_hls + 2 )
!
IF( .NOT.ln_dynspg_ts ) THEN
DO jj = mj0(jbdy1), mj1(jbdy2)
DO ji = 1, jpi
vv_b(ji,jj,Krhs_a) = vbdy(ji,jj) * r1_hv(ji,jj,Krhs_a)
END DO
END DO
ENDIF
!
DO jj = mj0(jbdy1), mj1(jbdy2)
zvb(:,jj) = 0._wp
zhvb(:,jj) = 0._wp
zflag = 0.5_wp - SIGN(0.5_wp, rn_hcri - e3v(ji,jj,jk,Krhs_a))
zvb(ji,jj) = zvb(ji,jj) + zflag * e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk)
zhvb(ji,jj) = zhvb(ji,jj) + zflag * e3v(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk)
!! zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a)
zvb(ji,jj) = zvb(ji,jj) / ( zhvb(ji,jj) + 1._wp - ssvmask(ji,jj))
zflag = 0.5_wp - SIGN(0.5_wp, rn_hcri - e3v(ji,jj,jk,Krhs_a))
vv(ji,jj,jk,Krhs_a) = zflag * ( vv(ji,jj,jk,Krhs_a) + vv_b(ji,jj,Krhs_a) - zvb(ji,jj) ) * vmask(ji,jj,jk)
END DO
END DO
END DO
!
jbdy1 = jpjglo - ( nn_hls + nbghostcells -1 ) - nn_shift_bar*Agrif_Rhoy()
jbdy2 = jpjglo - ( nn_hls + 1 )
!
IF( .NOT.ln_dynspg_ts ) THEN
DO jj = mj0(jbdy1), mj1(jbdy2)
DO ji = 1, jpi
uu_b(ji,jj,Krhs_a) = ubdy(ji,jj) * r1_hu(ji,jj,Krhs_a)
END DO
END DO
ENDIF
!
DO jj = mj0(jbdy1), mj1(jbdy2)
zub(:,jj) = 0._wp
zhub(:,jj) = 0._wp
zflag = 0.5_wp - SIGN(0.5_wp, rn_hcri - e3u(ji,jj,jk,Krhs_a))
zub(ji,jj) = zub(ji,jj) + zflag * e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk)
zhub(ji,jj) = zhub(ji,jj) + zflag * e3u(ji,jj,jk,Krhs_a) * umask(ji,jj,jk)
!!zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a)
zub(ji,jj) = zub(ji,jj) / ( zhub(ji,jj) + 1._wp - ssumask(ji,jj))
zflag = 0.5_wp - SIGN(0.5_wp, rn_hcri - e3u(ji,jj,jk,Krhs_a))
uu(ji,jj,jk,Krhs_a) = zflag * ( uu(ji,jj,jk,Krhs_a) + uu_b(ji,jj,Krhs_a) - zub(ji,jj) ) * umask(ji,jj,jk)
END DO
END DO
END DO
!
ENDIF
!
END SUBROUTINE Agrif_dyn
SUBROUTINE Agrif_dyn_ts( jn )
!!----------------------------------------------------------------------
!! *** ROUTINE Agrif_dyn_ts ***
!!----------------------------------------------------------------------
INTEGER, INTENT(in) :: jn
!!
INTEGER :: ji, jj
INTEGER :: istart, iend, jstart, jend
!!----------------------------------------------------------------------
!
IF( Agrif_Root() ) THEN
#if defined PARENT_EXT_BDY
! Assume persistance for barotropic mode well inside overlapping zone
ua_e(:,:) = umask_upd(:,:) * uu_b(:,:,Kmm_a) &
& * hu(:,:,Kmm_a) * hur_e(:,:) &
& + (1._wp - umask_upd(:,:)) * ua_e(:,:)
va_e(:,:) = vmask_upd(:,:) * vv_b(:,:,Kmm_a) &
& * hv(:,:,Kmm_a) * hvr_e(:,:) &
& + (1._wp - vmask_upd(:,:)) * va_e(:,:)
#endif
ELSE
!
!--- West ---!
IF( lk_west ) THEN
istart = nn_hls + 2 ! halo + land + 1
iend = nn_hls + nbghostcells + nn_shift_bar*Agrif_Rhox() ! halo + land + nbghostcells
DO ji = mi0(istart), mi1(iend)
DO jj=1,jpj
va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj)
ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj)
END DO
ENDIF
!
!--- East ---!
IF( lk_east ) THEN
istart = jpiglo - ( nn_hls + nbghostcells -1 ) - nn_shift_bar*Agrif_Rhox()
iend = jpiglo - ( nn_hls + 1 )
DO ji = mi0(istart), mi1(iend)
DO jj=1,jpj
va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj)
END DO
istart = jpiglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhox()
iend = jpiglo - ( nn_hls + 2 )
DO ji = mi0(istart), mi1(iend)
DO jj=1,jpj
ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj)
END DO
ENDIF
!
!--- South ---!
IF( lk_south ) THEN
jstart = nn_hls + 2
jend = nn_hls + nbghostcells + nn_shift_bar*Agrif_Rhoy()
DO jj = mj0(jstart), mj1(jend)
DO ji=1,jpi
ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj)
va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj)
END DO
ENDIF
!
!--- North ---!
IF( lk_north ) THEN
jstart = jpjglo - ( nn_hls + nbghostcells -1 ) - nn_shift_bar*Agrif_Rhoy()
jend = jpjglo - ( nn_hls + 1 )
DO jj = mj0(jstart), mj1(jend)
DO ji=1,jpi
ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj)
END DO
jstart = jpjglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhoy()
jend = jpjglo - ( nn_hls + 2 )
DO jj = mj0(jstart), mj1(jend)
DO ji=1,jpi
va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj)
END DO
ENDIF
!
ENDIF
END SUBROUTINE Agrif_dyn_ts
SUBROUTINE Agrif_dyn_ts_flux( jn, zu, zv )
!!----------------------------------------------------------------------
!! *** ROUTINE Agrif_dyn_ts_flux ***
!!----------------------------------------------------------------------
INTEGER, INTENT(in) :: jn
REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: zu, zv
!!
INTEGER :: ji, jj
INTEGER :: istart, iend, jstart, jend
!!----------------------------------------------------------------------
!
IF( Agrif_Root() ) THEN
#if defined PARENT_EXT_BDY
! Assume persistance for barotropic mode well inside overlapping zone
zu(:,:) = umask_upd(:,:) * uu_b(:,:,Kmm_a) &
& * hu(:,:,Kmm_a) * e2u(:,:) &
& + (1._wp - umask_upd(:,:)) * zu(:,:)
zv(:,:) = vmask_upd(:,:) * vv_b(:,:,Kmm_a) &
& * hv(:,:,Kmm_a) * e1v(:,:) &
& + (1._wp - vmask_upd(:,:)) * zv(:,:)
#endif
ELSE
!
!--- West ---!
IF( lk_west ) THEN
istart = nn_hls + 2
iend = nn_hls + nbghostcells + nn_shift_bar*Agrif_Rhox()
DO ji = mi0(istart), mi1(iend)
DO jj=1,jpj
zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj)
zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj)
END DO
ENDIF
!
!--- East ---!
IF( lk_east ) THEN
istart = jpiglo - ( nn_hls + nbghostcells -1 ) - nn_shift_bar*Agrif_Rhox()
iend = jpiglo - ( nn_hls + 1 )
DO ji = mi0(istart), mi1(iend)
DO jj=1,jpj
zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj)
END DO
istart = jpiglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhox()
iend = jpiglo - ( nn_hls + 2 )
DO ji = mi0(istart), mi1(iend)
DO jj=1,jpj
zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj)
END DO
ENDIF
!
!--- South ---!
IF( lk_south ) THEN
jstart = nn_hls + 2
jend = nn_hls + nbghostcells + nn_shift_bar*Agrif_Rhoy()
DO jj = mj0(jstart), mj1(jend)
DO ji=1,jpi
zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj)
zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj)
END DO
ENDIF
!
!--- North ---!
IF( lk_north ) THEN
jstart = jpjglo - ( nn_hls + nbghostcells -1 ) - nn_shift_bar*Agrif_Rhoy()
jend = jpjglo - ( nn_hls + 1 )
DO jj = mj0(jstart), mj1(jend)
DO ji=1,jpi
zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj)
END DO
jstart = jpjglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhoy()
jend = jpjglo - ( nn_hls + 2 )
DO jj = mj0(jstart), mj1(jend)
DO ji=1,jpi
zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj)
END DO
ENDIF
!
END SUBROUTINE Agrif_dyn_ts_flux
SUBROUTINE Agrif_dta_ts( kt )
!!----------------------------------------------------------------------
!! *** ROUTINE Agrif_dta_ts ***
!!----------------------------------------------------------------------
INTEGER, INTENT(in) :: kt
!!
LOGICAL :: ll_int_cons
!!----------------------------------------------------------------------
!
IF( Agrif_Root() ) RETURN
!
#if defined key_RK3
Agrif_SpecialValue = 0._wp
Agrif_UseSpecialValue = .TRUE.
CALL Agrif_Bc_variable(sshn_id, procname=interpsshn )
Agrif_UseSpecialValue = .FALSE.
#endif
!
ll_int_cons = ln_bt_fw ! Assume conservative temporal integration in the forward case only
!
! Enforce volume conservation if no time refinement:
IF ( Agrif_rhot()==1 ) ll_int_cons=.TRUE.
!
! Interpolate barotropic fluxes
Agrif_SpecialValue = 0._wp
Agrif_UseSpecialValue = ln_spc_dyn
use_sign_north = .TRUE.
sign_north = -1.
!
! Set bdy time interpolation stage to 0 (latter incremented locally do deal with corners)
utint_stage(:,:) = 0
vtint_stage(:,:) = 0
!
IF( ll_int_cons ) THEN ! Conservative interpolation
Agrif_UseSpecialValue = .FALSE. ! To ensure divergence conservation
!
IF ( lk_tint2d_constant ) THEN
CALL Agrif_Bc_variable( ub2b_interp_id, calledweight=1._wp, procname=interpub2b_const )
CALL Agrif_Bc_variable( vb2b_interp_id, calledweight=1._wp, procname=interpvb2b_const )
! Divergence conserving correction terms:
! JC: Disable this until we found a workaround around masked corners:
! IF ( Agrif_Rhox()>1 ) CALL Agrif_Bc_variable( ub2b_cor_id, calledweight=1._wp, procname=ub2b_cor )
! IF ( Agrif_Rhoy()>1 ) CALL Agrif_Bc_variable( vb2b_cor_id, calledweight=1._wp, procname=vb2b_cor )
ELSE
! order matters here !!!!!!
CALL Agrif_Bc_variable( ub2b_interp_id, calledweight=1._wp, procname=interpub2b ) ! Time integrated
CALL Agrif_Bc_variable( vb2b_interp_id, calledweight=1._wp, procname=interpvb2b )
!
bdy_tinterp = 1
CALL Agrif_Bc_variable( unb_interp_id , calledweight=1._wp, procname=interpunb ) ! After
CALL Agrif_Bc_variable( vnb_interp_id , calledweight=1._wp, procname=interpvnb )
!
bdy_tinterp = 2
CALL Agrif_Bc_variable( unb_interp_id , calledweight=0._wp, procname=interpunb ) ! Before
CALL Agrif_Bc_variable( vnb_interp_id , calledweight=0._wp, procname=interpvnb )
ENDIF
ELSE ! Linear interpolation
!
ubdy(:,:) = 0._wp ; vbdy(:,:) = 0._wp
CALL Agrif_Bc_variable( unb_interp_id, procname=interpunb )
CALL Agrif_Bc_variable( vnb_interp_id, procname=interpvnb )
ENDIF
Agrif_UseSpecialValue = .FALSE.
use_sign_north = .FALSE.
!
! Set ssh forcing over ghost zone:
! No temporal interpolation here
IF (lk_div_cons) CALL Agrif_Bc_variable( sshn_frc_id, calledweight=1._wp, procname=interpsshn_frc )
!
END SUBROUTINE Agrif_dta_ts
SUBROUTINE Agrif_ssh( kt )
!!----------------------------------------------------------------------
!! *** ROUTINE Agrif_ssh ***
!!----------------------------------------------------------------------
INTEGER, INTENT(in) :: kt
!
INTEGER :: ji, jj
INTEGER :: istart, iend, jstart, jend
!!----------------------------------------------------------------------
!
IF( Agrif_Root() ) RETURN
!
! Linear time interpolation of sea level
!
Agrif_SpecialValue = 0._wp
Agrif_UseSpecialValue = l_spc_ssh
CALL Agrif_Bc_variable(sshn_id, procname=interpsshn )
Agrif_UseSpecialValue = .FALSE.
!
! --- West --- !
IF(lk_west) THEN
istart = nn_hls + 2 ! halo + land + 1
iend = nn_hls + nbghostcells + nn_shift_bar*Agrif_Rhox() ! halo + land + nbghostcells
IF (lk_div_cons) iend = istart
DO ji = mi0(istart), mi1(iend)
DO jj = 1, jpj
ssh(ji,jj,Krhs_a) = hbdy(ji,jj)
END DO
END DO
ENDIF
!
! --- East --- !
IF(lk_east) THEN
istart = jpiglo - ( nn_hls + nbghostcells -1 ) - nn_shift_bar*Agrif_Rhox() ! halo + land + nbghostcells - 1
iend = jpiglo - ( nn_hls + 1 ) ! halo + land + 1 - 1
IF (lk_div_cons) istart = iend
DO ji = mi0(istart), mi1(iend)
DO jj = 1, jpj
ssh(ji,jj,Krhs_a) = hbdy(ji,jj)
END DO
END DO
ENDIF
!
! --- South --- !
IF(lk_south) THEN
jstart = nn_hls + 2 ! halo + land + 1
jend = nn_hls + nbghostcells + nn_shift_bar*Agrif_Rhoy() ! halo + land + nbghostcells
IF (lk_div_cons) jend = jstart
DO jj = mj0(jstart), mj1(jend)
DO ji = 1, jpi
ssh(ji,jj,Krhs_a) = hbdy(ji,jj)
END DO
END DO
ENDIF
!
! --- North --- !
IF(lk_north) THEN
jstart = jpjglo - ( nn_hls + nbghostcells -1 ) - nn_shift_bar*Agrif_Rhoy() ! halo + land + nbghostcells - 1
jend = jpjglo - ( nn_hls + 1 ) ! halo + land + 1 - 1
IF (lk_div_cons) jstart = jend
DO jj = mj0(jstart), mj1(jend)
DO ji = 1, jpi
ssh(ji,jj,Krhs_a) = hbdy(ji,jj)
END DO
END DO
ENDIF
!
END SUBROUTINE Agrif_ssh
SUBROUTINE Agrif_ssh_ts( jn )
!!----------------------------------------------------------------------
!! *** ROUTINE Agrif_ssh_ts ***
!!----------------------------------------------------------------------
INTEGER, INTENT(in) :: jn
!!
INTEGER :: ji, jj
INTEGER :: istart, iend, jstart, jend
!!----------------------------------------------------------------------
!
IF( Agrif_Root() ) THEN
#if defined PARENT_EXT_BDY
! Assume persistence well inside overlapping domain
ssha_e(:,:) = tmask_upd(:,:) * ssh(:,:,Kmm_a) &
& + (1._wp - tmask_upd(:,:)) * ssha_e(:,:)
#endif
ELSE
!
! --- West --- !
IF(lk_west) THEN
istart = nn_hls + 2 ! halo + land + 1
iend = nn_hls + nbghostcells + nn_shift_bar*Agrif_Rhox() ! halo + land + nbghostcells
IF (lk_div_cons) iend = istart
DO ji = mi0(istart), mi1(iend)
DO jj = 1, jpj
ssha_e(ji,jj) = hbdy(ji,jj)
END DO
ENDIF
!
! --- East --- !
IF(lk_east) THEN
istart = jpiglo - ( nn_hls + nbghostcells -1 ) - nn_shift_bar*Agrif_Rhox() ! halo + land + nbghostcells - 1
iend = jpiglo - ( nn_hls + 1 ) ! halo + land + 1 - 1
IF (lk_div_cons) istart = iend
DO ji = mi0(istart), mi1(iend)
DO jj = 1, jpj
ssha_e(ji,jj) = hbdy(ji,jj)
END DO
ENDIF
!
! --- South --- !
IF(lk_south) THEN
jstart = nn_hls + 2 ! halo + land + 1
jend = nn_hls + nbghostcells + nn_shift_bar*Agrif_Rhoy() ! halo + land + nbghostcells
IF (lk_div_cons) jend = jstart
DO jj = mj0(jstart), mj1(jend)
DO ji = 1, jpi
ssha_e(ji,jj) = hbdy(ji,jj)
END DO
ENDIF
!
! --- North --- !
IF(lk_north) THEN
jstart = jpjglo - ( nn_hls + nbghostcells -1 ) - nn_shift_bar*Agrif_Rhoy() ! halo + land + nbghostcells - 1
jend = jpjglo - ( nn_hls + 1 ) ! halo + land + 1 - 1
IF (lk_div_cons) jstart = jend
DO jj = mj0(jstart), mj1(jend)
DO ji = 1, jpi
ssha_e(ji,jj) = hbdy(ji,jj)
END DO
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
ENDIF
!
END SUBROUTINE Agrif_ssh_ts
SUBROUTINE Agrif_avm
!!----------------------------------------------------------------------
!! *** ROUTINE Agrif_avm ***
!!----------------------------------------------------------------------
REAL(wp) :: zalpha
!!----------------------------------------------------------------------
!
IF( Agrif_Root() ) RETURN
!
zalpha = 1._wp ! JC: proper time interpolation impossible
! => use last available value from parent
!
Agrif_SpecialValue = 0.e0
Agrif_UseSpecialValue = .TRUE.
l_vremap = ln_vert_remap
!
CALL Agrif_Bc_variable( avm_id, calledweight=zalpha, procname=interpavm )
!
Agrif_UseSpecialValue = .FALSE.
l_vremap = .FALSE.
!
END SUBROUTINE Agrif_avm
SUBROUTINE interptsn( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before )
!!----------------------------------------------------------------------
REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: ptab
INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2
LOGICAL , INTENT(in ) :: before
!
INTEGER :: ji, jj, jk, jn ! dummy loop indices
INTEGER :: N_in, N_out
INTEGER :: item
! vertical interpolation:
REAL(wp) :: zhtot, zwgt
REAL(wp), DIMENSION(k1:k2,1:jpts) :: tabin, tabin_i
REAL(wp), DIMENSION(k1:k2) :: z_in, h_in
REAL(wp), DIMENSION(1:jpk) :: h_out, z_out
!!----------------------------------------------------------------------
IF( before ) THEN
item = Kmm_a
IF( l_ini_child ) Kmm_a = Kbb_a
DO jn = 1,jpts
Jérôme Chanut
committed
DO jk=k1,k2-1
DO jj=j1,j2
DO ji=i1,i2
ptab(ji,jj,jk,jn) = ts(ji,jj,jk,jn,Kmm_a)
END DO
END DO
END DO
END DO
IF( l_vremap .OR. l_ini_child .OR. ln_zps ) THEN
! Fill cell depths (i.e. gdept) to be interpolated
! Warning: these are masked, hence extrapolated prior interpolation.
DO jj=j1,j2
DO ji=i1,i2
ptab(ji,jj,k1,jpts+1) = 0.5_wp * tmask(ji,jj,k1) * e3w(ji,jj,k1,Kmm_a)
Jérôme Chanut
committed
DO jk=k1+1,k2-1
& ( ptab(ji,jj,jk-1,jpts+1) + e3w(ji,jj,jk,Kmm_a) )
END DO
END DO
END DO
! Save ssh at last level:
IF (.NOT.ln_linssh) THEN
ptab(i1:i2,j1:j2,k2,jpts+1) = ssh(i1:i2,j1:j2,Kmm_a)*tmask(i1:i2,j1:j2,1)
END IF
ENDIF
Kmm_a = item
ELSE
item = Krhs_a
IF( l_ini_child ) Krhs_a = Kbb_a