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_opa_update.F90 in branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/NST_SRC – NEMO

source: branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/NST_SRC/agrif_opa_update.F90 @ 4486

Last change on this file since 4486 was 4486, checked in by jchanut, 10 years ago

Finalize Time split and AGRIF (tickets #106 and #107) + ticket #1240
  • Property svn:keywords set to Id
File size: 12.8 KB
Line 
1#define TWO_WAY
2
3MODULE agrif_opa_update
4#if defined key_agrif  && ! defined key_offline
5   USE par_oce
6   USE oce
7   USE dom_oce
8   USE agrif_oce
9   USE in_out_manager  ! I/O manager
10   USE lib_mpp
11   USE wrk_nemo 
12   USE dynspg_oce
13
14   IMPLICIT NONE
15   PRIVATE
16
17   PUBLIC Agrif_Update_Tra, Agrif_Update_Dyn
18
19   INTEGER, PUBLIC :: nbcline = 0
20
21   !!----------------------------------------------------------------------
22   !! NEMO/NST 3.3 , NEMO Consortium (2010)
23   !! $Id$
24   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
25   !!----------------------------------------------------------------------
26
27CONTAINS
28
29   SUBROUTINE Agrif_Update_Tra( kt )
30      !!---------------------------------------------
31      !!   *** ROUTINE Agrif_Update_Tra ***
32      !!---------------------------------------------
33      !!
34      INTEGER, INTENT(in) :: kt
35      REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztab
36
37
38      IF((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) RETURN
39#if defined TWO_WAY
40      CALL wrk_alloc( jpi, jpj, jpk, jpts, ztab )
41
42      Agrif_UseSpecialValueInUpdate = .TRUE.
43      Agrif_SpecialValueFineGrid = 0.
44
45      IF (MOD(nbcline,nbclineupdate) == 0) THEN
46         CALL Agrif_Update_Variable(ztab,tsn_id, procname=updateTS)
47      ELSE
48         CALL Agrif_Update_Variable(ztab,tsn_id,locupdate=(/0,2/), procname=updateTS)
49      ENDIF
50
51      Agrif_UseSpecialValueInUpdate = .FALSE.
52
53      CALL wrk_dealloc( jpi, jpj, jpk, jpts, ztab )
54#endif
55
56   END SUBROUTINE Agrif_Update_Tra
57
58   SUBROUTINE Agrif_Update_Dyn( kt )
59      !!---------------------------------------------
60      !!   *** ROUTINE Agrif_Update_Dyn ***
61      !!---------------------------------------------
62      !!
63      INTEGER, INTENT(in) :: kt
64      REAL(wp), POINTER, DIMENSION(:,:) :: ztab2d
65      REAL(wp), POINTER, DIMENSION(:,:,:) :: ztab
66
67
68      IF ((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) Return
69#if defined TWO_WAY
70      CALL wrk_alloc( jpi, jpj,      ztab2d )
71      CALL wrk_alloc( jpi, jpj, jpk, ztab   )
72
73      IF (mod(nbcline,nbclineupdate) == 0) THEN
74         CALL Agrif_Update_Variable(ztab,un_id,procname = updateU)
75         CALL Agrif_Update_Variable(ztab,vn_id,procname = updateV)
76      ELSE
77         CALL Agrif_Update_Variable(ztab,un_id,locupdate=(/0,1/),procname = updateU)
78         CALL Agrif_Update_Variable(ztab,vn_id,locupdate=(/0,1/),procname = updateV)         
79      ENDIF
80
81      CALL Agrif_Update_Variable(ztab2d,e1u_id,procname = updateU2d)
82      CALL Agrif_Update_Variable(ztab2d,e2v_id,procname = updateV2d)
83
84#if defined key_dynspg_ts
85      IF (ln_bt_fw) THEN
86         ! Update time integrated transports
87         IF (mod(nbcline,nbclineupdate) == 0) THEN
88            CALL Agrif_Update_Variable(ztab2d,ub2b_id,procname = updateub2b)
89            CALL Agrif_Update_Variable(ztab2d,vb2b_id,procname = updatevb2b)
90         ELSE
91            CALL Agrif_Update_Variable(ztab2d,ub2b_id,locupdate=(/0,1/),procname = updateub2b)
92            CALL Agrif_Update_Variable(ztab2d,vb2b_id,locupdate=(/0,1/),procname = updatevb2b)
93         ENDIF
94      END IF 
95#endif
96
97      nbcline = nbcline + 1
98
99      Agrif_UseSpecialValueInUpdate = .TRUE. 
100      Agrif_SpecialValueFineGrid = 0.
101      CALL Agrif_Update_Variable(ztab2d,sshn_id,procname = updateSSH)
102      Agrif_UseSpecialValueInUpdate = .FALSE.
103
104      CALL wrk_dealloc( jpi, jpj,      ztab2d )
105      CALL wrk_dealloc( jpi, jpj, jpk, ztab   )
106
107!Done in step
108!      CALL Agrif_ChildGrid_To_ParentGrid()
109!      CALL recompute_diags( kt )
110!      CALL Agrif_ParentGrid_To_ChildGrid()
111
112#endif
113
114   END SUBROUTINE Agrif_Update_Dyn
115
116   SUBROUTINE recompute_diags( kt )
117      !!---------------------------------------------
118      !!   *** ROUTINE recompute_diags ***
119      !!---------------------------------------------
120      INTEGER, INTENT(in) :: kt
121
122   END SUBROUTINE recompute_diags
123
124   SUBROUTINE updateTS( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before )
125      !!---------------------------------------------
126      !!           *** ROUTINE updateT ***
127      !!---------------------------------------------
128#  include "domzgr_substitute.h90"
129
130      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2
131      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres
132      LOGICAL, iNTENT(in) :: before
133
134      INTEGER :: ji,jj,jk,jn
135
136      IF (before) THEN
137         DO jn = n1,n2
138            DO jk=k1,k2
139               DO jj=j1,j2
140                  DO ji=i1,i2
141                     tabres(ji,jj,jk,jn) = tsn(ji,jj,jk,jn)
142                  END DO
143               END DO
144            END DO
145         END DO
146      ELSE
147         DO jn = n1,n2
148            DO jk=k1,k2
149               DO jj=j1,j2
150                  DO ji=i1,i2
151                     IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN
152                         tsn(ji,jj,jk,jn) = tabres(ji,jj,jk,jn) * tmask(ji,jj,jk)
153                     END IF
154                  END DO
155               END DO
156            END DO
157         END DO
158      ENDIF
159
160   END SUBROUTINE updateTS
161
162   SUBROUTINE updateu( tabres, i1, i2, j1, j2, k1, k2, before )
163      !!---------------------------------------------
164      !!           *** ROUTINE updateu ***
165      !!---------------------------------------------
166#  include "domzgr_substitute.h90"
167
168      INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2
169      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres
170      LOGICAL, INTENT(in) :: before
171
172      INTEGER :: ji, jj, jk
173      REAL(wp) :: zrhoy
174
175      IF (before) THEN
176         zrhoy = Agrif_Rhoy()
177         DO jk=k1,k2
178            DO jj=j1,j2
179               DO ji=i1,i2
180                  tabres(ji,jj,jk) = e2u(ji,jj) * un(ji,jj,jk)
181                  tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3u(ji,jj,jk)
182               END DO
183            END DO
184         END DO
185         tabres = zrhoy * tabres
186      ELSE
187         DO jk=k1,k2
188            DO jj=j1,j2
189               DO ji=i1,i2
190                  un(ji,jj,jk) = tabres(ji,jj,jk) / (e2u(ji,jj))
191                  un(ji,jj,jk) = un(ji,jj,jk) * umask(ji,jj,jk)
192                  un(ji,jj,jk) = un(ji,jj,jk) / fse3u(ji,jj,jk)
193               END DO
194            END DO
195         END DO
196      ENDIF
197
198   END SUBROUTINE updateu
199
200   SUBROUTINE updatev( tabres, i1, i2, j1, j2, k1, k2, before )
201      !!---------------------------------------------
202      !!           *** ROUTINE updatev ***
203      !!---------------------------------------------
204#  include "domzgr_substitute.h90"
205
206      INTEGER :: i1,i2,j1,j2,k1,k2
207      INTEGER :: ji,jj,jk
208      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: tabres
209      LOGICAL :: before
210
211      REAL(wp) :: zrhox
212
213      IF (before) THEN
214         zrhox = Agrif_Rhox()
215         DO jk=k1,k2
216            DO jj=j1,j2
217               DO ji=i1,i2
218                  tabres(ji,jj,jk) = e1v(ji,jj) * vn(ji,jj,jk)
219                  tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3v(ji,jj,jk)
220               END DO
221            END DO
222         END DO
223         tabres = zrhox * tabres
224      ELSE
225         DO jk=k1,k2
226            DO jj=j1,j2
227               DO ji=i1,i2
228                  vn(ji,jj,jk) = tabres(ji,jj,jk) / (e1v(ji,jj))
229                  vn(ji,jj,jk) = vn(ji,jj,jk) * vmask(ji,jj,jk)
230                  vn(ji,jj,jk) = vn(ji,jj,jk) / fse3v(ji,jj,jk)
231               END DO
232            END DO
233         END DO
234      ENDIF
235
236   END SUBROUTINE updatev
237
238   SUBROUTINE updateu2d( tabres, i1, i2, j1, j2, before )
239      !!---------------------------------------------
240      !!          *** ROUTINE updateu2d ***
241      !!---------------------------------------------
242#  include "domzgr_substitute.h90"
243
244      INTEGER, INTENT(in) :: i1, i2, j1, j2
245      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
246      LOGICAL, INTENT(in) :: before
247
248      INTEGER :: ji, jj, jk
249      REAL(wp) :: zrhoy
250      REAL(wp) :: zhinv
251
252      IF (before) THEN
253         zrhoy = Agrif_Rhoy()
254         DO jj=j1,j2
255            DO ji=i1,i2
256               tabres(ji,jj) = un_b(ji,jj) * hu(ji,jj) * e2u(ji,jj)
257            END DO
258         END DO
259         tabres = zrhoy * tabres
260      ELSE
261         DO jj=j1,j2
262            DO ji=i1,i2
263               IF(umask(ji,jj,1) .NE. 0.) THEN             
264                  spgu(ji,jj) = 0.e0
265                  DO jk=1,jpk
266                     spgu(ji,jj) = spgu(ji,jj) + fse3u(ji,jj,jk) * un(ji,jj,jk)
267                  END DO
268                  spgu(ji,jj) = spgu(ji,jj) * e2u(ji,jj)
269                  zhinv = (tabres(ji,jj)-spgu(ji,jj))/(hu(ji,jj)*e2u(ji,jj))
270                  Do jk=1,jpk             
271                     un(ji,jj,jk) = un(ji,jj,jk) + zhinv
272                     un(ji,jj,jk) = un(ji,jj,jk) * umask(ji,jj,jk)           
273                  END DO
274               ENDIF
275               ! Update barotropic velocities:
276               un_b(ji,jj) = tabres(ji,jj) * hur(ji,jj) / e2u(ji,jj)
277            END DO
278         END DO
279      ENDIF
280
281   END SUBROUTINE updateu2d
282
283   SUBROUTINE updatev2d( tabres, i1, i2, j1, j2, before )
284      !!---------------------------------------------
285      !!          *** ROUTINE updatev2d ***
286      !!---------------------------------------------
287
288      INTEGER, INTENT(in) :: i1, i2, j1, j2
289      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
290      LOGICAL, INTENT(in) :: before
291
292      INTEGER :: ji, jj, jk
293      REAL(wp) :: zrhox
294      REAL(wp) :: zhinv
295
296      IF (before) THEN
297         zrhox = Agrif_Rhox()
298         DO jj=j1,j2
299            DO ji=i1,i2
300               tabres(ji,jj) = vn_b(ji,jj) * hv(ji,jj) * e1v(ji,jj) 
301            END DO
302         END DO
303         tabres = zrhox * tabres
304      ELSE
305         DO jj=j1,j2
306            DO ji=i1,i2
307               IF(vmask(ji,jj,1) .NE. 0.) THEN             
308                  spgv(ji,jj) = 0.
309                  DO jk=1,jpk
310                     spgv(ji,jj) = spgv(ji,jj) + fse3v(ji,jj,jk) * vn(ji,jj,jk)
311                  END DO
312                  spgv(ji,jj) = spgv(ji,jj) * e1v(ji,jj)
313                  zhinv = (tabres(ji,jj)-spgv(ji,jj))/(hv(ji,jj)*e1v(ji,jj))
314                  DO jk=1,jpk             
315                     vn(ji,jj,jk) = vn(ji,jj,jk) + zhinv
316                     vn(ji,jj,jk) = vn(ji,jj,jk) * vmask(ji,jj,jk)
317                  END DO
318               ENDIF
319               ! Update barotropic velocities:
320               vn_b(ji,jj) = tabres(ji,jj) * hvr(ji,jj) / e1v(ji,jj)
321            END DO
322         END DO
323      ENDIF
324
325   END SUBROUTINE updatev2d
326
327   SUBROUTINE updateSSH( tabres, i1, i2, j1, j2, before )
328      !!---------------------------------------------
329      !!          *** ROUTINE updateSSH ***
330      !!---------------------------------------------
331#  include "domzgr_substitute.h90"
332
333      INTEGER, INTENT(in) :: i1, i2, j1, j2
334      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
335      LOGICAL, INTENT(in) :: before
336
337      INTEGER :: ji, jj
338
339      IF (before) THEN
340         DO jj=j1,j2
341            DO ji=i1,i2
342               tabres(ji,jj) = sshn(ji,jj)
343            END DO
344         END DO
345      ELSE
346         DO jj=j1,j2
347            DO ji=i1,i2
348               sshn(ji,jj) = tabres(ji,jj) * tmask(ji,jj,1)
349            END DO
350         END DO
351      ENDIF
352
353   END SUBROUTINE updateSSH
354
355   SUBROUTINE updateub2b( tabres, i1, i2, j1, j2, before )
356      !!---------------------------------------------
357      !!          *** ROUTINE updateub2b ***
358      !!---------------------------------------------
359
360      INTEGER, INTENT(in) :: i1, i2, j1, j2
361      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
362      LOGICAL, INTENT(in) :: before
363
364      INTEGER :: ji, jj
365      REAL(wp) :: zrhoy
366
367      IF (before) THEN
368         zrhoy = Agrif_Rhoy()
369         DO jj=j1,j2
370            DO ji=i1,i2
371               tabres(ji,jj) = ub2_i_b(ji,jj) * e2u(ji,jj)
372            END DO
373         END DO
374         tabres = zrhoy * tabres
375      ELSE
376         DO jj=j1,j2
377            DO ji=i1,i2
378               ub2_b(ji,jj) = tabres(ji,jj) / e2u(ji,jj)
379            END DO
380         END DO
381      ENDIF
382
383   END SUBROUTINE updateub2b
384
385   SUBROUTINE updatevb2b( tabres, i1, i2, j1, j2, before )
386      !!---------------------------------------------
387      !!          *** ROUTINE updatevb2b ***
388      !!---------------------------------------------
389
390      INTEGER, INTENT(in) :: i1, i2, j1, j2
391      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
392      LOGICAL, INTENT(in) :: before
393
394      INTEGER :: ji, jj
395      REAL(wp) :: zrhox
396
397      IF (before) THEN
398         zrhox = Agrif_Rhox()
399         DO jj=j1,j2
400            DO ji=i1,i2
401               tabres(ji,jj) = vb2_i_b(ji,jj) * e1v(ji,jj) 
402            END DO
403         END DO
404         tabres = zrhox * tabres
405      ELSE
406         DO jj=j1,j2
407            DO ji=i1,i2
408               vb2_b(ji,jj) = tabres(ji,jj) / e1v(ji,jj)
409            END DO
410         END DO
411      ENDIF
412
413   END SUBROUTINE updatevb2b
414
415#else
416CONTAINS
417   SUBROUTINE agrif_opa_update_empty
418      !!---------------------------------------------
419      !!   *** ROUTINE agrif_opa_update_empty ***
420      !!---------------------------------------------
421      WRITE(*,*)  'agrif_opa_update : You should not have seen this print! error?'
422   END SUBROUTINE agrif_opa_update_empty
423#endif
424END MODULE agrif_opa_update
425
Note: See TracBrowser for help on using the repository browser.