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

Last change on this file since 941 was 782, checked in by rblod, 16 years ago

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