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

Last change on this file since 1587 was 1587, checked in by ctlod, 15 years ago

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