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

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

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