New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
agrif_top_update.F90 in NEMO/trunk/src/NST – NEMO

source: NEMO/trunk/src/NST/agrif_top_update.F90 @ 12377

Last change on this file since 12377 was 12377, checked in by acc, 4 years ago

The big one. Merging all 2019 developments from the option 1 branch back onto the trunk.

This changeset reproduces 2019/dev_r11943_MERGE_2019 on the trunk using a 2-URL merge
onto a working copy of the trunk. I.e.:

svn merge --ignore-ancestry \

​svn+ssh://acc@forge.ipsl.jussieu.fr/ipsl/forge/projets/nemo/svn/NEMO/trunk \
​svn+ssh://acc@forge.ipsl.jussieu.fr/ipsl/forge/projets/nemo/svn/NEMO/branches/2019/dev_r11943_MERGE_2019 ./

The --ignore-ancestry flag avoids problems that may otherwise arise from the fact that
the merge history been trunk and branch may have been applied in a different order but
care has been taken before this step to ensure that all applicable fixes and updates
are present in the merge branch.

The trunk state just before this step has been branched to releases/release-4.0-HEAD
and that branch has been immediately tagged as releases/release-4.0.2. Any fixes
or additions in response to tickets on 4.0, 4.0.1 or 4.0.2 should be done on
releases/release-4.0-HEAD. From now on future 'point' releases (e.g. 4.0.2) will
remain unchanged with periodic releases as needs demand. Note release-4.0-HEAD is a
transitional naming convention. Future full releases, say 4.2, will have a release-4.2
branch which fulfills this role and the first point release (e.g. 4.2.0) will be made
immediately following the release branch creation.

2020 developments can be started from any trunk revision later than this one.
  • Property svn:keywords set to Id
File size: 9.5 KB
Line 
1#undef DECAL_FEEDBACK
2
3MODULE agrif_top_update
4   !!======================================================================
5   !!                ***  MODULE agrif_top_update  ***
6   !! AGRIF :   update package for passive tracers (TOP)
7   !!======================================================================
8   !! History : 
9   !!----------------------------------------------------------------------
10#if defined key_agrif && defined key_top
11   !!----------------------------------------------------------------------
12   !!   'key_agrif'                                              AGRIF zoom
13   !!   'key_TOP'                                           on-line tracers
14   !!----------------------------------------------------------------------
15   USE par_oce
16   USE oce
17   USE dom_oce
18   USE agrif_oce
19   USE par_trc
20   USE trc
21   USE vremap
22
23   IMPLICIT NONE
24   PRIVATE
25
26   PUBLIC Agrif_Update_Trc
27
28   !!----------------------------------------------------------------------
29   !! NEMO/NST 4.0 , NEMO Consortium (2018)
30   !! $Id$
31   !! Software governed by the CeCILL license (see ./LICENSE)
32   !!----------------------------------------------------------------------
33CONTAINS
34
35   SUBROUTINE Agrif_Update_Trc( )
36      !!----------------------------------------------------------------------
37      !!                   *** ROUTINE Agrif_Update_Trc ***
38      !!----------------------------------------------------------------------
39      !
40      IF (Agrif_Root()) RETURN 
41      !
42      Agrif_UseSpecialValueInUpdate = .TRUE.
43      Agrif_SpecialValueFineGrid    = 0._wp
44      !
45# if ! defined DECAL_FEEDBACK
46      CALL Agrif_Update_Variable(trn_id, procname=updateTRC )
47!      CALL Agrif_Update_Variable( trn_id, locupdate=(/0,2/), procname=updateTRC )
48# else
49      CALL Agrif_Update_Variable(trn_id, locupdate=(/1,0/),procname=updateTRC )
50!      CALL Agrif_Update_Variable( trn_id, locupdate=(/1,2/), procname=updateTRC )
51# endif
52      !
53      Agrif_UseSpecialValueInUpdate = .FALSE.
54      !
55   END SUBROUTINE Agrif_Update_Trc
56
57#ifdef key_vertical
58   SUBROUTINE updateTRC( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before )
59      !!---------------------------------------------
60      !!           *** ROUTINE updateT ***
61      !!---------------------------------------------
62      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2
63      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres
64      LOGICAL, INTENT(in) :: before
65      !!
66      INTEGER :: ji,jj,jk,jn
67      REAL(wp) :: ztb, ztnu, ztno
68      REAL(wp) :: h_in(k1:k2)
69      REAL(wp) :: h_out(1:jpk)
70      INTEGER  :: N_in, N_out
71      REAL(wp) :: h_diff
72      REAL(wp) :: tabin(k1:k2,1:jptra)
73      REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk,1:jptra) :: tabres_child
74      !!---------------------------------------------
75      !
76      IF (before) THEN
77         AGRIF_SpecialValue = -999._wp
78         DO jn = n1,n2-1
79            DO jk=k1,k2
80               DO jj=j1,j2
81                  DO ji=i1,i2
82                     tabres(ji,jj,jk,jn) = (tr(ji,jj,jk,jn,Kmm_a) * e3t(ji,jj,jk,Kmm_a) ) &
83                                           * tmask(ji,jj,jk) + (tmask(ji,jj,jk)-1)*999._wp
84                  END DO
85               END DO
86            END DO
87         END DO
88         DO jk=k1,k2
89            DO jj=j1,j2
90               DO ji=i1,i2
91                  tabres(ji,jj,jk,n2) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm_a) &
92                                           + (tmask(ji,jj,jk)-1)*999._wp
93               END DO
94            END DO
95         END DO
96      ELSE
97         tabres_child(:,:,:,:) = 0.
98         AGRIF_SpecialValue = 0._wp
99         DO jj=j1,j2
100            DO ji=i1,i2
101               N_in = 0
102               DO jk=k1,k2 !k2 = jpk of child grid
103                  IF (tabres(ji,jj,jk,n2) == 0  ) EXIT
104                  N_in = N_in + 1
105                  tabin(jk,:) = tabres(ji,jj,jk,n1:n2-1)/tabres(ji,jj,jk,n2)
106                  h_in(N_in) = tabres(ji,jj,jk,n2)
107               ENDDO
108               N_out = 0
109               DO jk=1,jpk ! jpk of parent grid
110                  IF (tmask(ji,jj,jk) < -900) EXIT ! TODO: Will not work with ISF
111                  N_out = N_out + 1
112                  h_out(N_out) = e3t(ji,jj,jk,Kmm_a) !Parent grid scale factors. Could multiply by e1e2t here instead of division above
113               ENDDO
114               IF (N_in > 0) THEN !Remove this?
115                  h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in))
116                  IF (h_diff < -1.e-4) THEN
117                     print *,'CHECK YOUR bathy T points ...',ji,jj,h_diff,sum(h_in(1:N_in)),sum(h_out(1:N_out))
118                     print *,h_in(1:N_in)
119                     print *,h_out(1:N_out)
120                     STOP
121                  ENDIF
122                  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)
123               ENDIF
124            ENDDO
125         ENDDO
126         !
127         IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN
128            ! Add asselin part
129            DO jn = 1,jptra
130               DO jk=1,jpkm1
131                  DO jj=j1,j2
132                     DO ji=i1,i2
133                        IF( tabres_child(ji,jj,jk,jn) .NE. 0. ) THEN
134                           ztb  = tr(ji,jj,jk,jn,Kbb_a) * e3t(ji,jj,jk,Kbb_a) ! fse3t_b prior update should be used
135                           ztnu = tabres_child(ji,jj,jk,jn) * e3t(ji,jj,jk,Kmm_a)
136                           ztno = tr(ji,jj,jk,jn,Kmm_a) * e3t(ji,jj,jk,Krhs_a)
137                           tr(ji,jj,jk,jn,Kbb_a) = ( ztb + atfp * ( ztnu - ztno) )  & 
138                                     &        * tmask(ji,jj,jk) / e3t(ji,jj,jk,Kbb_a)
139                        ENDIF
140                     ENDDO
141                  ENDDO
142               ENDDO
143            ENDDO
144         ENDIF
145         DO jn = 1,jptra
146            DO jk=1,jpkm1
147               DO jj=j1,j2
148                  DO ji=i1,i2
149                     IF( tabres_child(ji,jj,jk,jn) .NE. 0. ) THEN
150                        tr(ji,jj,jk,jn,Kmm_a) = tabres_child(ji,jj,jk,jn)
151                     END IF
152                  END DO
153               END DO
154            END DO
155         END DO
156         !
157         IF  ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN
158            tr(i1:i2,j1:j2,1:jpkm1,1:jptra,Kbb_a)  = tr(i1:i2,j1:j2,1:jpkm1,1:jptra,Kmm_a)
159         ENDIF
160         !
161
162      ENDIF
163      !
164   END SUBROUTINE updateTRC
165
166
167#else
168   SUBROUTINE updateTRC( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before )
169      !!----------------------------------------------------------------------
170      !!                      *** ROUTINE updateTRC ***
171      !!----------------------------------------------------------------------
172      INTEGER                                    , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2, n1, n2
173      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) ::   tabres
174      LOGICAL                                    , INTENT(in   ) ::   before
175      !!
176      INTEGER :: ji,jj,jk,jn
177      REAL(wp) :: ztb, ztnu, ztno
178      !!----------------------------------------------------------------------
179      !
180      !
181      IF (before) THEN
182         DO jn = n1,n2
183            DO jk=k1,k2
184               DO jj=j1,j2
185                  DO ji=i1,i2
186!> jc tmp
187                     tabres(ji,jj,jk,jn) = tr(ji,jj,jk,jn,Kmm_a)  * e3t(ji,jj,jk,Kmm_a) / e3t_0(ji,jj,jk)
188!                     tabres(ji,jj,jk,jn) = tr(ji,jj,jk,jn,Kmm_a)  * e3t(ji,jj,jk,Kmm_a)
189!< jc tmp
190                  END DO
191               END DO
192            END DO
193         END DO
194      ELSE
195!> jc tmp
196         DO jn = n1,n2
197            tabres(i1:i2,j1:j2,k1:k2,jn) =  tabres(i1:i2,j1:j2,k1:k2,jn) * e3t_0(i1:i2,j1:j2,k1:k2) &
198                                         & * tmask(i1:i2,j1:j2,k1:k2)
199         ENDDO
200!< jc tmp
201         IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN
202            ! Add asselin part
203            DO jn = n1,n2
204               DO jk=k1,k2
205                  DO jj=j1,j2
206                     DO ji=i1,i2
207                        IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN
208                           ztb  = tr(ji,jj,jk,jn,Kbb_a) * e3t(ji,jj,jk,Kbb_a) ! fse3t_b prior update should be used
209                           ztnu = tabres(ji,jj,jk,jn)
210                           ztno = tr(ji,jj,jk,jn,Kmm_a) * e3t(ji,jj,jk,Krhs_a)
211                           tr(ji,jj,jk,jn,Kbb_a) = ( ztb + atfp * ( ztnu - ztno) )  & 
212                                     &        * tmask(ji,jj,jk) / e3t(ji,jj,jk,Kbb_a)
213                        ENDIF
214                     ENDDO
215                  ENDDO
216               ENDDO
217            ENDDO
218         ENDIF
219         DO jn = n1,n2
220            DO jk=k1,k2
221               DO jj=j1,j2
222                  DO ji=i1,i2
223                     IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN
224                        tr(ji,jj,jk,jn,Kmm_a) = tabres(ji,jj,jk,jn) / e3t(ji,jj,jk,Kmm_a)
225                     END IF
226                  END DO
227               END DO
228            END DO
229         END DO
230         !
231         IF  ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN
232            tr(i1:i2,j1:j2,k1:k2,n1:n2,Kbb_a)  = tr(i1:i2,j1:j2,k1:k2,n1:n2,Kmm_a)
233         ENDIF
234         !
235      ENDIF
236      !
237   END SUBROUTINE updateTRC
238#endif
239
240#else
241   !!----------------------------------------------------------------------
242   !!   Empty module                                           no TOP AGRIF
243   !!----------------------------------------------------------------------
244CONTAINS
245   SUBROUTINE agrif_top_update_empty
246      WRITE(*,*)  'agrif_top_update : You should not have seen this print! error?'
247   END SUBROUTINE agrif_top_update_empty
248#endif
249
250   !!======================================================================
251END MODULE agrif_top_update
Note: See TracBrowser for help on using the repository browser.