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

Last change on this file since 1158 was 1156, checked in by rblod, 16 years ago

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