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
#undef DECAL_FEEDBACK
MODULE agrif_top_update
!!======================================================================
!! *** MODULE agrif_top_update ***
!! AGRIF : update package for passive tracers (TOP)
!!======================================================================
!! History :
!!----------------------------------------------------------------------
#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 par_trc
USE trc
USE vremap
IMPLICIT NONE
PRIVATE
PUBLIC Agrif_Update_Trc
!! * Substitutions
# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/NST 4.0 , NEMO Consortium (2018)
!! $Id: agrif_top_update.F90 15265 2021-09-16 11:13:13Z jchanut $
!! Software governed by the CeCILL license (see ./LICENSE)
!!----------------------------------------------------------------------
CONTAINS
SUBROUTINE Agrif_Update_Trc( )
!!----------------------------------------------------------------------
!! *** ROUTINE Agrif_Update_Trc ***
!!----------------------------------------------------------------------
!
IF (Agrif_Root()) RETURN
!
l_vremap = ln_vert_remap
Agrif_UseSpecialValueInUpdate = .NOT.l_vremap
Agrif_SpecialValueFineGrid = 0._wp
!
# if ! defined DECAL_FEEDBACK
CALL Agrif_Update_Variable(trn_id, procname=updateTRC )
! CALL Agrif_Update_Variable( trn_id, locupdate=(/0,2/), procname=updateTRC )
# else
CALL Agrif_Update_Variable(trn_id, locupdate=(/1,0/),procname=updateTRC )
! CALL Agrif_Update_Variable( trn_id, locupdate=(/1,2/), procname=updateTRC )
# endif
!
Agrif_UseSpecialValueInUpdate = .FALSE.
l_vremap = .FALSE.
!
END SUBROUTINE Agrif_Update_Trc
SUBROUTINE updateTRC( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before )
INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2
REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres
LOGICAL, INTENT(in) :: before
!!
INTEGER :: ji,jj,jk,jn
REAL(wp) :: ztb, ztnu, ztno
REAL(wp) :: h_in(k1:k2)
REAL(wp) :: h_out(1:jpk)
INTEGER :: N_in, N_out
REAL(wp) :: h_diff
REAL(wp) :: tabin(k1:k2,1:jptra)
REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk,1:jptra) :: tabres_child
IF (before) THEN
IF ( l_vremap ) THEN
DO jn = n1,n2-1
DO jk=k1,k2
DO jj=j1,j2
DO ji=i1,i2
tabres(ji,jj,jk,jn) = tr(ji,jj,jk,jn,Kmm_a) * e3t(ji,jj,jk,Kmm_a)
END DO
END DO
END DO
END DO
DO jk=k1,k2
DO jj=j1,j2
DO ji=i1,i2
tabres(ji,jj,jk,n2) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm_a)
END DO
END DO
END DO
ELSE
DO jn = 1,jptra
DO jk=k1,k2
DO jj=j1,j2
DO ji=i1,i2
tabres(ji,jj,jk,jn) = tr(ji,jj,jk,jn,Kmm_a) * e3t(ji,jj,jk,Kmm_a) / e3t_0(ji,jj,jk)
END DO
END DO
END DO
END DO
ENDIF
ELSE
IF ( l_vremap ) THEN
tabres_child(:,:,:,:) = 0._wp
AGRIF_SpecialValue = 0._wp
DO jj=j1,j2
DO ji=i1,i2
N_in = 0
DO jk=k1,k2 !k2 = jpk of child grid
IF (tabres(ji,jj,jk,n2) <= 1.e-6_wp ) EXIT
N_in = N_in + 1
tabin(jk,:) = tabres(ji,jj,jk,n1:n2-1)/tabres(ji,jj,jk,n2)
h_in(N_in) = tabres(ji,jj,jk,n2)
ENDDO
N_out = 0
DO jk=1,jpk ! jpk of parent grid
IF (tmask(ji,jj,jk) == 0._wp ) EXIT ! TODO: Will not work with ISF
N_out = N_out + 1
h_out(N_out) = e3t(ji,jj,jk,Kmm_a)
ENDDO
IF (N_in*N_out > 0) THEN !Remove this?
CALL reconstructandremap(tabin(1:N_in,1:jptra),h_in(1:N_in),tabres_child(ji,jj,1:N_out,1:jptra),h_out(1:N_out),N_in,N_out,jptra)
ENDIF
ENDDO
ENDDO
IF (.NOT.(lk_agrif_fstep.AND.(l_1st_euler))) THEN
! Add asselin part
DO jn = 1,jptra
DO jk = 1, jpkm1
DO jj = j1, j2
DO ji = i1, i2
IF( tabres_child(ji,jj,jk,jn) /= 0._wp ) THEN
ztb = tr(ji,jj,jk,jn,Kbb_a) * e3t(ji,jj,jk,Kbb_a) ! fse3t_b prior update should be used
ztnu = tabres_child(ji,jj,jk,jn) * e3t(ji,jj,jk,Kmm_a)
ztno = tr(ji,jj,jk,jn,Kmm_a) * e3t(ji,jj,jk,Krhs_a)
tr(ji,jj,jk,jn,Kbb_a) = ( ztb + rn_atfp * ( ztnu - ztno) ) &
& * tmask(ji,jj,jk) / e3t(ji,jj,jk,Kbb_a)
ENDIF
END DO
END DO
END DO
END DO
ENDIF
DO jn = 1,jptra
DO jk = 1, jpkm1
DO jj = j1, j2
DO ji = i1, i2
IF( tabres_child(ji,jj,jk,jn) /= 0._wp ) THEN
tr(ji,jj,jk,jn,Kmm_a) = tabres_child(ji,jj,jk,jn)
END IF
END DO
END DO
END DO
END DO
ELSE
DO jn = 1,jptra
tabres(i1:i2,j1:j2,k1:k2,jn) = tabres(i1:i2,j1:j2,k1:k2,jn) * e3t_0(i1:i2,j1:j2,k1:k2) &
& * tmask(i1:i2,j1:j2,k1:k2)
ENDDO
IF (.NOT.(lk_agrif_fstep.AND.(l_1st_euler))) THEN
! Add asselin part
DO jn = 1,jptra
DO jk = k1, k2
DO jj = j1, j2
DO ji = i1, i2
IF( tabres(ji,jj,jk,jn) /= 0._wp ) THEN
ztb = tr(ji,jj,jk,jn,Kbb_a) * e3t(ji,jj,jk,Kbb_a) ! fse3t_b prior update should be used
ztnu = tabres(ji,jj,jk,jn)
ztno = tr(ji,jj,jk,jn,Kmm_a) * e3t(ji,jj,jk,Krhs_a)
tr(ji,jj,jk,jn,Kbb_a) = ( ztb + rn_atfp * ( ztnu - ztno) ) &
& * tmask(ji,jj,jk) / e3t(ji,jj,jk,Kbb_a)
ENDIF
END DO
END DO
END DO
END DO
ENDIF
DO jn = 1,jptra
DO jk=k1,k2
DO jj=j1,j2
DO ji=i1,i2
IF( tabres(ji,jj,jk,jn) /= 0._wp ) THEN
tr(ji,jj,jk,jn,Kmm_a) = tabres(ji,jj,jk,jn) / e3t(ji,jj,jk,Kmm_a)
END IF
END DO
END DO
END DO
END DO
!
ENDIF
IF ((l_1st_euler).AND.(Agrif_Nb_Step()==0) ) THEN
tr(i1:i2,j1:j2,1:jpkm1,1:jptra,Kbb_a) = tr(i1:i2,j1:j2,1:jpkm1,1:jptra,Kmm_a)
ENDIF
ENDIF
!
END SUBROUTINE updateTRC
#else
!!----------------------------------------------------------------------
!! Empty module no TOP AGRIF
!!----------------------------------------------------------------------
CONTAINS
SUBROUTINE agrif_top_update_empty
WRITE(*,*) 'agrif_top_update : You should not have seen this print! error?'
END SUBROUTINE agrif_top_update_empty
#endif
!!======================================================================
END MODULE agrif_top_update