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/branches/2019/dev_r11233_AGRIF-05_jchanut_vert_coord_interp/src/NST – NEMO

source: NEMO/branches/2019/dev_r11233_AGRIF-05_jchanut_vert_coord_interp/src/NST/agrif_top_update.F90 @ 11603

Last change on this file since 11603 was 11603, checked in by jchanut, 5 years ago

#2222, 1) correct time interpolation of barotropic velocities in corners. 2) Clean remapping module and enable remapping several variables at the same time. At this stage, vertical remapping doesn't change VORTEX results with an identical vertical grid ONLY in one way mode and a linearized free surface (within truncature errors).

  • Property svn:keywords set to Id
File size: 9.0 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
22   IMPLICIT NONE
23   PRIVATE
24
25   PUBLIC Agrif_Update_Trc
26
27   !!----------------------------------------------------------------------
28   !! NEMO/NST 4.0 , NEMO Consortium (2018)
29   !! $Id$
30   !! Software governed by the CeCILL license (see ./LICENSE)
31   !!----------------------------------------------------------------------
32CONTAINS
33
34   SUBROUTINE Agrif_Update_Trc( )
35      !!----------------------------------------------------------------------
36      !!                   *** ROUTINE Agrif_Update_Trc ***
37      !!----------------------------------------------------------------------
38      !
39      IF (Agrif_Root()) RETURN 
40      !
41      Agrif_UseSpecialValueInUpdate = .TRUE.
42      Agrif_SpecialValueFineGrid    = 0._wp
43      !
44# if ! defined DECAL_FEEDBACK
45      CALL Agrif_Update_Variable(trn_id, procname=updateTRC )
46!      CALL Agrif_Update_Variable( trn_id, locupdate=(/0,2/), procname=updateTRC )
47# else
48      CALL Agrif_Update_Variable(trn_id, locupdate=(/1,0/),procname=updateTRC )
49!      CALL Agrif_Update_Variable( trn_id, locupdate=(/1,2/), procname=updateTRC )
50# endif
51      !
52      Agrif_UseSpecialValueInUpdate = .FALSE.
53      !
54   END SUBROUTINE Agrif_Update_Trc
55
56#ifdef key_vertical
57   SUBROUTINE updateTRC( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before )
58      !!---------------------------------------------
59      !!           *** ROUTINE updateT ***
60      !!---------------------------------------------
61      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2
62      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres
63      LOGICAL, INTENT(in) :: before
64      !!
65      INTEGER :: ji,jj,jk,jn
66      REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk,n1:n2) :: tabres_child
67      REAL(wp) :: h_in(k1:k2)
68      REAL(wp) :: h_out(1:jpk)
69      INTEGER  :: N_in, N_out
70      REAL(wp) :: h_diff
71      REAL(wp) :: zrho_xy
72      REAL(wp) :: tabin(k1:k2,n1:n2)
73      !!---------------------------------------------
74      !
75      IF (before) THEN
76         AGRIF_SpecialValue = -999._wp
77         zrho_xy = Agrif_rhox() * Agrif_rhoy() 
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) = (trn(ji,jj,jk,jn) * e3t_n(ji,jj,jk) ) &
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_n(ji,jj,jk) &
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_n(ji,jj,jk) !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,jpk
131                  DO jj=j1,j2
132                     DO ji=i1,i2
133                        IF( tabres_child(ji,jj,jk,jn) .NE. 0. ) THEN
134                           trb(ji,jj,jk,jn) = trb(ji,jj,jk,jn) & 
135                                 & + atfp * ( tabres_child(ji,jj,jk,jn) &
136                                 &          - trn(ji,jj,jk,jn) ) * tmask(ji,jj,jk)
137                        ENDIF
138                     ENDDO
139                  ENDDO
140               ENDDO
141            ENDDO
142         ENDIF
143         DO jn = 1,jptra
144            DO jk=1,jpk
145               DO jj=j1,j2
146                  DO ji=i1,i2
147                     IF( tabres_child(ji,jj,jk,jn) .NE. 0. ) THEN
148                        trn(ji,jj,jk,jn) = tabres_child(ji,jj,jk,jn) * tmask(ji,jj,jk)
149                     END IF
150                  END DO
151               END DO
152            END DO
153         END DO
154      ENDIF
155      !
156   END SUBROUTINE updateTRC
157
158
159#else
160   SUBROUTINE updateTRC( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before )
161      !!----------------------------------------------------------------------
162      !!                      *** ROUTINE updateTRC ***
163      !!----------------------------------------------------------------------
164      INTEGER                                    , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2, n1, n2
165      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) ::   tabres
166      LOGICAL                                    , INTENT(in   ) ::   before
167      !!
168      INTEGER :: ji,jj,jk,jn
169      REAL(wp) :: ztb, ztnu, ztno
170      !!----------------------------------------------------------------------
171      !
172      !
173      IF (before) THEN
174         DO jn = n1,n2
175            DO jk=k1,k2
176               DO jj=j1,j2
177                  DO ji=i1,i2
178!> jc tmp
179                     tabres(ji,jj,jk,jn) = trn(ji,jj,jk,jn)  * e3t_n(ji,jj,jk) / e3t_0(ji,jj,jk)
180!                     tabres(ji,jj,jk,jn) = trn(ji,jj,jk,jn)  * e3t_n(ji,jj,jk)
181!< jc tmp
182                  END DO
183               END DO
184            END DO
185         END DO
186      ELSE
187!> jc tmp
188         DO jn = n1,n2
189            tabres(i1:i2,j1:j2,k1:k2,jn) =  tabres(i1:i2,j1:j2,k1:k2,jn) * e3t_0(i1:i2,j1:j2,k1:k2) &
190                                         & * tmask(i1:i2,j1:j2,k1:k2)
191         ENDDO
192!< jc tmp
193         IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN
194            ! Add asselin part
195            DO jn = n1,n2
196               DO jk=k1,k2
197                  DO jj=j1,j2
198                     DO ji=i1,i2
199                        IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN
200                           ztb  = trb(ji,jj,jk,jn) * e3t_b(ji,jj,jk) ! fse3t_b prior update should be used
201                           ztnu = tabres(ji,jj,jk,jn)
202                           ztno = trn(ji,jj,jk,jn) * e3t_a(ji,jj,jk)
203                           trb(ji,jj,jk,jn) = ( ztb + atfp * ( ztnu - ztno) )  & 
204                                     &        * tmask(ji,jj,jk) / e3t_b(ji,jj,jk)
205                        ENDIF
206                     ENDDO
207                  ENDDO
208               ENDDO
209            ENDDO
210         ENDIF
211         DO jn = n1,n2
212            DO jk=k1,k2
213               DO jj=j1,j2
214                  DO ji=i1,i2
215                     IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN
216                        trn(ji,jj,jk,jn) = tabres(ji,jj,jk,jn) / e3t_n(ji,jj,jk)
217                     END IF
218                  END DO
219               END DO
220            END DO
221         END DO
222         !
223         IF  ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN
224            trb(i1:i2,j1:j2,k1:k2,n1:n2)  = trn(i1:i2,j1:j2,k1:k2,n1:n2)
225         ENDIF
226         !
227      ENDIF
228      !
229   END SUBROUTINE updateTRC
230#endif
231
232#else
233   !!----------------------------------------------------------------------
234   !!   Empty module                                           no TOP AGRIF
235   !!----------------------------------------------------------------------
236CONTAINS
237   SUBROUTINE agrif_top_update_empty
238      WRITE(*,*)  'agrif_top_update : You should not have seen this print! error?'
239   END SUBROUTINE agrif_top_update_empty
240#endif
241
242   !!======================================================================
243END MODULE agrif_top_update
Note: See TracBrowser for help on using the repository browser.