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

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

RB:nemo_v1_update_038: first integration of Agrif :

change key_AGRIF to key_agrif in NST_SRC

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