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

source: tags/nemo_v3_2_2/NEMO/NST_SRC/agrif_opa_update.F90 @ 2720

Last change on this file since 2720 was 2486, checked in by rblod, 13 years ago

Correct Agrif inconstency for ssh, nemo_v3_2 version, see ticket 669
  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 11.7 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      INTEGER, INTENT(in) :: kt
96
97   END SUBROUTINE recompute_diags
98
99   SUBROUTINE updateT( tabres, i1, i2, j1, j2, k1, k2, before )
100      !!---------------------------------------------
101      !!           *** ROUTINE updateT ***
102      !!---------------------------------------------
103#  include "domzgr_substitute.h90"
104
105      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2
106      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres
107      LOGICAL, iNTENT(in) :: before
108
109      INTEGER :: ji,jj,jk
110
111      IF (before) THEN
112         DO jk=k1,k2
113            DO jj=j1,j2
114               DO ji=i1,i2
115                  tabres(ji,jj,jk) = tn(ji,jj,jk)
116               END DO
117            END DO
118         END DO
119      ELSE
120         DO jk=k1,k2
121            DO jj=j1,j2
122               DO ji=i1,i2
123                  IF( tabres(ji,jj,jk) .NE. 0. ) THEN
124                     tn(ji,jj,jk) = tabres(ji,jj,jk) * tmask(ji,jj,jk)
125                  ENDIF
126               END DO
127            END DO
128         END DO
129      ENDIF
130
131   END SUBROUTINE updateT
132
133   SUBROUTINE updateS( tabres, i1, i2, j1, j2, k1, k2, before )
134      !!---------------------------------------------
135      !!           *** ROUTINE updateS ***
136      !!---------------------------------------------
137#  include "domzgr_substitute.h90"
138
139      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2
140      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres
141      LOGICAL, iNTENT(in) :: before
142
143      INTEGER :: ji,jj,jk
144
145      IF (before) THEN
146         DO jk=k1,k2
147            DO jj=j1,j2
148               DO ji=i1,i2
149                  tabres(ji,jj,jk) = sn(ji,jj,jk)
150               END DO
151            END DO
152         END DO
153      ELSE
154         DO jk=k1,k2
155            DO jj=j1,j2
156               DO ji=i1,i2
157                  IF (tabres(ji,jj,jk).NE.0.) THEN
158                     sn(ji,jj,jk) = tabres(ji,jj,jk) * tmask(ji,jj,jk)
159                  ENDIF
160               END DO
161            END DO
162         END DO
163      ENDIF
164
165   END SUBROUTINE updateS
166
167   SUBROUTINE updateu( tabres, i1, i2, j1, j2, k1, k2, before )
168      !!---------------------------------------------
169      !!           *** ROUTINE updateu ***
170      !!---------------------------------------------
171#  include "domzgr_substitute.h90"
172
173      INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2
174      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres
175      LOGICAL, INTENT(in) :: before
176
177      INTEGER :: ji, jj, jk
178      REAL(wp) :: zrhoy
179
180      IF (before) THEN
181         zrhoy = Agrif_Rhoy()
182         DO jk=k1,k2
183            DO jj=j1,j2
184               DO ji=i1,i2
185                  tabres(ji,jj,jk) = e2u(ji,jj) * un(ji,jj,jk)
186#if ! defined key_zco
187                  tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3u(ji,jj,jk)
188#endif
189               END DO
190            END DO
191         END DO
192         tabres = zrhoy * tabres
193      ELSE
194         DO jk=k1,k2
195            DO jj=j1,j2
196               DO ji=i1,i2
197                  un(ji,jj,jk) = tabres(ji,jj,jk) / (e2u(ji,jj))
198                  un(ji,jj,jk) = un(ji,jj,jk) * umask(ji,jj,jk)
199#if ! defined key_zco
200                  un(ji,jj,jk) = un(ji,jj,jk) / fse3u(ji,jj,jk)
201#endif
202               END DO
203            END DO
204         END DO
205      ENDIF
206
207   END SUBROUTINE updateu
208
209   SUBROUTINE updatev( tabres, i1, i2, j1, j2, k1, k2, before )
210      !!---------------------------------------------
211      !!           *** ROUTINE updatev ***
212      !!---------------------------------------------
213#  include "domzgr_substitute.h90"
214
215      INTEGER :: i1,i2,j1,j2,k1,k2
216      INTEGER :: ji,jj,jk
217      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: tabres
218      LOGICAL :: before
219
220      REAL(wp) :: zrhox
221
222      IF (before) THEN
223         zrhox = Agrif_Rhox()
224         DO jk=k1,k2
225            DO jj=j1,j2
226               DO ji=i1,i2
227                  tabres(ji,jj,jk) = e1v(ji,jj) * vn(ji,jj,jk)
228#if ! defined key_zco
229                  tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3v(ji,jj,jk)
230#endif
231               END DO
232            END DO
233         END DO
234         tabres = zrhox * tabres
235      ELSE
236         DO jk=k1,k2
237            DO jj=j1,j2
238               DO ji=i1,i2
239                  vn(ji,jj,jk) = tabres(ji,jj,jk) / (e1v(ji,jj))
240                  vn(ji,jj,jk) = vn(ji,jj,jk) * vmask(ji,jj,jk)
241#if ! defined key_zco
242                  vn(ji,jj,jk) = vn(ji,jj,jk) / fse3v(ji,jj,jk)
243#endif
244               END DO
245            END DO
246         END DO
247      ENDIF
248
249   END SUBROUTINE updatev
250
251   SUBROUTINE updateu2d( tabres, i1, i2, j1, j2, before )
252      !!---------------------------------------------
253      !!          *** ROUTINE updateu2d ***
254      !!---------------------------------------------
255#  include "domzgr_substitute.h90"
256
257      INTEGER, INTENT(in) :: i1, i2, j1, j2
258      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
259      LOGICAL, INTENT(in) :: before
260
261      INTEGER :: ji, jj, jk
262      REAL(wp) :: zrhoy
263      REAL(wp) :: zhinv
264
265      IF (before) THEN
266         zrhoy = Agrif_Rhoy()
267         DO jk = 1,jpkm1
268            DO jj=j1,j2
269               DO ji=i1,i2
270                  tabres(ji,jj) = tabres(ji,jj) + fse3u(ji,jj,jk) * un(ji,jj,jk)
271               END DO
272            END DO
273         END DO
274         DO jj=j1,j2
275            DO ji=i1,i2
276               tabres(ji,jj) = tabres(ji,jj) * e2u(ji,jj)
277            END DO
278         END DO
279         tabres = zrhoy * tabres
280      ELSE
281         DO jj=j1,j2
282            DO ji=i1,i2
283               IF(umask(ji,jj,1) .NE. 0.) THEN             
284                  spgu(ji,jj) = 0.e0
285                  DO jk=1,jpk
286                     spgu(ji,jj) = spgu(ji,jj) + fse3u(ji,jj,jk) * un(ji,jj,jk)
287                  END DO
288                  spgu(ji,jj) = spgu(ji,jj) * e2u(ji,jj)
289                  zhinv = (tabres(ji,jj)-spgu(ji,jj))/(hu(ji,jj)*e2u(ji,jj))
290                  Do jk=1,jpk             
291                     un(ji,jj,jk) = un(ji,jj,jk) + zhinv
292                     un(ji,jj,jk) = un(ji,jj,jk) * umask(ji,jj,jk)           
293                  END DO
294               ENDIF
295            END DO
296         END DO
297      ENDIF
298
299   END SUBROUTINE updateu2d
300
301   SUBROUTINE updatev2d( tabres, i1, i2, j1, j2, before )
302      !!---------------------------------------------
303      !!          *** ROUTINE updatev2d ***
304      !!---------------------------------------------
305
306      INTEGER, INTENT(in) :: i1, i2, j1, j2
307      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
308      LOGICAL, INTENT(in) :: before
309
310      INTEGER :: ji, jj, jk
311      REAL(wp) :: zrhox
312      REAL(wp) :: zhinv
313
314      IF (before) THEN
315         zrhox = Agrif_Rhox()
316         tabres = 0.e0
317         DO jk = 1,jpkm1
318            DO jj=j1,j2
319               DO ji=i1,i2
320                  tabres(ji,jj) = tabres(ji,jj) + fse3v(ji,jj,jk) * vn(ji,jj,jk)
321               END DO
322            END DO
323         END DO
324         DO jj=j1,j2
325            DO ji=i1,i2
326               tabres(ji,jj) = tabres(ji,jj) * e1v(ji,jj)
327            END DO
328         END DO
329         tabres = zrhox * tabres
330      ELSE
331         DO jj=j1,j2
332            DO ji=i1,i2
333               IF(vmask(ji,jj,1) .NE. 0.) THEN             
334                  spgv(ji,jj) = 0.
335                  DO jk=1,jpk
336                     spgv(ji,jj) = spgv(ji,jj) + fse3v(ji,jj,jk) * vn(ji,jj,jk)
337                  END DO
338                  spgv(ji,jj) = spgv(ji,jj) * e1v(ji,jj)
339                  zhinv = (tabres(ji,jj)-spgv(ji,jj))/(hv(ji,jj)*e1v(ji,jj))
340                  DO jk=1,jpk             
341                     vn(ji,jj,jk) = vn(ji,jj,jk) + zhinv
342                     vn(ji,jj,jk) = vn(ji,jj,jk) * vmask(ji,jj,jk)
343                  END DO
344               ENDIF
345            END DO
346         END DO
347      ENDIF
348
349   END SUBROUTINE updatev2d
350
351   SUBROUTINE updateSSH( tabres, i1, i2, j1, j2, before )
352      !!---------------------------------------------
353      !!          *** ROUTINE updateSSH ***
354      !!---------------------------------------------
355#  include "domzgr_substitute.h90"
356
357      INTEGER, INTENT(in) :: i1, i2, j1, j2
358      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
359      LOGICAL, INTENT(in) :: before
360
361      INTEGER :: ji, jj
362      REAL(wp) :: zrhox, zrhoy
363
364      IF (before) THEN
365         zrhox = Agrif_Rhox()
366         zrhoy = Agrif_Rhoy()
367         DO jj=j1,j2
368            DO ji=i1,i2
369               tabres(ji,jj) = e1t(ji,jj) * e2t(ji,jj) * sshn(ji,jj)
370            END DO
371         END DO
372         tabres = zrhox * zrhoy * tabres
373      ELSE
374         DO jj=j1,j2
375            DO ji=i1,i2
376               sshn(ji,jj) = tabres(ji,jj) / (e1t(ji,jj) * e2t(ji,jj))
377               sshn(ji,jj) = sshn(ji,jj) * tmask(ji,jj,1)
378            END DO
379         END DO
380      ENDIF
381
382   END SUBROUTINE updateSSH
383
384#else
385CONTAINS
386   SUBROUTINE agrif_opa_update_empty
387      !!---------------------------------------------
388      !!   *** ROUTINE agrif_opa_update_empty ***
389      !!---------------------------------------------
390      WRITE(*,*)  'agrif_opa_update : You should not have seen this print! error?'
391   END SUBROUTINE agrif_opa_update_empty
392#endif
393END MODULE agrif_opa_update
Note: See TracBrowser for help on using the repository browser.