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 dynspg_ts, ONLY: un_adv, vn_adv
!
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
Tomas Lovato
committed
PUBlIC interp_tmask_agrif
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
CALL Agrif_Set_MaskMaxSearch(10)
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.
CALL Agrif_Set_MaskMaxSearch(3)
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
SUBROUTINE Agrif_tra
!!----------------------------------------------------------------------
!! *** ROUTINE Agrif_tra ***
!!----------------------------------------------------------------------
!
IF( Agrif_Root() ) RETURN
!
Agrif_SpecialValue = 0._wp
Agrif_UseSpecialValue = l_spc_tra
l_vremap = ln_vert_remap
!
CALL Agrif_Bc_variable( ts_interp_id, procname=interptsn )
!
Agrif_UseSpecialValue = .FALSE.
l_vremap = .FALSE.
!
END SUBROUTINE Agrif_tra
SUBROUTINE Agrif_dyn( kt )
!!----------------------------------------------------------------------
!! *** 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
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
!!----------------------------------------------------------------------
!
IF( Agrif_Root() ) RETURN
!
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, procname=interpun )
CALL Agrif_Bc_variable( vn_interp_id, 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, procname=interpunb )
CALL Agrif_Bc_variable( vnb_interp_id, procname=interpvnb )
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
!
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
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
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
IF( l_vremap .OR. l_ini_child ) THEN
IF (ln_linssh) THEN
ptab(i1:i2,j1:j2,k2,n2) = 0._wp
ELSE ! Assuming parent volume follows child:
ptab(i1:i2,j1:j2,k2,n2) = ssh(i1:i2,j1:j2,Krhs_a)
ENDIF
ts(ji,jj,:,:,Krhs_a) = 0._wp
! N_in = mbkt_parent(ji,jj)
! Input grid (account for partial cells if any):
N_in = k2-1
z_in(1) = ptab(ji,jj,1,n2) - ptab(ji,jj,k2,n2)
DO jk=2,k2
z_in(jk) = ptab(ji,jj,jk,n2) - ptab(ji,jj,k2,n2)
IF (( z_in(jk) <= z_in(jk-1) ).OR.(z_in(jk)>ht_0(ji,jj))) EXIT
END DO
N_in = jk-1
DO jk=1, N_in
tabin(jk,1:jpts) = ptab(ji,jj,jk,1:jpts)
END DO
IF (ssmask(ji,jj)==1._wp) THEN
N_out = mbkt(ji,jj)
ELSE
N_out = 0
ENDIF
IF (N_in*N_out > 0) THEN
IF ( l_vremap ) THEN
DO jk = 1, N_in
h_in(jk) = e3t0_parent(ji,jj,jk) * &
& (1._wp + ptab(ji,jj,k2,n2)/(ht0_parent(ji,jj)*ssmask(ji,jj) + 1._wp - ssmask(ji,jj)))
END DO
z_in(1) = 0.5_wp * h_in(1)