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 @ 469

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

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