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 branches/DEV_r2106_LOCEAN2010/NEMO/NST_SRC – NEMO

source: branches/DEV_r2106_LOCEAN2010/NEMO/NST_SRC/agrif_opa_update.F90 @ 2240

Last change on this file since 2240 was 2240, checked in by cetlod, 14 years ago

Suppression of key_zco everywhere in the code
  • 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      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               END DO
201            END DO
202         END DO
203         tabres = zrhoy * tabres
204      ELSE
205         DO jk=k1,k2
206            DO jj=j1,j2
207               DO ji=i1,i2
208                  un(ji,jj,jk) = tabres(ji,jj,jk) / (e2u(ji,jj))
209                  un(ji,jj,jk) = un(ji,jj,jk) * umask(ji,jj,jk)
210                  un(ji,jj,jk) = un(ji,jj,jk) / fse3u(ji,jj,jk)
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                  tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3v(ji,jj,jk)
238               END DO
239            END DO
240         END DO
241         tabres = zrhox * tabres
242      ELSE
243         DO jk=k1,k2
244            DO jj=j1,j2
245               DO ji=i1,i2
246                  vn(ji,jj,jk) = tabres(ji,jj,jk) / (e1v(ji,jj))
247                  vn(ji,jj,jk) = vn(ji,jj,jk) * vmask(ji,jj,jk)
248                  vn(ji,jj,jk) = vn(ji,jj,jk) / fse3v(ji,jj,jk)
249               END DO
250            END DO
251         END DO
252      ENDIF
253
254   END SUBROUTINE updatev
255
256   SUBROUTINE updateu2d( tabres, i1, i2, j1, j2, before )
257      !!---------------------------------------------
258      !!          *** ROUTINE updateu2d ***
259      !!---------------------------------------------
260#  include "domzgr_substitute.h90"
261
262      INTEGER, INTENT(in) :: i1, i2, j1, j2
263      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
264      LOGICAL, INTENT(in) :: before
265
266      INTEGER :: ji, jj, jk
267      REAL(wp) :: zrhoy
268      REAL(wp) :: zhinv
269
270      IF (before) THEN
271         zrhoy = Agrif_Rhoy()
272         DO jk = 1,jpkm1
273            DO jj=j1,j2
274               DO ji=i1,i2
275                  tabres(ji,jj) = tabres(ji,jj) + fse3u(ji,jj,jk) * un(ji,jj,jk)
276               END DO
277            END DO
278         END DO
279         DO jj=j1,j2
280            DO ji=i1,i2
281               tabres(ji,jj) = tabres(ji,jj) * e2u(ji,jj)
282            END DO
283         END DO
284         tabres = zrhoy * tabres
285      ELSE
286         DO jj=j1,j2
287            DO ji=i1,i2
288               IF(umask(ji,jj,1) .NE. 0.) THEN             
289                  spgu(ji,jj) = 0.e0
290                  DO jk=1,jpk
291                     spgu(ji,jj) = spgu(ji,jj) + fse3u(ji,jj,jk) * un(ji,jj,jk)
292                  END DO
293                  spgu(ji,jj) = spgu(ji,jj) * e2u(ji,jj)
294                  zhinv = (tabres(ji,jj)-spgu(ji,jj))/(hu(ji,jj)*e2u(ji,jj))
295                  Do jk=1,jpk             
296                     un(ji,jj,jk) = un(ji,jj,jk) + zhinv
297                     un(ji,jj,jk) = un(ji,jj,jk) * umask(ji,jj,jk)           
298                  END DO
299               ENDIF
300            END DO
301         END DO
302      ENDIF
303
304   END SUBROUTINE updateu2d
305
306   SUBROUTINE updatev2d( tabres, i1, i2, j1, j2, before )
307      !!---------------------------------------------
308      !!          *** ROUTINE updatev2d ***
309      !!---------------------------------------------
310
311      INTEGER, INTENT(in) :: i1, i2, j1, j2
312      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
313      LOGICAL, INTENT(in) :: before
314
315      INTEGER :: ji, jj, jk
316      REAL(wp) :: zrhox
317      REAL(wp) :: zhinv
318
319      IF (before) THEN
320         zrhox = Agrif_Rhox()
321         tabres = 0.e0
322         DO jk = 1,jpkm1
323            DO jj=j1,j2
324               DO ji=i1,i2
325                  tabres(ji,jj) = tabres(ji,jj) + fse3v(ji,jj,jk) * vn(ji,jj,jk)
326               END DO
327            END DO
328         END DO
329         DO jj=j1,j2
330            DO ji=i1,i2
331               tabres(ji,jj) = tabres(ji,jj) * e1v(ji,jj)
332            END DO
333         END DO
334         tabres = zrhox * tabres
335      ELSE
336         DO jj=j1,j2
337            DO ji=i1,i2
338               IF(vmask(ji,jj,1) .NE. 0.) THEN             
339                  spgv(ji,jj) = 0.
340                  DO jk=1,jpk
341                     spgv(ji,jj) = spgv(ji,jj) + fse3v(ji,jj,jk) * vn(ji,jj,jk)
342                  END DO
343                  spgv(ji,jj) = spgv(ji,jj) * e1v(ji,jj)
344                  zhinv = (tabres(ji,jj)-spgv(ji,jj))/(hv(ji,jj)*e1v(ji,jj))
345                  DO jk=1,jpk             
346                     vn(ji,jj,jk) = vn(ji,jj,jk) + zhinv
347                     vn(ji,jj,jk) = vn(ji,jj,jk) * vmask(ji,jj,jk)
348                  END DO
349               ENDIF
350            END DO
351         END DO
352      ENDIF
353
354   END SUBROUTINE updatev2d
355
356   SUBROUTINE updateSSH( tabres, i1, i2, j1, j2, before )
357      !!---------------------------------------------
358      !!          *** ROUTINE updateSSH ***
359      !!---------------------------------------------
360#  include "domzgr_substitute.h90"
361
362      INTEGER, INTENT(in) :: i1, i2, j1, j2
363      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
364      LOGICAL, INTENT(in) :: before
365
366      INTEGER :: ji, jj
367      REAL(wp) :: zrhox, zrhoy
368
369      IF (before) THEN
370         zrhox = Agrif_Rhox()
371         zrhoy = Agrif_Rhoy()
372         DO jj=j1,j2
373            DO ji=i1,i2
374               tabres(ji,jj) = e1t(ji,jj) * e2t(ji,jj) * sshn(ji,jj)
375            END DO
376         END DO
377         tabres = zrhox * zrhoy * tabres
378      ELSE
379         DO jj=j1,j2
380            DO ji=i1,i2
381               sshn(ji,jj) = tabres(ji,jj) / (e1t(ji,jj) * e2t(ji,jj))
382               sshn(ji,jj) = sshn(ji,jj) * tmask(ji,jj,1)
383            END DO
384         END DO
385      ENDIF
386
387   END SUBROUTINE updateSSH
388
389#else
390CONTAINS
391   SUBROUTINE agrif_opa_update_empty
392      !!---------------------------------------------
393      !!   *** ROUTINE agrif_opa_update_empty ***
394      !!---------------------------------------------
395      WRITE(*,*)  'agrif_opa_update : You should not have seen this print! error?'
396   END SUBROUTINE agrif_opa_update_empty
397#endif
398END MODULE agrif_opa_update
Note: See TracBrowser for help on using the repository browser.