Newer
Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
MODULE agrif_top_interp
!!======================================================================
!! *** MODULE agrif_top_interp ***
!! AGRIF: interpolation package for TOP
!!======================================================================
!! History : 2.0 ! ???
!!----------------------------------------------------------------------
#if defined key_agrif && defined key_top
!!----------------------------------------------------------------------
!! 'key_agrif' AGRIF zoom
!! 'key_top' on-line tracers
!!----------------------------------------------------------------------
USE par_oce
USE oce
USE dom_oce
USE agrif_oce
USE agrif_top_sponge
USE par_trc
USE trc
USE vremap
!
USE lib_mpp ! MPP library
IMPLICIT NONE
PRIVATE
PUBLIC Agrif_trc, interptrn
!! * Substitutions
# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/NST 4.0 , NEMO Consortium (2018)
!! $Id: agrif_top_interp.F90 14218 2020-12-18 16:44:52Z jchanut $
!! Software governed by the CeCILL license (see ./LICENSE)
!!----------------------------------------------------------------------
CONTAINS
SUBROUTINE Agrif_trc
!!----------------------------------------------------------------------
!! *** ROUTINE Agrif_trc ***
!!----------------------------------------------------------------------
!
IF( Agrif_Root() ) RETURN
!
Agrif_SpecialValue = 0._wp
Agrif_UseSpecialValue = l_spc_top
l_vremap = ln_vert_remap
!
CALL Agrif_Bc_variable( trn_id, procname=interptrn )
!
Agrif_UseSpecialValue = .FALSE.
l_vremap = .FALSE.
!
END SUBROUTINE Agrif_trc
SUBROUTINE interptrn( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before )
!!----------------------------------------------------------------------
!! *** ROUTINE interptrn ***
!!----------------------------------------------------------------------
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:jptra) :: 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,jptra
DO jk=k1,k2
DO jj=j1,j2
DO ji=i1,i2
ptab(ji,jj,jk,jn) = tr(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,jptra+1) = 0.5_wp * tmask(ji,jj,k1) * e3w(ji,jj,k1,Kmm_a)
DO jk=k1+1,k2
ptab(ji,jj,jk,jptra+1) = tmask(ji,jj,jk) * &
& ( ptab(ji,jj,jk-1,jptra+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,jptra+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
DO jj=j1,j2
DO ji=i1,i2
tr(ji,jj,:,:,Krhs_a) = 0.
!
! Build vertical grids:
! 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:jptra) = ptab(ji,jj,jk,1:jptra)
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)
z_in(jk) = z_in(jk-1) + 0.5_wp * ( h_in(jk) + h_in(jk-1) )
z_in(1:N_in) = z_in(1:N_in) - ptab(ji,jj,k2,n2)
ENDIF
! Output (Child) grid:
DO jk=1,N_out
h_out(jk) = e3t(ji,jj,jk,Krhs_a)
END DO
z_out(1) = 0.5_wp * e3w(ji,jj,1,Krhs_a)
z_out(jk) = z_out(jk-1) + e3w(ji,jj,jk,Krhs_a)
IF (.NOT.ln_linssh) z_out(1:N_out) = z_out(1:N_out) - ssh(ji,jj,Krhs_a)
CALL remap_linear(tabin(1:N_in,1:jptra),z_in(1:N_in),tr(ji,jj,1:N_out,1:jptra,Krhs_a), &
ELSE
CALL reconstructandremap(tabin(1:N_in,1:jptra),h_in(1:N_in),tr(ji,jj,1:N_out,1:jptra,Krhs_a), &
& h_out(1:N_out),N_in,N_out,jptra)
ENDIF
ENDIF
END DO
END DO
Krhs_a = item
ELSE
IF ( Agrif_Parent(ln_zps) ) THEN ! Account for partial cells
! linear vertical interpolation
DO jj=j1,j2
DO ji=i1,i2
!
N_in = mbkt(ji,jj)
N_out = mbkt(ji,jj)
z_in(1) = ptab(ji,jj,1,n2)
tabin(1,1:jptra) = ptab(ji,jj,1,1:jptra)
DO jk=2, N_in
z_in(jk) = ptab(ji,jj,jk,n2)
tabin(jk,1:jptra) = ptab(ji,jj,jk,1:jptra)
END DO
IF (.NOT.ln_linssh) z_in(1:N_in) = z_in(1:N_in) - ptab(ji,jj,k2,n2)
z_out(1) = 0.5_wp * e3w(ji,jj,1,Krhs_a)
z_out(jk) = z_out(jk-1) + e3w(ji,jj,jk,Krhs_a)
199
200
201
202
203
204
205
206
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
END DO
IF (.NOT.ln_linssh) z_out(1:N_out) = z_out(1:N_out) - ssh(ji,jj,Krhs_a)
CALL remap_linear(tabin(1:N_in,1:jptra),z_in(1:N_in),ptab(ji,jj,1:N_out,1:jptra), &
& z_out(1:N_out),N_in,N_out,jptra)
END DO
END DO
ENDIF
DO jn=1, jptra
tr(i1:i2,j1:j2,1:jpk,jn,Krhs_a)=ptab(i1:i2,j1:j2,1:jpk,jn)*tmask(i1:i2,j1:j2,1:jpk)
END DO
ENDIF
ENDIF
!
END SUBROUTINE interptrn
#else
!!----------------------------------------------------------------------
!! Empty module no TOP AGRIF
!!----------------------------------------------------------------------
CONTAINS
SUBROUTINE Agrif_TOP_Interp_empty
!!---------------------------------------------
!! *** ROUTINE agrif_Top_Interp_empty ***
!!---------------------------------------------
WRITE(*,*) 'agrif_top_interp : You should not have seen this print! error?'
END SUBROUTINE Agrif_TOP_Interp_empty
#endif
!!======================================================================
END MODULE agrif_top_interp