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
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
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 = .TRUE.
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_i, z_in_i
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) * e3t(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) + 0.5_wp * (e3t(ji,jj,jk-1,Kmm_a)+e3t(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) ptab(i1:i2,j1:j2,k2,n2) = 0._wp
DO jj=j1,j2
DO ji=i1,i2
tr(ji,jj,:,:,Krhs_a) = 0.
!
! Build vertical grids:
N_in = mbkt_parent(ji,jj)
N_out = mbkt(ji,jj)
IF (N_in*N_out > 0) THEN
! Input grid (account for partial cells if any):
DO jk=1,N_in
z_in(jk) = ptab(ji,jj,jk,n2) - ptab(ji,jj,k2,n2)
tabin(jk,1:jptra) = ptab(ji,jj,jk,1:jptra)
END DO
! Intermediate grid:
IF ( l_vremap ) THEN
DO jk = 1, N_in
h_in_i(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_i(1) = 0.5_wp * h_in_i(1)
DO jk=2,N_in
z_in_i(jk) = z_in_i(jk-1) + 0.5_wp * ( h_in_i(jk) + h_in_i(jk-1) )
END DO
z_in_i(1:N_in) = z_in_i(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 * h_out(1)
DO jk=2,N_out
z_out(jk) = z_out(jk-1) + 0.5_wp * ( h_out(jk)+h_out(jk-1) )
END DO
IF (.NOT.ln_linssh) z_out(1:N_out) = z_out(1:N_out) - ssh(ji,jj,Krhs_a)
IF( l_ini_child ) THEN
CALL remap_linear(tabin(1:N_in,1:jptra),z_in(1:N_in),tr(ji,jj,1:N_out,1:jptra,Krhs_a), &
& z_out(1:N_out),N_in,N_out,jptra)
ELSE
CALL remap_linear(tabin(1:N_in,1:jptra),z_in(1:N_in),tabin_i(1:N_in,1:jptra), &
& z_in_i(1:N_in),N_in,N_in,jptra)
CALL reconstructandremap(tabin_i(1:N_in,1:jptra),h_in_i(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 * e3t(ji,jj,1,Krhs_a)
DO jk=2, N_out
z_out(jk) = z_out(jk-1) + 0.5_wp * (e3t(ji,jj,jk-1,Krhs_a) + e3t(ji,jj,jk,Krhs_a))
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