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

Last change on this file since 699 was 699, checked in by smasson, 17 years ago

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