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 trunk/NEMO/NST_SRC – NEMO

source: trunk/NEMO/NST_SRC/agrif_opa_update.F90 @ 453

Last change on this file since 453 was 453, checked in by opalod, 18 years ago

nemo_v1_bugfix_043:RB: correct a critical bug to update dynamics with agrif
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 9.9 KB
Line 
1#define TWO_WAY
2
3      Module agrif_opa_update
4#if defined key_agrif
5      USE par_oce
6      USE oce
7      USE dom_oce
8     
9      Integer, Parameter :: nbclineupdate = 3
10      Integer :: nbcline
11
12      Contains
13
14      Subroutine Agrif_Update_Tra( kt )
15!
16!     Modules used:
17!
18
19      implicit none
20!
21!     Declarations:
22      INTEGER :: kt
23!
24!
25!     Variables
26!
27      Real :: tabtemp(jpi,jpj,jpk)
28!
29!     Begin
30!
31
32      IF ((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) Return
33#if defined TWO_WAY
34      Agrif_UseSpecialValueInUpdate = .TRUE.
35      Agrif_SpecialValueFineGrid = 0.
36      IF (mod(nbcline,nbclineupdate) == 0) THEN
37      Call Agrif_Update_Variable(tabtemp,tn, procname=updateT)
38      Call Agrif_Update_Variable(tabtemp,sn, procname=updateS)
39      ELSE
40      Call Agrif_Update_Variable(tabtemp,tn,locupdate=(/0,2/), procname=updateT)
41      Call Agrif_Update_Variable(tabtemp,sn,locupdate=(/0,2/), procname=updateS)
42      ENDIF
43
44
45      Agrif_UseSpecialValueInUpdate = .FALSE.
46#endif
47
48      Return
49      End subroutine Agrif_Update_Tra
50
51      Subroutine Agrif_Update_Dyn( kt )
52!
53!     Modules used:
54!
55!
56!     Declarations:
57!
58      INTEGER :: kt
59!
60!     Variables
61!
62      Real :: tabtemp(jpi,jpj,jpk)
63      Real :: tabtemp2d(jpi,jpj)
64!
65!     Begin
66!
67!
68       
69      IF ((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) Return
70#if defined TWO_WAY
71
72      IF (mod(nbcline,nbclineupdate) == 0) THEN
73      Call Agrif_Update_Variable(tabtemp,un,procname = updateU)
74      Call Agrif_Update_Variable(tabtemp,vn,procname = updateV)
75      ELSE
76      Call Agrif_Update_Variable(tabtemp,un,locupdate=(/0,1/),procname = updateU)
77      Call Agrif_Update_Variable(tabtemp,vn,locupdate=(/0,1/),procname = updateV)         
78      ENDIF
79
80      Call Agrif_Update_Variable(tabtemp2d,e1u,procname = updateU2d)
81      Call Agrif_Update_Variable(tabtemp2d,e2v,procname = updateV2d) 
82     
83      nbcline = nbcline + 1
84
85       Agrif_UseSpecialValueInUpdate = .TRUE.
86       Agrif_SpecialValueFineGrid = 0.
87       Call Agrif_Update_Variable(tabtemp2d,sshn,procname = updateSSH)
88       Agrif_UseSpecialValueInUpdate = .FALSE.
89
90
91      Call Agrif_ChildGrid_To_ParentGrid()
92      Call recompute_diags( kt )
93      Call Agrif_ParentGrid_To_ChildGrid()
94
95#endif
96!
97      Return
98      End subroutine Agrif_Update_Dyn
99
100      Subroutine recompute_diags(kt)
101      Use divcur
102      Use wzvmod
103      Use cla_div
104      Use  ocfzpt
105      Implicit None
106      INTEGER kt
107     
108      ta = hdivb
109      sa = rotb
110      CALL oc_fz_pt
111      Call div_cur(kt)
112
113      hdivb = ta
114      rotb  = sa
115
116      IF( n_cla == 1 ) CALL div_cla( kt )
117      Call wzv( kt )
118     
119      End Subroutine recompute_diags
120
121       subroutine updateT(tabres,i1,i2,j1,j2,k1,k2,before)
122       Implicit none
123#  include "domzgr_substitute.h90"
124       integer i1,i2,j1,j2,k1,k2
125       integer ji,jj,jk
126       real,dimension(i1:i2,j1:j2,k1:k2) :: tabres
127       LOGICAL :: before
128
129       IF (before) THEN
130       
131         DO jk=k1,k2
132           DO jj=j1,j2
133             DO ji=i1,i2
134               tabres(ji,jj,jk) = tn(ji,jj,jk)
135             ENDDO
136           ENDDO
137         ENDDO
138         
139       ELSE
140
141         DO jk=k1,k2
142           DO jj=j1,j2
143             DO ji=i1,i2
144               IF (tabres(ji,jj,jk).NE.0.) THEN
145               tn(ji,jj,jk) = tabres(ji,jj,jk) * tmask(ji,jj,jk)
146               ENDIF
147             ENDDO
148            ENDDO
149          ENDDO
150       ENDIF
151
152       end subroutine updateT
153
154       
155       subroutine updateS(tabres,i1,i2,j1,j2,k1,k2,before)
156       Implicit none
157#  include "domzgr_substitute.h90"
158       integer i1,i2,j1,j2,k1,k2
159       integer ji,jj,jk
160       real,dimension(i1:i2,j1:j2,k1:k2) :: tabres
161       LOGICAL :: before
162
163
164       IF (before) THEN
165       
166         DO jk=k1,k2
167           DO jj=j1,j2
168             DO ji=i1,i2
169               tabres(ji,jj,jk) = sn(ji,jj,jk)
170             ENDDO
171           ENDDO
172         ENDDO
173         
174       ELSE
175
176         DO jk=k1,k2
177           DO jj=j1,j2
178             DO ji=i1,i2
179               IF (tabres(ji,jj,jk).NE.0.) THEN
180               sn(ji,jj,jk) = tabres(ji,jj,jk) * tmask(ji,jj,jk)
181               ENDIF
182             ENDDO
183           ENDDO
184         ENDDO
185       ENDIF
186
187       end subroutine updateS
188
189       subroutine updateu(tabres,i1,i2,j1,j2,k1,k2,before)
190       Implicit none
191#  include "domzgr_substitute.h90"
192       integer i1,i2,j1,j2,k1,k2
193       integer ji,jj,jk
194       real,dimension(i1:i2,j1:j2,k1:k2) :: tabres
195       LOGICAL :: before
196       REAL(wp) :: rhoy
197
198
199       IF (before) THEN
200       
201       rhoy = Agrif_Rhoy()
202       
203         DO jk=k1,k2
204           DO jj=j1,j2
205             DO ji=i1,i2
206               tabres(ji,jj,jk) = e2u(ji,jj) * un(ji,jj,jk)
207#if defined key_partial_steps
208               tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3u(ji,jj,jk)
209#endif
210             ENDDO
211           ENDDO
212         ENDDO
213 
214         tabres = rhoy * tabres
215 
216       ELSE
217
218         DO jk=k1,k2
219           DO jj=j1,j2
220             DO ji=i1,i2
221               un(ji,jj,jk) = tabres(ji,jj,jk) / (e2u(ji,jj))
222               un(ji,jj,jk) = un(ji,jj,jk) * umask(ji,jj,jk)
223#if defined key_partial_steps
224               un(ji,jj,jk) = un(ji,jj,jk) / fse3u(ji,jj,jk)
225#endif
226       ENDDO
227       ENDDO
228       ENDDO
229       ENDIF
230
231       end subroutine updateu
232
233       subroutine updatev(tabres,i1,i2,j1,j2,k1,k2,before)
234       Implicit none
235#  include "domzgr_substitute.h90"
236       integer i1,i2,j1,j2,k1,k2
237       integer ji,jj,jk
238       real,dimension(i1:i2,j1:j2,k1:k2) :: tabres
239       LOGICAL :: before
240       REAL(wp) :: rhox
241
242
243       IF (before) THEN
244       
245       rhox = Agrif_Rhox()
246       
247         DO jk=k1,k2
248           DO jj=j1,j2
249             DO ji=i1,i2
250               tabres(ji,jj,jk) = e1v(ji,jj) * vn(ji,jj,jk)
251#if defined key_partial_steps
252               tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3v(ji,jj,jk)
253#endif
254             ENDDO
255           ENDDO
256         ENDDO
257 
258        tabres = rhox * tabres
259 
260       ELSE
261
262         DO jk=k1,k2
263           DO jj=j1,j2
264             DO ji=i1,i2
265               vn(ji,jj,jk) = tabres(ji,jj,jk) / (e1v(ji,jj))
266               vn(ji,jj,jk) = vn(ji,jj,jk) * vmask(ji,jj,jk)
267#if defined key_partial_steps
268               vn(ji,jj,jk) = vn(ji,jj,jk) / fse3v(ji,jj,jk)
269#endif
270       ENDDO
271       ENDDO
272       ENDDO
273       ENDIF
274
275       end subroutine updatev
276
277       subroutine updateu2d(tabres,i1,i2,j1,j2,before)
278       Implicit none
279#  include "domzgr_substitute.h90"
280       integer i1,i2,j1,j2
281       integer ji,jj,jk
282       real,dimension(i1:i2,j1:j2) :: tabres
283       LOGICAL :: before
284       REAL(wp) :: rhoy
285       REAL(wp) :: hinv
286
287
288       IF (before) THEN
289       
290       rhoy = Agrif_Rhoy()
291       
292           DO jk = 1,jpkm1
293             DO jj=j1,j2
294             DO ji=i1,i2
295                tabres(ji,jj) = tabres(ji,jj) + fse3u(ji,jj,jk) * un(ji,jj,jk)
296             ENDDO
297             ENDDO
298           ENDDO
299           
300           DO jj=j1,j2
301           DO ji=i1,i2
302             tabres(ji,jj) = tabres(ji,jj) * e2u(ji,jj)
303           ENDDO
304           ENDDO
305   
306          tabres = rhoy * tabres
307   
308       ELSE
309
310           DO jj=j1,j2
311             DO ji=i1,i2
312               IF (umask(ji,jj,1) .NE. 0.) THEN             
313               spgu(ji,jj) = 0.
314               Do jk=1,jpk
315                spgu(ji,jj) = spgu(ji,jj) + fse3u(ji,jj,jk) * un(ji,jj,jk)
316               EndDo
317               spgu(ji,jj) = spgu(ji,jj) * e2u(ji,jj)
318               hinv = (tabres(ji,jj)-spgu(ji,jj))/(hu(ji,jj)*e2u(ji,jj))
319               Do jk=1,jpk             
320               un(ji,jj,jk) = un(ji,jj,jk) + hinv
321               un(ji,jj,jk) = un(ji,jj,jk) * umask(ji,jj,jk)           
322               EndDo
323               ENDIF
324             ENDDO
325           ENDDO
326       ENDIF
327
328       end subroutine updateu2d
329
330       subroutine updatev2d(tabres,i1,i2,j1,j2,before)
331       Implicit none
332       integer i1,i2,j1,j2
333       integer ji,jj,jk
334       real,dimension(i1:i2,j1:j2) :: tabres
335       LOGICAL :: before
336       REAL(wp) :: rhox
337       REAL(wp) :: hinv
338
339
340       IF (before) THEN
341       
342       rhox = Agrif_Rhox()
343       
344           tabres = 0.
345           
346           DO jk = 1,jpkm1
347             DO jj=j1,j2
348             DO ji=i1,i2
349                tabres(ji,jj) = tabres(ji,jj) + fse3v(ji,jj,jk) * vn(ji,jj,jk)
350             ENDDO
351             ENDDO
352           ENDDO
353           
354           DO jj=j1,j2
355           DO ji=i1,i2
356              tabres(ji,jj) = tabres(ji,jj) * e1v(ji,jj)
357           ENDDO
358           ENDDO
359   
360         tabres = rhox * tabres
361   
362       ELSE
363
364           DO jj=j1,j2
365             DO ji=i1,i2
366               IF (vmask(ji,jj,1) .NE. 0.) THEN             
367               spgv(ji,jj) = 0.
368               Do jk=1,jpk
369                spgv(ji,jj) = spgv(ji,jj) + fse3v(ji,jj,jk) * vn(ji,jj,jk)
370               EndDo
371               spgv(ji,jj) = spgv(ji,jj) * e1v(ji,jj)
372               hinv = (tabres(ji,jj)-spgv(ji,jj))/(hv(ji,jj)*e1v(ji,jj))
373
374               Do jk=1,jpk             
375               vn(ji,jj,jk) = vn(ji,jj,jk) + hinv
376               vn(ji,jj,jk) = vn(ji,jj,jk) * vmask(ji,jj,jk)
377               EndDo
378               ENDIF
379           ENDDO
380           ENDDO
381           
382       ENDIF
383
384       end subroutine updatev2d
385
386       subroutine updateSSH(tabres,i1,i2,j1,j2,before)
387       Implicit none
388#  include "domzgr_substitute.h90"
389       integer i1,i2,j1,j2
390       integer ji,jj
391       real,dimension(i1:i2,j1:j2) :: tabres
392       LOGICAL :: before
393       REAL(wp) :: rhox, rhoy
394
395
396       IF (before) THEN
397       rhox = Agrif_Rhox()
398       rhoy = Agrif_Rhoy()
399       
400           DO jj=j1,j2
401             DO ji=i1,i2
402               tabres(ji,jj) = e1t(ji,jj) * e2t(ji,jj) * sshn(ji,jj)
403             ENDDO
404           ENDDO
405   
406         tabres = rhox * rhoy * tabres
407 
408       ELSE
409           DO jj=j1,j2
410             DO ji=i1,i2
411               sshn(ji,jj) = tabres(ji,jj) / (e1t(ji,jj) * e2t(ji,jj))
412               sshn(ji,jj) = sshn(ji,jj) * tmask(ji,jj,1)
413       ENDDO
414       ENDDO
415       ENDIF
416
417       end subroutine updateSSH
418       
419#else
420       CONTAINS
421       subroutine agrif_opa_update_empty
422       end subroutine agrif_opa_update_empty
423#endif
424       End Module agrif_opa_update
Note: See TracBrowser for help on using the repository browser.